Commit | Line | Data |
---|---|---|
44d21104 | 1 | # -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*- |
e82b9348 | 2 | use strict; |
8962fc49 | 3 | package CPAN; |
ecc7fca0 | 4 | $CPAN::VERSION = '1.9205'; |
23a216b4 | 5 | $CPAN::VERSION = eval $CPAN::VERSION if $CPAN::VERSION =~ /_/; |
5f05dabc | 6 | |
e82b9348 | 7 | use CPAN::HandleConfig; |
554a9ef5 | 8 | use CPAN::Version; |
e82b9348 | 9 | use CPAN::Debug; |
135a59c2 | 10 | use CPAN::Queue; |
e82b9348 | 11 | use CPAN::Tarzip; |
f04ea8d1 | 12 | use CPAN::DeferedCode; |
5f05dabc | 13 | use Carp (); |
14 | use Config (); | |
15 | use Cwd (); | |
0cf35e6a | 16 | use DirHandle (); |
5f05dabc | 17 | use Exporter (); |
b96578bb SP |
18 | use ExtUtils::MakeMaker qw(prompt); # for some unknown reason, |
19 | # 5.005_04 does not work without | |
20 | # this | |
5f05dabc | 21 | use File::Basename (); |
10b2abe6 | 22 | use File::Copy (); |
5f05dabc | 23 | use File::Find; |
24 | use File::Path (); | |
0cf35e6a | 25 | use File::Spec (); |
da199366 | 26 | use FileHandle (); |
05bab18e | 27 | use Fcntl qw(:flock); |
5f05dabc | 28 | use Safe (); |
0cf35e6a | 29 | use Sys::Hostname qw(hostname); |
10b2abe6 | 30 | use Text::ParseWords (); |
0cf35e6a | 31 | use Text::Wrap (); |
8962fc49 | 32 | |
b03f445c RGS |
33 | sub find_perl (); |
34 | ||
8962fc49 SP |
35 | # we need to run chdir all over and we would get at wrong libraries |
36 | # there | |
37 | BEGIN { | |
38 | if (File::Spec->can("rel2abs")) { | |
39 | for my $inc (@INC) { | |
2b3bde2a | 40 | $inc = File::Spec->rel2abs($inc) unless ref $inc; |
8962fc49 SP |
41 | } |
42 | } | |
43 | } | |
44 | no lib "."; | |
5f05dabc | 45 | |
be708cc0 | 46 | require Mac::BuildTools if $^O eq 'MacOS'; |
f04ea8d1 SP |
47 | $ENV{PERL5_CPAN_IS_RUNNING}=$$; |
48 | $ENV{PERL5_CPANPLUS_IS_RUNNING}=$$; # https://rt.cpan.org/Ticket/Display.html?id=23735 | |
be708cc0 | 49 | |
e82b9348 SP |
50 | END { $CPAN::End++; &cleanup; } |
51 | ||
da199366 | 52 | $CPAN::Signal ||= 0; |
c356248b | 53 | $CPAN::Frontend ||= "CPAN::Shell"; |
f04ea8d1 | 54 | unless (@CPAN::Defaultsites) { |
7fefbd44 RGS |
55 | @CPAN::Defaultsites = map { |
56 | CPAN::URL->new(TEXT => $_, FROM => "DEF") | |
57 | } | |
58 | "http://www.perl.org/CPAN/", | |
59 | "ftp://ftp.perl.org/pub/CPAN/"; | |
60 | } | |
0cf35e6a | 61 | # $CPAN::iCwd (i for initial) is going to be initialized during find_perl |
607a774b | 62 | $CPAN::Perl ||= CPAN::find_perl(); |
554a9ef5 | 63 | $CPAN::Defaultdocs ||= "http://search.cpan.org/perldoc?"; |
f04ea8d1 SP |
64 | $CPAN::Defaultrecent ||= "http://search.cpan.org/uploads.rdf"; |
65 | $CPAN::Defaultrecent ||= "http://cpan.uwinnipeg.ca/htdocs/cpan.xml"; | |
607a774b | 66 | |
05bab18e | 67 | # our globals are getting a mess |
6658a91b SP |
68 | use vars qw( |
69 | $AUTOLOAD | |
135a59c2 | 70 | $Be_Silent |
6658a91b | 71 | $CONFIG_DIRTY |
6658a91b | 72 | $Defaultdocs |
2b3bde2a | 73 | $Echo_readline |
6658a91b SP |
74 | $Frontend |
75 | $GOTOSHELL | |
76 | $HAS_USABLE | |
77 | $Have_warned | |
f20de9f0 | 78 | $MAX_RECURSION |
6658a91b | 79 | $META |
05bab18e | 80 | $RUN_DEGRADED |
6658a91b | 81 | $Signal |
be34b10d | 82 | $SQLite |
6658a91b SP |
83 | $Suppress_readline |
84 | $VERSION | |
135a59c2 | 85 | $autoload_recursion |
6658a91b SP |
86 | $term |
87 | @Defaultsites | |
88 | @EXPORT | |
135a59c2 | 89 | ); |
6d29edf5 | 90 | |
f20de9f0 SP |
91 | $MAX_RECURSION = 32; |
92 | ||
2e2b7522 | 93 | @CPAN::ISA = qw(CPAN::Debug Exporter); |
5f05dabc | 94 | |
44d21104 A |
95 | # note that these functions live in CPAN::Shell and get executed via |
96 | # AUTOLOAD when called directly | |
55e314ee | 97 | @EXPORT = qw( |
44d21104 A |
98 | autobundle |
99 | bundle | |
100 | clean | |
101 | cvs_import | |
102 | expand | |
103 | force | |
b72dd56f | 104 | fforce |
44d21104 A |
105 | get |
106 | install | |
05bab18e | 107 | install_tested |
f20de9f0 | 108 | is_tested |
44d21104 A |
109 | make |
110 | mkmyconfig | |
111 | notest | |
112 | perldoc | |
113 | readme | |
114 | recent | |
115 | recompile | |
8fc516fe | 116 | report |
44d21104 | 117 | shell |
f04ea8d1 | 118 | smoke |
44d21104 | 119 | test |
ed84aac9 | 120 | upgrade |
f04ea8d1 | 121 | ); |
5f05dabc | 122 | |
0cf35e6a SP |
123 | sub soft_chdir_with_alternatives ($); |
124 | ||
135a59c2 A |
125 | { |
126 | $autoload_recursion ||= 0; | |
127 | ||
128 | #-> sub CPAN::AUTOLOAD ; | |
129 | sub AUTOLOAD { | |
130 | $autoload_recursion++; | |
131 | my($l) = $AUTOLOAD; | |
132 | $l =~ s/.*:://; | |
133 | if ($CPAN::Signal) { | |
134 | warn "Refusing to autoload '$l' while signal pending"; | |
135 | $autoload_recursion--; | |
136 | return; | |
137 | } | |
138 | if ($autoload_recursion > 1) { | |
139 | my $fullcommand = join " ", map { "'$_'" } $l, @_; | |
140 | warn "Refusing to autoload $fullcommand in recursion\n"; | |
141 | $autoload_recursion--; | |
142 | return; | |
143 | } | |
144 | my(%export); | |
145 | @export{@EXPORT} = ''; | |
146 | CPAN::HandleConfig->load unless $CPAN::Config_loaded++; | |
f04ea8d1 | 147 | if (exists $export{$l}) { |
135a59c2 A |
148 | CPAN::Shell->$l(@_); |
149 | } else { | |
150 | die(qq{Unknown CPAN command "$AUTOLOAD". }. | |
151 | qq{Type ? for help.\n}); | |
152 | } | |
153 | $autoload_recursion--; | |
55e314ee A |
154 | } |
155 | } | |
156 | ||
157 | #-> sub CPAN::shell ; | |
158 | sub shell { | |
36263cb3 | 159 | my($self) = @_; |
911a92db | 160 | $Suppress_readline = ! -t STDIN unless defined $Suppress_readline; |
e82b9348 | 161 | CPAN::HandleConfig->load unless $CPAN::Config_loaded++; |
55e314ee | 162 | |
9ddc4ed0 | 163 | my $oprompt = shift || CPAN::Prompt->new; |
9d61fa1d A |
164 | my $prompt = $oprompt; |
165 | my $commandline = shift || ""; | |
9ddc4ed0 | 166 | $CPAN::CurrentCommandId ||= 1; |
5e05dca5 | 167 | |
55e314ee A |
168 | local($^W) = 1; |
169 | unless ($Suppress_readline) { | |
f04ea8d1 | 170 | require Term::ReadLine; |
9d61fa1d A |
171 | if (! $term |
172 | or | |
173 | $term->ReadLine eq "Term::ReadLine::Stub" | |
174 | ) { | |
175 | $term = Term::ReadLine->new('CPAN Monitor'); | |
176 | } | |
f04ea8d1 SP |
177 | if ($term->ReadLine eq "Term::ReadLine::Gnu") { |
178 | my $attribs = $term->Attribs; | |
179 | $attribs->{attempted_completion_function} = sub { | |
180 | &CPAN::Complete::gnu_cpl; | |
181 | } | |
182 | } else { | |
183 | $readline::rl_completion_function = | |
184 | $readline::rl_completion_function = 'CPAN::Complete::cpl'; | |
185 | } | |
5fc0f0f6 JH |
186 | if (my $histfile = $CPAN::Config->{'histfile'}) {{ |
187 | unless ($term->can("AddHistory")) { | |
188 | $CPAN::Frontend->mywarn("Terminal does not support AddHistory.\n"); | |
189 | last; | |
190 | } | |
f20de9f0 | 191 | $META->readhist($term,$histfile); |
5fc0f0f6 | 192 | }} |
8962fc49 SP |
193 | for ($CPAN::Config->{term_ornaments}) { # alias |
194 | local $Term::ReadLine::termcap_nowarn = 1; | |
ed84aac9 A |
195 | $term->ornaments($_) if defined; |
196 | } | |
f04ea8d1 SP |
197 | # $term->OUT is autoflushed anyway |
198 | my $odef = select STDERR; | |
199 | $| = 1; | |
200 | select STDOUT; | |
201 | $| = 1; | |
202 | select $odef; | |
55e314ee A |
203 | } |
204 | ||
55e314ee | 205 | $META->checklock(); |
135a59c2 A |
206 | my @cwd = grep { defined $_ and length $_ } |
207 | CPAN::anycwd(), | |
208 | File::Spec->can("tmpdir") ? File::Spec->tmpdir() : (), | |
209 | File::Spec->rootdir(); | |
911a92db GS |
210 | my $try_detect_readline; |
211 | $try_detect_readline = $term->ReadLine eq "Term::ReadLine::Stub" if $term; | |
f04ea8d1 SP |
212 | unless ($CPAN::Config->{inhibit_startup_message}) { |
213 | my $rl_avail = $Suppress_readline ? "suppressed" : | |
214 | ($term->ReadLine ne "Term::ReadLine::Stub") ? "enabled" : | |
215 | "available (maybe install Bundle::CPAN or Bundle::CPANxxl?)"; | |
8962fc49 SP |
216 | $CPAN::Frontend->myprint( |
217 | sprintf qq{ | |
554a9ef5 | 218 | cpan shell -- CPAN exploration and modules installation (v%s) |
6d29edf5 | 219 | ReadLine support %s |
55e314ee | 220 | |
6d29edf5 | 221 | }, |
8962fc49 SP |
222 | $CPAN::VERSION, |
223 | $rl_avail | |
224 | ) | |
225 | } | |
c356248b | 226 | my($continuation) = ""; |
8962fc49 | 227 | my $last_term_ornaments; |
8d97e4a1 | 228 | SHELLCOMMAND: while () { |
f04ea8d1 | 229 | if ($Suppress_readline) { |
2b3bde2a SP |
230 | if ($Echo_readline) { |
231 | $|=1; | |
232 | } | |
f04ea8d1 SP |
233 | print $prompt; |
234 | last SHELLCOMMAND unless defined ($_ = <> ); | |
2b3bde2a SP |
235 | if ($Echo_readline) { |
236 | # backdoor: I could not find a way to record sessions | |
237 | print $_; | |
238 | } | |
f04ea8d1 SP |
239 | chomp; |
240 | } else { | |
241 | last SHELLCOMMAND unless | |
8d97e4a1 | 242 | defined ($_ = $term->readline($prompt, $commandline)); |
f04ea8d1 SP |
243 | } |
244 | $_ = "$continuation$_" if $continuation; | |
245 | s/^\s+//; | |
246 | next SHELLCOMMAND if /^$/; | |
247 | s/^\s*\?\s*/help /; | |
248 | if (/^(?:q(?:uit)?|bye|exit)$/i) { | |
249 | last SHELLCOMMAND; | |
250 | } elsif (s/\\$//s) { | |
251 | chomp; | |
252 | $continuation = $_; | |
253 | $prompt = " > "; | |
254 | } elsif (/^\!/) { | |
255 | s/^\!//; | |
256 | my($eval) = $_; | |
257 | package CPAN::Eval; | |
e82b9348 | 258 | use strict; |
f04ea8d1 SP |
259 | use vars qw($import_done); |
260 | CPAN->import(':DEFAULT') unless $import_done++; | |
261 | CPAN->debug("eval[$eval]") if $CPAN::DEBUG; | |
262 | eval($eval); | |
263 | warn $@ if $@; | |
264 | $continuation = ""; | |
265 | $prompt = $oprompt; | |
266 | } elsif (/./) { | |
267 | my(@line); | |
6a935156 SP |
268 | eval { @line = Text::ParseWords::shellwords($_) }; |
269 | warn($@), next SHELLCOMMAND if $@; | |
270 | warn("Text::Parsewords could not parse the line [$_]"), | |
271 | next SHELLCOMMAND unless @line; | |
f04ea8d1 SP |
272 | $CPAN::META->debug("line[".join("|",@line)."]") if $CPAN::DEBUG; |
273 | my $command = shift @line; | |
274 | eval { CPAN::Shell->$command(@line) }; | |
275 | if ($@) { | |
276 | my $err = "$@"; | |
277 | if ($err =~ /\S/) { | |
278 | require Carp; | |
279 | require Dumpvalue; | |
280 | my $dv = Dumpvalue->new(); | |
281 | Carp::cluck(sprintf "Catching error: %s", $dv->stringify($err)); | |
282 | } | |
283 | } | |
284 | if ($command =~ /^( | |
285 | # classic commands | |
286 | make | |
287 | |test | |
288 | |install | |
289 | |clean | |
290 | ||
291 | # pragmas for classic commands | |
292 | |ff?orce | |
293 | |notest | |
294 | ||
295 | # compounds | |
296 | |report | |
297 | |smoke | |
298 | |upgrade | |
299 | )$/x) { | |
300 | # only commands that tell us something about failed distros | |
9ddc4ed0 A |
301 | CPAN::Shell->failed($CPAN::CurrentCommandId,1); |
302 | } | |
0cf35e6a | 303 | soft_chdir_with_alternatives(\@cwd); |
f04ea8d1 SP |
304 | $CPAN::Frontend->myprint("\n"); |
305 | $continuation = ""; | |
9ddc4ed0 | 306 | $CPAN::CurrentCommandId++; |
f04ea8d1 SP |
307 | $prompt = $oprompt; |
308 | } | |
55e314ee | 309 | } continue { |
f04ea8d1 SP |
310 | $commandline = ""; # I do want to be able to pass a default to |
311 | # shell, but on the second command I see no | |
312 | # use in that | |
313 | $Signal=0; | |
314 | CPAN::Queue->nullify_queue; | |
315 | if ($try_detect_readline) { | |
316 | if ($CPAN::META->has_inst("Term::ReadLine::Gnu") | |
317 | || | |
318 | $CPAN::META->has_inst("Term::ReadLine::Perl") | |
319 | ) { | |
320 | delete $INC{"Term/ReadLine.pm"}; | |
321 | my $redef = 0; | |
322 | local($SIG{__WARN__}) = CPAN::Shell::paintdots_onreload(\$redef); | |
323 | require Term::ReadLine; | |
324 | $CPAN::Frontend->myprint("\n$redef subroutines in ". | |
325 | "Term::ReadLine redefined\n"); | |
326 | $GOTOSHELL = 1; | |
327 | } | |
328 | } | |
329 | if ($term and $term->can("ornaments")) { | |
330 | for ($CPAN::Config->{term_ornaments}) { # alias | |
331 | if (defined $_) { | |
332 | if (not defined $last_term_ornaments | |
333 | or $_ != $last_term_ornaments | |
334 | ) { | |
335 | local $Term::ReadLine::termcap_nowarn = 1; | |
336 | $term->ornaments($_); | |
337 | $last_term_ornaments = $_; | |
338 | } | |
339 | } else { | |
340 | undef $last_term_ornaments; | |
341 | } | |
342 | } | |
343 | } | |
344 | for my $class (qw(Module Distribution)) { | |
345 | # again unsafe meta access? | |
346 | for my $dm (keys %{$CPAN::META->{readwrite}{"CPAN::$class"}}) { | |
347 | next unless $CPAN::META->{readwrite}{"CPAN::$class"}{$dm}{incommandcolor}; | |
348 | CPAN->debug("BUG: $class '$dm' was in command state, resetting"); | |
349 | delete $CPAN::META->{readwrite}{"CPAN::$class"}{$dm}{incommandcolor}; | |
350 | } | |
351 | } | |
352 | if ($GOTOSHELL) { | |
353 | $GOTOSHELL = 0; # not too often | |
354 | $META->savehist if $CPAN::term && $CPAN::term->can("GetHistory"); | |
355 | @_ = ($oprompt,""); | |
356 | goto &shell; | |
357 | } | |
55e314ee | 358 | } |
0cf35e6a | 359 | soft_chdir_with_alternatives(\@cwd); |
55e314ee A |
360 | } |
361 | ||
ecc7fca0 | 362 | #-> CPAN::soft_chdir_with_alternatives ; |
0cf35e6a SP |
363 | sub soft_chdir_with_alternatives ($) { |
364 | my($cwd) = @_; | |
135a59c2 A |
365 | unless (@$cwd) { |
366 | my $root = File::Spec->rootdir(); | |
367 | $CPAN::Frontend->mywarn(qq{Warning: no good directory to chdir to! | |
368 | Trying '$root' as temporary haven. | |
0cf35e6a | 369 | }); |
135a59c2 A |
370 | push @$cwd, $root; |
371 | } | |
372 | while () { | |
373 | if (chdir $cwd->[0]) { | |
374 | return; | |
0cf35e6a | 375 | } else { |
135a59c2 A |
376 | if (@$cwd>1) { |
377 | $CPAN::Frontend->mywarn(qq{Could not chdir to "$cwd->[0]": $! | |
378 | Trying to chdir to "$cwd->[1]" instead. | |
379 | }); | |
380 | shift @$cwd; | |
381 | } else { | |
382 | $CPAN::Frontend->mydie(qq{Could not chdir to "$cwd->[0]": $!}); | |
383 | } | |
0cf35e6a SP |
384 | } |
385 | } | |
386 | } | |
44d21104 | 387 | |
f04ea8d1 SP |
388 | sub _flock { |
389 | my($fh,$mode) = @_; | |
390 | if ($Config::Config{d_flock}) { | |
391 | return flock $fh, $mode; | |
392 | } elsif (!$Have_warned->{"d_flock"}++) { | |
393 | $CPAN::Frontend->mywarn("Your OS does not support locking; continuing and ignoring all locking issues\n"); | |
394 | $CPAN::Frontend->mysleep(5); | |
395 | return 1; | |
396 | } else { | |
397 | return 1; | |
398 | } | |
399 | } | |
400 | ||
b72dd56f | 401 | sub _yaml_module () { |
05bab18e SP |
402 | my $yaml_module = $CPAN::Config->{yaml_module} || "YAML"; |
403 | if ( | |
404 | $yaml_module ne "YAML" | |
405 | && | |
406 | !$CPAN::META->has_inst($yaml_module) | |
407 | ) { | |
408 | # $CPAN::Frontend->mywarn("'$yaml_module' not installed, falling back to 'YAML'\n"); | |
409 | $yaml_module = "YAML"; | |
410 | } | |
ade94d80 SP |
411 | if ($yaml_module eq "YAML" |
412 | && | |
413 | $CPAN::META->has_inst($yaml_module) | |
414 | && | |
415 | $YAML::VERSION < 0.60 | |
416 | && | |
417 | !$Have_warned->{"YAML"}++ | |
418 | ) { | |
419 | $CPAN::Frontend->mywarn("Warning: YAML version '$YAML::VERSION' is too low, please upgrade!\n". | |
420 | "I'll continue but problems are *very* likely to happen.\n" | |
421 | ); | |
422 | $CPAN::Frontend->mysleep(5); | |
423 | } | |
05bab18e SP |
424 | return $yaml_module; |
425 | } | |
426 | ||
1e8f9a0a SP |
427 | # CPAN::_yaml_loadfile |
428 | sub _yaml_loadfile { | |
429 | my($self,$local_file) = @_; | |
05bab18e | 430 | return +[] unless -s $local_file; |
b72dd56f | 431 | my $yaml_module = _yaml_module; |
1e8f9a0a | 432 | if ($CPAN::META->has_inst($yaml_module)) { |
f04ea8d1 SP |
433 | # temporarly enable yaml code deserialisation |
434 | no strict 'refs'; | |
435 | # 5.6.2 could not do the local() with the reference | |
436 | local $YAML::LoadCode; | |
437 | local $YAML::Syck::LoadCode; | |
438 | ${ "$yaml_module\::LoadCode" } = $CPAN::Config->{yaml_load_code} || 0; | |
439 | ||
f20de9f0 SP |
440 | my $code; |
441 | if ($code = UNIVERSAL::can($yaml_module, "LoadFile")) { | |
442 | my @yaml; | |
443 | eval { @yaml = $code->($local_file); }; | |
444 | if ($@) { | |
445 | # this shall not be done by the frontend | |
446 | die CPAN::Exception::yaml_process_error->new($yaml_module,$local_file,"parse",$@); | |
447 | } | |
448 | return \@yaml; | |
449 | } elsif ($code = UNIVERSAL::can($yaml_module, "Load")) { | |
450 | local *FH; | |
451 | open FH, $local_file or die "Could not open '$local_file': $!"; | |
452 | local $/; | |
453 | my $ystream = <FH>; | |
454 | my @yaml; | |
455 | eval { @yaml = $code->($ystream); }; | |
456 | if ($@) { | |
457 | # this shall not be done by the frontend | |
458 | die CPAN::Exception::yaml_process_error->new($yaml_module,$local_file,"parse",$@); | |
459 | } | |
460 | return \@yaml; | |
1e8f9a0a | 461 | } |
1e8f9a0a | 462 | } else { |
b72dd56f SP |
463 | # this shall not be done by the frontend |
464 | die CPAN::Exception::yaml_not_installed->new($yaml_module, $local_file, "parse"); | |
1e8f9a0a | 465 | } |
6658a91b | 466 | return +[]; |
1e8f9a0a SP |
467 | } |
468 | ||
05bab18e SP |
469 | # CPAN::_yaml_dumpfile |
470 | sub _yaml_dumpfile { | |
b72dd56f SP |
471 | my($self,$local_file,@what) = @_; |
472 | my $yaml_module = _yaml_module; | |
05bab18e | 473 | if ($CPAN::META->has_inst($yaml_module)) { |
f20de9f0 | 474 | my $code; |
b72dd56f | 475 | if (UNIVERSAL::isa($local_file, "FileHandle")) { |
f20de9f0 | 476 | $code = UNIVERSAL::can($yaml_module, "Dump"); |
b72dd56f | 477 | eval { print $local_file $code->(@what) }; |
f20de9f0 | 478 | } elsif ($code = UNIVERSAL::can($yaml_module, "DumpFile")) { |
b72dd56f | 479 | eval { $code->($local_file,@what); }; |
f20de9f0 SP |
480 | } elsif ($code = UNIVERSAL::can($yaml_module, "Dump")) { |
481 | local *FH; | |
482 | open FH, ">$local_file" or die "Could not open '$local_file': $!"; | |
483 | print FH $code->(@what); | |
05bab18e SP |
484 | } |
485 | if ($@) { | |
b72dd56f | 486 | die CPAN::Exception::yaml_process_error->new($yaml_module,$local_file,"dump",$@); |
05bab18e SP |
487 | } |
488 | } else { | |
b72dd56f | 489 | if (UNIVERSAL::isa($local_file, "FileHandle")) { |
be34b10d SP |
490 | # I think this case does not justify a warning at all |
491 | } else { | |
b72dd56f | 492 | die CPAN::Exception::yaml_not_installed->new($yaml_module, $local_file, "dump"); |
be34b10d | 493 | } |
05bab18e SP |
494 | } |
495 | } | |
496 | ||
be34b10d | 497 | sub _init_sqlite () { |
810a0276 | 498 | unless ($CPAN::META->has_inst("CPAN::SQLite")) { |
b72dd56f | 499 | $CPAN::Frontend->mywarn(qq{CPAN::SQLite not installed, trying to work without\n}) |
810a0276 | 500 | unless $Have_warned->{"CPAN::SQLite"}++; |
be34b10d SP |
501 | return; |
502 | } | |
810a0276 | 503 | require CPAN::SQLite::META; # not needed since CVS version of 2006-12-17 |
be34b10d SP |
504 | $CPAN::SQLite ||= CPAN::SQLite::META->new($CPAN::META); |
505 | } | |
506 | ||
810a0276 SP |
507 | { |
508 | my $negative_cache = {}; | |
509 | sub _sqlite_running { | |
510 | if ($negative_cache->{time} && time < $negative_cache->{time} + 60) { | |
511 | # need to cache the result, otherwise too slow | |
512 | return $negative_cache->{fact}; | |
513 | } else { | |
514 | $negative_cache = {}; # reset | |
515 | } | |
516 | my $ret = $CPAN::Config->{use_sqlite} && ($CPAN::SQLite || _init_sqlite()); | |
517 | return $ret if $ret; # fast anyway | |
518 | $negative_cache->{time} = time; | |
519 | return $negative_cache->{fact} = $ret; | |
520 | } | |
521 | } | |
522 | ||
55e314ee | 523 | package CPAN::CacheMgr; |
e82b9348 | 524 | use strict; |
c356248b | 525 | @CPAN::CacheMgr::ISA = qw(CPAN::InfoObj CPAN); |
55e314ee A |
526 | use File::Find; |
527 | ||
55e314ee | 528 | package CPAN::FTP; |
e82b9348 | 529 | use strict; |
05bab18e | 530 | use Fcntl qw(:flock); |
f04ea8d1 | 531 | use vars qw($connect_to_internet_ok $Ua $Thesite $ThesiteURL $Themethod); |
55e314ee A |
532 | @CPAN::FTP::ISA = qw(CPAN::Debug); |
533 | ||
c049f953 | 534 | package CPAN::LWP::UserAgent; |
e82b9348 | 535 | use strict; |
c049f953 | 536 | use vars qw(@ISA $USER $PASSWD $SETUPDONE); |
3c4b39be | 537 | # we delay requiring LWP::UserAgent and setting up inheritance until we need it |
c049f953 | 538 | |
55e314ee | 539 | package CPAN::Complete; |
e82b9348 | 540 | use strict; |
55e314ee | 541 | @CPAN::Complete::ISA = qw(CPAN::Debug); |
05bab18e SP |
542 | # Q: where is the "How do I add a new command" HOWTO? |
543 | # A: svn diff -r 1048:1049 where andk added the report command | |
9d61fa1d | 544 | @CPAN::Complete::COMMANDS = sort qw( |
f04ea8d1 | 545 | ? ! a b d h i m o q r u |
0cf35e6a | 546 | autobundle |
f04ea8d1 | 547 | bye |
0cf35e6a SP |
548 | clean |
549 | cvs_import | |
550 | dump | |
f04ea8d1 | 551 | exit |
f20de9f0 | 552 | failed |
0cf35e6a | 553 | force |
b72dd56f | 554 | fforce |
05bab18e | 555 | hosts |
0cf35e6a | 556 | install |
05bab18e | 557 | install_tested |
f20de9f0 | 558 | is_tested |
0cf35e6a SP |
559 | look |
560 | ls | |
44d21104 A |
561 | make |
562 | mkmyconfig | |
0cf35e6a SP |
563 | notest |
564 | perldoc | |
f04ea8d1 | 565 | quit |
0cf35e6a SP |
566 | readme |
567 | recent | |
44d21104 | 568 | recompile |
0cf35e6a | 569 | reload |
8fc516fe | 570 | report |
dc053c64 | 571 | reports |
ed84aac9 | 572 | scripts |
f04ea8d1 | 573 | smoke |
44d21104 | 574 | test |
ed84aac9 | 575 | upgrade |
0cf35e6a | 576 | ); |
55e314ee A |
577 | |
578 | package CPAN::Index; | |
e82b9348 | 579 | use strict; |
05bab18e | 580 | use vars qw($LAST_TIME $DATE_OF_02 $DATE_OF_03 $HAVE_REANIMATED); |
55e314ee | 581 | @CPAN::Index::ISA = qw(CPAN::Debug); |
c049f953 JH |
582 | $LAST_TIME ||= 0; |
583 | $DATE_OF_03 ||= 0; | |
6d29edf5 JH |
584 | # use constant PROTOCOL => "2.0"; # outcommented to avoid warning on upgrade from 1.57 |
585 | sub PROTOCOL { 2.0 } | |
55e314ee A |
586 | |
587 | package CPAN::InfoObj; | |
e82b9348 | 588 | use strict; |
55e314ee A |
589 | @CPAN::InfoObj::ISA = qw(CPAN::Debug); |
590 | ||
591 | package CPAN::Author; | |
e82b9348 | 592 | use strict; |
55e314ee A |
593 | @CPAN::Author::ISA = qw(CPAN::InfoObj); |
594 | ||
595 | package CPAN::Distribution; | |
e82b9348 | 596 | use strict; |
55e314ee A |
597 | @CPAN::Distribution::ISA = qw(CPAN::InfoObj); |
598 | ||
599 | package CPAN::Bundle; | |
e82b9348 | 600 | use strict; |
55e314ee A |
601 | @CPAN::Bundle::ISA = qw(CPAN::Module); |
602 | ||
603 | package CPAN::Module; | |
e82b9348 | 604 | use strict; |
55e314ee | 605 | @CPAN::Module::ISA = qw(CPAN::InfoObj); |
10b2abe6 | 606 | |
35576f8c | 607 | package CPAN::Exception::RecursiveDependency; |
e82b9348 | 608 | use strict; |
35576f8c A |
609 | use overload '""' => "as_string"; |
610 | ||
f20de9f0 SP |
611 | # a module sees its distribution (no version) |
612 | # a distribution sees its prereqs (which are module names) (usually with versions) | |
613 | # a bundle sees its module names and/or its distributions (no version) | |
614 | ||
35576f8c A |
615 | sub new { |
616 | my($class) = shift; | |
617 | my($deps) = shift; | |
ade94d80 SP |
618 | my (@deps,%seen,$loop_starts_with); |
619 | DCHAIN: for my $dep (@$deps) { | |
620 | push @deps, {name => $dep, display_as => $dep}; | |
f04ea8d1 | 621 | if ($seen{$dep}++) { |
ade94d80 SP |
622 | $loop_starts_with = $dep; |
623 | last DCHAIN; | |
624 | } | |
625 | } | |
626 | my $in_loop = 0; | |
627 | for my $i (0..$#deps) { | |
628 | my $x = $deps[$i]{name}; | |
629 | $in_loop ||= $x eq $loop_starts_with; | |
630 | my $xo = CPAN::Shell->expandany($x) or next; | |
631 | if ($xo->isa("CPAN::Module")) { | |
632 | my $have = $xo->inst_version || "N/A"; | |
633 | my($want,$d,$want_type); | |
634 | if ($i>0 and $d = $deps[$i-1]{name}) { | |
635 | my $do = CPAN::Shell->expandany($d); | |
636 | $want = $do->{prereq_pm}{requires}{$x}; | |
637 | if (defined $want) { | |
638 | $want_type = "requires: "; | |
639 | } else { | |
640 | $want = $do->{prereq_pm}{build_requires}{$x}; | |
641 | if (defined $want) { | |
642 | $want_type = "build_requires: "; | |
643 | } else { | |
644 | $want_type = "unknown status"; | |
645 | $want = "???"; | |
646 | } | |
647 | } | |
648 | } else { | |
649 | $want = $xo->cpan_version; | |
650 | $want_type = "want: "; | |
651 | } | |
652 | $deps[$i]{have} = $have; | |
653 | $deps[$i]{want_type} = $want_type; | |
654 | $deps[$i]{want} = $want; | |
655 | $deps[$i]{display_as} = "$x (have: $have; $want_type$want)"; | |
656 | } elsif ($xo->isa("CPAN::Distribution")) { | |
657 | $deps[$i]{display_as} = $xo->pretty_id; | |
658 | if ($in_loop) { | |
659 | $xo->{make} = CPAN::Distrostatus->new("NO cannot resolve circular dependency"); | |
660 | } else { | |
661 | $xo->{make} = CPAN::Distrostatus->new("NO one dependency ($loop_starts_with) is a circular dependency"); | |
662 | } | |
663 | $xo->store_persistent_state; # otherwise I will not reach | |
664 | # all involved parties for | |
665 | # the next session | |
666 | } | |
35576f8c A |
667 | } |
668 | bless { deps => \@deps }, $class; | |
669 | } | |
670 | ||
671 | sub as_string { | |
672 | my($self) = shift; | |
ade94d80 SP |
673 | my $ret = "\nRecursive dependency detected:\n "; |
674 | $ret .= join("\n => ", map {$_->{display_as}} @{$self->{deps}}); | |
675 | $ret .= ".\nCannot resolve.\n"; | |
676 | $ret; | |
35576f8c A |
677 | } |
678 | ||
b72dd56f SP |
679 | package CPAN::Exception::yaml_not_installed; |
680 | use strict; | |
681 | use overload '""' => "as_string"; | |
682 | ||
683 | sub new { | |
684 | my($class,$module,$file,$during) = @_; | |
685 | bless { module => $module, file => $file, during => $during }, $class; | |
686 | } | |
687 | ||
688 | sub as_string { | |
689 | my($self) = shift; | |
690 | "'$self->{module}' not installed, cannot $self->{during} '$self->{file}'\n"; | |
691 | } | |
692 | ||
693 | package CPAN::Exception::yaml_process_error; | |
694 | use strict; | |
695 | use overload '""' => "as_string"; | |
696 | ||
697 | sub new { | |
23a216b4 | 698 | my($class,$module,$file,$during,$error) = @_; |
b72dd56f SP |
699 | bless { module => $module, |
700 | file => $file, | |
701 | during => $during, | |
702 | error => $error }, $class; | |
703 | } | |
704 | ||
705 | sub as_string { | |
706 | my($self) = shift; | |
23a216b4 SP |
707 | if ($self->{during}) { |
708 | if ($self->{file}) { | |
709 | if ($self->{module}) { | |
710 | if ($self->{error}) { | |
711 | return "Alert: While trying to '$self->{during}' YAML file\n". | |
712 | " '$self->{file}'\n". | |
713 | "with '$self->{module}' the following error was encountered:\n". | |
714 | " $self->{error}\n"; | |
715 | } else { | |
716 | return "Alert: While trying to '$self->{during}' YAML file\n". | |
717 | " '$self->{file}'\n". | |
718 | "with '$self->{module}' some unknown error was encountered\n"; | |
719 | } | |
720 | } else { | |
721 | return "Alert: While trying to '$self->{during}' YAML file\n". | |
722 | " '$self->{file}'\n". | |
723 | "some unknown error was encountered\n"; | |
724 | } | |
725 | } else { | |
726 | return "Alert: While trying to '$self->{during}' some YAML file\n". | |
727 | "some unknown error was encountered\n"; | |
728 | } | |
729 | } else { | |
730 | return "Alert: unknown error encountered\n"; | |
731 | } | |
b72dd56f SP |
732 | } |
733 | ||
9ddc4ed0 | 734 | package CPAN::Prompt; use overload '""' => "as_string"; |
4d1321a7 A |
735 | use vars qw($prompt); |
736 | $prompt = "cpan> "; | |
9ddc4ed0 | 737 | $CPAN::CurrentCommandId ||= 0; |
9ddc4ed0 A |
738 | sub new { |
739 | bless {}, shift; | |
740 | } | |
741 | sub as_string { | |
05bab18e SP |
742 | my $word = "cpan"; |
743 | unless ($CPAN::META->{LOCK}) { | |
744 | $word = "nolock_cpan"; | |
745 | } | |
9ddc4ed0 | 746 | if ($CPAN::Config->{commandnumber_in_prompt}) { |
05bab18e | 747 | sprintf "$word\[%d]> ", $CPAN::CurrentCommandId; |
9ddc4ed0 | 748 | } else { |
05bab18e | 749 | "$word> "; |
9ddc4ed0 A |
750 | } |
751 | } | |
752 | ||
7fefbd44 RGS |
753 | package CPAN::URL; use overload '""' => "as_string", fallback => 1; |
754 | # accessors: TEXT(the url string), FROM(DEF=>defaultlist,USER=>urllist), | |
755 | # planned are things like age or quality | |
756 | sub new { | |
757 | my($class,%args) = @_; | |
758 | bless { | |
759 | %args | |
760 | }, $class; | |
761 | } | |
762 | sub as_string { | |
763 | my($self) = @_; | |
764 | $self->text; | |
765 | } | |
766 | sub text { | |
767 | my($self,$set) = @_; | |
768 | if (defined $set) { | |
769 | $self->{TEXT} = $set; | |
770 | } | |
771 | $self->{TEXT}; | |
772 | } | |
773 | ||
9ddc4ed0 A |
774 | package CPAN::Distrostatus; |
775 | use overload '""' => "as_string", | |
776 | fallback => 1; | |
777 | sub new { | |
778 | my($class,$arg) = @_; | |
779 | bless { | |
780 | TEXT => $arg, | |
781 | FAILED => substr($arg,0,2) eq "NO", | |
782 | COMMANDID => $CPAN::CurrentCommandId, | |
be34b10d | 783 | TIME => time, |
9ddc4ed0 A |
784 | }, $class; |
785 | } | |
786 | sub commandid { shift->{COMMANDID} } | |
787 | sub failed { shift->{FAILED} } | |
788 | sub text { | |
789 | my($self,$set) = @_; | |
790 | if (defined $set) { | |
791 | $self->{TEXT} = $set; | |
792 | } | |
793 | $self->{TEXT}; | |
794 | } | |
795 | sub as_string { | |
796 | my($self) = @_; | |
4d1321a7 | 797 | $self->text; |
9ddc4ed0 A |
798 | } |
799 | ||
55e314ee | 800 | package CPAN::Shell; |
e82b9348 | 801 | use strict; |
6a935156 SP |
802 | use vars qw( |
803 | $ADVANCED_QUERY | |
804 | $AUTOLOAD | |
805 | $COLOR_REGISTERED | |
f04ea8d1 | 806 | $Help |
135a59c2 | 807 | $autoload_recursion |
6a935156 SP |
808 | $reload |
809 | @ISA | |
135a59c2 | 810 | ); |
55e314ee | 811 | @CPAN::Shell::ISA = qw(CPAN::Debug); |
9d61fa1d | 812 | $COLOR_REGISTERED ||= 0; |
f04ea8d1 SP |
813 | $Help = { |
814 | '?' => \"help", | |
815 | '!' => "eval the rest of the line as perl", | |
816 | a => "whois author", | |
817 | autobundle => "wtite inventory into a bundle file", | |
818 | b => "info about bundle", | |
819 | bye => \"quit", | |
820 | clean => "clean up a distribution's build directory", | |
821 | # cvs_import | |
822 | d => "info about a distribution", | |
823 | # dump | |
824 | exit => \"quit", | |
825 | failed => "list all failed actions within current session", | |
826 | fforce => "redo a command from scratch", | |
827 | force => "redo a command", | |
828 | h => \"help", | |
829 | help => "overview over commands; 'help ...' explains specific commands", | |
830 | hosts => "statistics about recently used hosts", | |
831 | i => "info about authors/bundles/distributions/modules", | |
832 | install => "install a distribution", | |
833 | install_tested => "install all distributions tested OK", | |
834 | is_tested => "list all distributions tested OK", | |
835 | look => "open a subshell in a distribution's directory", | |
836 | ls => "list distributions according to a glob", | |
837 | m => "info about a module", | |
838 | make => "make/build a distribution", | |
839 | mkmyconfig => "write current config into a CPAN/MyConfig.pm file", | |
840 | notest => "run a (usually install) command but leave out the test phase", | |
841 | o => "'o conf ...' for config stuff; 'o debug ...' for debugging", | |
842 | perldoc => "try to get a manpage for a module", | |
843 | q => \"quit", | |
844 | quit => "leave the cpan shell", | |
845 | r => "review over upgradeable modules", | |
846 | readme => "display the README of a distro woth a pager", | |
847 | recent => "show recent uploads to the CPAN", | |
848 | # recompile | |
849 | reload => "'reload cpan' or 'reload index'", | |
850 | report => "test a distribution and send a test report to cpantesters", | |
851 | reports => "info about reported tests from cpantesters", | |
852 | # scripts | |
853 | # smoke | |
854 | test => "test a distribution", | |
855 | u => "display uninstalled modules", | |
856 | upgrade => "combine 'r' command with immediate installation", | |
857 | }; | |
135a59c2 | 858 | { |
135a59c2 A |
859 | $autoload_recursion ||= 0; |
860 | ||
861 | #-> sub CPAN::Shell::AUTOLOAD ; | |
862 | sub AUTOLOAD { | |
863 | $autoload_recursion++; | |
864 | my($l) = $AUTOLOAD; | |
865 | my $class = shift(@_); | |
866 | # warn "autoload[$l] class[$class]"; | |
867 | $l =~ s/.*:://; | |
868 | if ($CPAN::Signal) { | |
869 | warn "Refusing to autoload '$l' while signal pending"; | |
870 | $autoload_recursion--; | |
871 | return; | |
872 | } | |
873 | if ($autoload_recursion > 1) { | |
874 | my $fullcommand = join " ", map { "'$_'" } $l, @_; | |
875 | warn "Refusing to autoload $fullcommand in recursion\n"; | |
876 | $autoload_recursion--; | |
877 | return; | |
878 | } | |
879 | if ($l =~ /^w/) { | |
880 | # XXX needs to be reconsidered | |
881 | if ($CPAN::META->has_inst('CPAN::WAIT')) { | |
882 | CPAN::WAIT->$l(@_); | |
883 | } else { | |
884 | $CPAN::Frontend->mywarn(qq{ | |
55e314ee A |
885 | Commands starting with "w" require CPAN::WAIT to be installed. |
886 | Please consider installing CPAN::WAIT to use the fulltext index. | |
f610777f | 887 | For this you just need to type |
55e314ee | 888 | install CPAN::WAIT |
c356248b | 889 | }); |
6d29edf5 | 890 | } |
135a59c2 A |
891 | } else { |
892 | $CPAN::Frontend->mywarn(qq{Unknown shell command '$l'. }. | |
893 | qq{Type ? for help. | |
894 | }); | |
6d29edf5 | 895 | } |
135a59c2 | 896 | $autoload_recursion--; |
f610777f | 897 | } |
36263cb3 GS |
898 | } |
899 | ||
55e314ee | 900 | package CPAN; |
e82b9348 | 901 | use strict; |
55e314ee | 902 | |
2e2b7522 | 903 | $META ||= CPAN->new; # In case we re-eval ourselves we need the || |
55e314ee | 904 | |
6d29edf5 JH |
905 | # from here on only subs. |
906 | ################################################################################ | |
55e314ee | 907 | |
05bab18e SP |
908 | sub _perl_fingerprint { |
909 | my($self,$other_fingerprint) = @_; | |
910 | my $dll = eval {OS2::DLLname()}; | |
911 | my $mtime_dll = 0; | |
912 | if (defined $dll) { | |
913 | $mtime_dll = (-f $dll ? (stat(_))[9] : '-1'); | |
914 | } | |
b03f445c | 915 | my $mtime_perl = (-f CPAN::find_perl ? (stat(_))[9] : '-1'); |
05bab18e | 916 | my $this_fingerprint = { |
b03f445c | 917 | '$^X' => CPAN::find_perl, |
05bab18e | 918 | sitearchexp => $Config::Config{sitearchexp}, |
f20de9f0 | 919 | 'mtime_$^X' => $mtime_perl, |
05bab18e SP |
920 | 'mtime_dll' => $mtime_dll, |
921 | }; | |
922 | if ($other_fingerprint) { | |
923 | if (exists $other_fingerprint->{'stat($^X)'}) { # repair fp from rev. 1.88_57 | |
924 | $other_fingerprint->{'mtime_$^X'} = $other_fingerprint->{'stat($^X)'}[9]; | |
925 | } | |
926 | # mandatory keys since 1.88_57 | |
927 | for my $key (qw($^X sitearchexp mtime_dll mtime_$^X)) { | |
928 | return unless $other_fingerprint->{$key} eq $this_fingerprint->{$key}; | |
929 | } | |
930 | return 1; | |
931 | } else { | |
932 | return $this_fingerprint; | |
933 | } | |
934 | } | |
935 | ||
ed84aac9 A |
936 | sub suggest_myconfig () { |
937 | SUGGEST_MYCONFIG: if(!$INC{'CPAN/MyConfig.pm'}) { | |
938 | $CPAN::Frontend->myprint("You don't seem to have a user ". | |
939 | "configuration (MyConfig.pm) yet.\n"); | |
8962fc49 | 940 | my $new = CPAN::Shell::colorable_makemaker_prompt("Do you want to create a ". |
ed84aac9 A |
941 | "user configuration now? (Y/n)", |
942 | "yes"); | |
943 | if($new =~ m{^y}i) { | |
944 | CPAN::Shell->mkmyconfig(); | |
945 | return &checklock; | |
946 | } else { | |
947 | $CPAN::Frontend->mydie("OK, giving up."); | |
948 | } | |
949 | } | |
950 | } | |
951 | ||
6d29edf5 | 952 | #-> sub CPAN::all_objects ; |
36263cb3 | 953 | sub all_objects { |
5f05dabc | 954 | my($mgr,$class) = @_; |
e82b9348 | 955 | CPAN::HandleConfig->load unless $CPAN::Config_loaded++; |
5f05dabc | 956 | CPAN->debug("mgr[$mgr] class[$class]") if $CPAN::DEBUG; |
957 | CPAN::Index->reload; | |
6d29edf5 | 958 | values %{ $META->{readwrite}{$class} }; # unsafe meta access, ok |
5f05dabc | 959 | } |
960 | ||
c4d24d4c A |
961 | # Called by shell, not in batch mode. In batch mode I see no risk in |
962 | # having many processes updating something as installations are | |
963 | # continually checked at runtime. In shell mode I suspect it is | |
964 | # unintentional to open more than one shell at a time | |
965 | ||
10b2abe6 | 966 | #-> sub CPAN::checklock ; |
5f05dabc | 967 | sub checklock { |
968 | my($self) = @_; | |
5de3f0da | 969 | my $lockfile = File::Spec->catfile($CPAN::Config->{cpan_home},".lock"); |
5f05dabc | 970 | if (-f $lockfile && -M _ > 0) { |
f04ea8d1 | 971 | my $fh = FileHandle->new($lockfile) or |
9ddc4ed0 | 972 | $CPAN::Frontend->mydie("Could not open lockfile '$lockfile': $!"); |
f04ea8d1 SP |
973 | my $otherpid = <$fh>; |
974 | my $otherhost = <$fh>; | |
975 | $fh->close; | |
976 | if (defined $otherpid && $otherpid) { | |
977 | chomp $otherpid; | |
978 | } | |
979 | if (defined $otherhost && $otherhost) { | |
980 | chomp $otherhost; | |
981 | } | |
982 | my $thishost = hostname(); | |
983 | if (defined $otherhost && defined $thishost && | |
984 | $otherhost ne '' && $thishost ne '' && | |
985 | $otherhost ne $thishost) { | |
9ddc4ed0 | 986 | $CPAN::Frontend->mydie(sprintf("CPAN.pm panic: Lockfile '$lockfile'\n". |
c9869e1c SP |
987 | "reports other host $otherhost and other ". |
988 | "process $otherpid.\n". | |
0dfa0441 | 989 | "Cannot proceed.\n")); |
f04ea8d1 | 990 | } elsif ($RUN_DEGRADED) { |
05bab18e SP |
991 | $CPAN::Frontend->mywarn("Running in degraded mode (experimental)\n"); |
992 | } elsif (defined $otherpid && $otherpid) { | |
f04ea8d1 SP |
993 | return if $$ == $otherpid; # should never happen |
994 | $CPAN::Frontend->mywarn( | |
995 | qq{ | |
0dfa0441 | 996 | There seems to be running another CPAN process (pid $otherpid). Contacting... |
c356248b | 997 | }); |
f04ea8d1 SP |
998 | if (kill 0, $otherpid) { |
999 | $CPAN::Frontend->mywarn(qq{Other job is running.\n}); | |
1000 | my($ans) = | |
1001 | CPAN::Shell::colorable_makemaker_prompt | |
1002 | (qq{Shall I try to run in degraded }. | |
1003 | qq{mode? (Y/n)},"y"); | |
05bab18e SP |
1004 | if ($ans =~ /^y/i) { |
1005 | $CPAN::Frontend->mywarn("Running in degraded mode (experimental). | |
1006 | Please report if something unexpected happens\n"); | |
1007 | $RUN_DEGRADED = 1; | |
1008 | for ($CPAN::Config) { | |
be34b10d SP |
1009 | # XXX |
1010 | # $_->{build_dir_reuse} = 0; # 2006-11-17 akoenig Why was that? | |
1011 | $_->{commandnumber_in_prompt} = 0; # visibility | |
1012 | $_->{histfile} = ""; # who should win otherwise? | |
1013 | $_->{cache_metadata} = 0; # better would be a lock? | |
b72dd56f | 1014 | $_->{use_sqlite} = 0; # better would be a write lock! |
05bab18e SP |
1015 | } |
1016 | } else { | |
1017 | $CPAN::Frontend->mydie(" | |
1018 | You may want to kill the other job and delete the lockfile. On UNIX try: | |
0dfa0441 | 1019 | kill $otherpid |
c356248b | 1020 | rm $lockfile |
05bab18e SP |
1021 | "); |
1022 | } | |
f04ea8d1 SP |
1023 | } elsif (-w $lockfile) { |
1024 | my($ans) = | |
1025 | CPAN::Shell::colorable_makemaker_prompt | |
1026 | (qq{Other job not responding. Shall I overwrite }. | |
1027 | qq{the lockfile '$lockfile'? (Y/n)},"y"); | |
1028 | $CPAN::Frontend->myexit("Ok, bye\n") | |
1029 | unless $ans =~ /^y/i; | |
1030 | } else { | |
1031 | Carp::croak( | |
1032 | qq{Lockfile '$lockfile' not writeable by you. }. | |
1033 | qq{Cannot proceed.\n}. | |
1034 | qq{ On UNIX try:\n}. | |
1035 | qq{ rm '$lockfile'\n}. | |
1036 | qq{ and then rerun us.\n} | |
1037 | ); | |
1038 | } | |
1039 | } else { | |
05bab18e SP |
1040 | $CPAN::Frontend->mydie(sprintf("CPAN.pm panic: Found invalid lockfile ". |
1041 | "'$lockfile', please remove. Cannot proceed.\n")); | |
6d29edf5 | 1042 | } |
5f05dabc | 1043 | } |
36263cb3 GS |
1044 | my $dotcpan = $CPAN::Config->{cpan_home}; |
1045 | eval { File::Path::mkpath($dotcpan);}; | |
1046 | if ($@) { | |
ed84aac9 A |
1047 | # A special case at least for Jarkko. |
1048 | my $firsterror = $@; | |
1049 | my $seconderror; | |
1050 | my $symlinkcpan; | |
1051 | if (-l $dotcpan) { | |
1052 | $symlinkcpan = readlink $dotcpan; | |
1053 | die "readlink $dotcpan failed: $!" unless defined $symlinkcpan; | |
1054 | eval { File::Path::mkpath($symlinkcpan); }; | |
1055 | if ($@) { | |
1056 | $seconderror = $@; | |
1057 | } else { | |
1058 | $CPAN::Frontend->mywarn(qq{ | |
36263cb3 GS |
1059 | Working directory $symlinkcpan created. |
1060 | }); | |
ed84aac9 A |
1061 | } |
1062 | } | |
1063 | unless (-d $dotcpan) { | |
1064 | my $mess = qq{ | |
36263cb3 GS |
1065 | Your configuration suggests "$dotcpan" as your |
1066 | CPAN.pm working directory. I could not create this directory due | |
1067 | to this error: $firsterror\n}; | |
ed84aac9 | 1068 | $mess .= qq{ |
36263cb3 GS |
1069 | As "$dotcpan" is a symlink to "$symlinkcpan", |
1070 | I tried to create that, but I failed with this error: $seconderror | |
1071 | } if $seconderror; | |
ed84aac9 | 1072 | $mess .= qq{ |
36263cb3 GS |
1073 | Please make sure the directory exists and is writable. |
1074 | }; | |
f04ea8d1 | 1075 | $CPAN::Frontend->mywarn($mess); |
ed84aac9 A |
1076 | return suggest_myconfig; |
1077 | } | |
44d21104 | 1078 | } # $@ after eval mkpath $dotcpan |
05bab18e SP |
1079 | if (0) { # to test what happens when a race condition occurs |
1080 | for (reverse 1..10) { | |
1081 | print $_, "\n"; | |
1082 | sleep 1; | |
1083 | } | |
1084 | } | |
1085 | # locking | |
1086 | if (!$RUN_DEGRADED && !$self->{LOCKFH}) { | |
1087 | my $fh; | |
1088 | unless ($fh = FileHandle->new("+>>$lockfile")) { | |
1089 | if ($! =~ /Permission/) { | |
f04ea8d1 | 1090 | $CPAN::Frontend->mywarn(qq{ |
5f05dabc | 1091 | |
1092 | Your configuration suggests that CPAN.pm should use a working | |
1093 | directory of | |
1094 | $CPAN::Config->{cpan_home} | |
1095 | Unfortunately we could not create the lock file | |
1096 | $lockfile | |
1097 | due to permission problems. | |
1098 | ||
1099 | Please make sure that the configuration variable | |
1100 | \$CPAN::Config->{cpan_home} | |
1101 | points to a directory where you can write a .lock file. You can set | |
87892b73 RGS |
1102 | this variable in either a CPAN/MyConfig.pm or a CPAN/Config.pm in your |
1103 | \@INC path; | |
c356248b | 1104 | }); |
05bab18e SP |
1105 | return suggest_myconfig; |
1106 | } | |
1107 | } | |
1108 | my $sleep = 1; | |
f04ea8d1 | 1109 | while (!CPAN::_flock($fh, LOCK_EX|LOCK_NB)) { |
05bab18e SP |
1110 | if ($sleep>10) { |
1111 | $CPAN::Frontend->mydie("Giving up\n"); | |
1112 | } | |
1113 | $CPAN::Frontend->mysleep($sleep++); | |
1114 | $CPAN::Frontend->mywarn("Could not lock lockfile with flock: $!; retrying\n"); | |
1115 | } | |
1116 | ||
1117 | seek $fh, 0, 0; | |
1118 | truncate $fh, 0; | |
b03f445c | 1119 | $fh->autoflush(1); |
05bab18e SP |
1120 | $fh->print($$, "\n"); |
1121 | $fh->print(hostname(), "\n"); | |
1122 | $self->{LOCK} = $lockfile; | |
1123 | $self->{LOCKFH} = $fh; | |
5f05dabc | 1124 | } |
6d29edf5 | 1125 | $SIG{TERM} = sub { |
135a59c2 A |
1126 | my $sig = shift; |
1127 | &cleanup; | |
1128 | $CPAN::Frontend->mydie("Got SIG$sig, leaving"); | |
c356248b | 1129 | }; |
6d29edf5 | 1130 | $SIG{INT} = sub { |
09d9d230 | 1131 | # no blocks!!! |
135a59c2 A |
1132 | my $sig = shift; |
1133 | &cleanup if $Signal; | |
1134 | die "Got yet another signal" if $Signal > 1; | |
1135 | $CPAN::Frontend->mydie("Got another SIG$sig") if $Signal; | |
1136 | $CPAN::Frontend->mywarn("Caught SIG$sig, trying to continue\n"); | |
1137 | $Signal++; | |
da199366 | 1138 | }; |
911a92db GS |
1139 | |
1140 | # From: Larry Wall <larry@wall.org> | |
1141 | # Subject: Re: deprecating SIGDIE | |
1142 | # To: perl5-porters@perl.org | |
1143 | # Date: Thu, 30 Sep 1999 14:58:40 -0700 (PDT) | |
1144 | # | |
1145 | # The original intent of __DIE__ was only to allow you to substitute one | |
1146 | # kind of death for another on an application-wide basis without respect | |
1147 | # to whether you were in an eval or not. As a global backstop, it should | |
1148 | # not be used any more lightly (or any more heavily :-) than class | |
1149 | # UNIVERSAL. Any attempt to build a general exception model on it should | |
1150 | # be politely squashed. Any bug that causes every eval {} to have to be | |
1151 | # modified should be not so politely squashed. | |
1152 | # | |
1153 | # Those are my current opinions. It is also my optinion that polite | |
1154 | # arguments degenerate to personal arguments far too frequently, and that | |
1155 | # when they do, it's because both people wanted it to, or at least didn't | |
1156 | # sufficiently want it not to. | |
1157 | # | |
1158 | # Larry | |
1159 | ||
6d29edf5 JH |
1160 | # global backstop to cleanup if we should really die |
1161 | $SIG{__DIE__} = \&cleanup; | |
e50380aa | 1162 | $self->debug("Signal handler set.") if $CPAN::DEBUG; |
5f05dabc | 1163 | } |
1164 | ||
10b2abe6 | 1165 | #-> sub CPAN::DESTROY ; |
5f05dabc | 1166 | sub DESTROY { |
1167 | &cleanup; # need an eval? | |
1168 | } | |
1169 | ||
9d61fa1d A |
1170 | #-> sub CPAN::anycwd ; |
1171 | sub anycwd () { | |
1172 | my $getcwd; | |
1173 | $getcwd = $CPAN::Config->{'getcwd'} || 'cwd'; | |
1174 | CPAN->$getcwd(); | |
1175 | } | |
1176 | ||
55e314ee A |
1177 | #-> sub CPAN::cwd ; |
1178 | sub cwd {Cwd::cwd();} | |
1179 | ||
1180 | #-> sub CPAN::getcwd ; | |
1181 | sub getcwd {Cwd::getcwd();} | |
1182 | ||
ca79d794 SP |
1183 | #-> sub CPAN::fastcwd ; |
1184 | sub fastcwd {Cwd::fastcwd();} | |
1185 | ||
1186 | #-> sub CPAN::backtickcwd ; | |
1187 | sub backtickcwd {my $cwd = `cwd`; chomp $cwd; $cwd} | |
1188 | ||
607a774b | 1189 | #-> sub CPAN::find_perl ; |
b03f445c | 1190 | sub find_perl () { |
607a774b | 1191 | my($perl) = File::Spec->file_name_is_absolute($^X) ? $^X : ""; |
0cf35e6a | 1192 | my $pwd = $CPAN::iCwd = CPAN::anycwd(); |
607a774b MS |
1193 | my $candidate = File::Spec->catfile($pwd,$^X); |
1194 | $perl ||= $candidate if MM->maybe_command($candidate); | |
1195 | ||
1196 | unless ($perl) { | |
f04ea8d1 | 1197 | my ($component,$perl_name); |
607a774b | 1198 | DIST_PERLNAME: foreach $perl_name ($^X, 'perl', 'perl5', "perl$]") { |
f04ea8d1 SP |
1199 | PATH_COMPONENT: foreach $component (File::Spec->path(), |
1200 | $Config::Config{'binexp'}) { | |
1201 | next unless defined($component) && $component; | |
1202 | my($abs) = File::Spec->catfile($component,$perl_name); | |
1203 | if (MM->maybe_command($abs)) { | |
1204 | $perl = $abs; | |
1205 | last DIST_PERLNAME; | |
1206 | } | |
1207 | } | |
1208 | } | |
607a774b MS |
1209 | } |
1210 | ||
1211 | return $perl; | |
1212 | } | |
1213 | ||
1214 | ||
10b2abe6 | 1215 | #-> sub CPAN::exists ; |
5f05dabc | 1216 | sub exists { |
1217 | my($mgr,$class,$id) = @_; | |
e82b9348 | 1218 | CPAN::HandleConfig->load unless $CPAN::Config_loaded++; |
5f05dabc | 1219 | CPAN::Index->reload; |
e50380aa | 1220 | ### Carp::croak "exists called without class argument" unless $class; |
5f05dabc | 1221 | $id ||= ""; |
e82b9348 | 1222 | $id =~ s/:+/::/g if $class eq "CPAN::Module"; |
810a0276 SP |
1223 | my $exists; |
1224 | if (CPAN::_sqlite_running) { | |
1225 | $exists = (exists $META->{readonly}{$class}{$id} or | |
1226 | $CPAN::SQLite->set($class, $id)); | |
be34b10d | 1227 | } else { |
810a0276 | 1228 | $exists = exists $META->{readonly}{$class}{$id}; |
be34b10d | 1229 | } |
810a0276 | 1230 | $exists ||= exists $META->{readwrite}{$class}{$id}; # unsafe meta access, ok |
5f05dabc | 1231 | } |
1232 | ||
09d9d230 A |
1233 | #-> sub CPAN::delete ; |
1234 | sub delete { | |
1235 | my($mgr,$class,$id) = @_; | |
6d29edf5 JH |
1236 | delete $META->{readonly}{$class}{$id}; # unsafe meta access, ok |
1237 | delete $META->{readwrite}{$class}{$id}; # unsafe meta access, ok | |
09d9d230 A |
1238 | } |
1239 | ||
de34a54b JH |
1240 | #-> sub CPAN::has_usable |
1241 | # has_inst is sometimes too optimistic, we should replace it with this | |
1242 | # has_usable whenever a case is given | |
1243 | sub has_usable { | |
1244 | my($self,$mod,$message) = @_; | |
1245 | return 1 if $HAS_USABLE->{$mod}; | |
1246 | my $has_inst = $self->has_inst($mod,$message); | |
1247 | return unless $has_inst; | |
6d29edf5 JH |
1248 | my $usable; |
1249 | $usable = { | |
1250 | LWP => [ # we frequently had "Can't locate object | |
1251 | # method "new" via package "LWP::UserAgent" at | |
1252 | # (eval 69) line 2006 | |
1253 | sub {require LWP}, | |
1254 | sub {require LWP::UserAgent}, | |
1255 | sub {require HTTP::Request}, | |
1256 | sub {require URI::URL}, | |
1257 | ], | |
ec5fee46 | 1258 | 'Net::FTP' => [ |
6d29edf5 JH |
1259 | sub {require Net::FTP}, |
1260 | sub {require Net::Config}, | |
87892b73 RGS |
1261 | ], |
1262 | 'File::HomeDir' => [ | |
1263 | sub {require File::HomeDir; | |
b03f445c | 1264 | unless (CPAN::Version->vge(File::HomeDir::->VERSION, 0.52)) { |
87892b73 | 1265 | for ("Will not use File::HomeDir, need 0.52\n") { |
ed84aac9 | 1266 | $CPAN::Frontend->mywarn($_); |
87892b73 RGS |
1267 | die $_; |
1268 | } | |
1269 | } | |
1270 | }, | |
1271 | ], | |
f20de9f0 SP |
1272 | 'Archive::Tar' => [ |
1273 | sub {require Archive::Tar; | |
b03f445c | 1274 | unless (CPAN::Version->vge(Archive::Tar::->VERSION, 1.00)) { |
f20de9f0 SP |
1275 | for ("Will not use Archive::Tar, need 1.00\n") { |
1276 | $CPAN::Frontend->mywarn($_); | |
1277 | die $_; | |
1278 | } | |
1279 | } | |
1280 | }, | |
1281 | ], | |
b03f445c RGS |
1282 | 'File::Temp' => [ |
1283 | # XXX we should probably delete from | |
1284 | # %INC too so we can load after we | |
1285 | # installed a new enough version -- | |
1286 | # I'm not sure. | |
1287 | sub {require File::Temp; | |
1288 | unless (CPAN::Version->vge(File::Temp::->VERSION,0.16)) { | |
1289 | for ("Will not use File::Temp, need 0.16\n") { | |
1290 | $CPAN::Frontend->mywarn($_); | |
1291 | die $_; | |
1292 | } | |
1293 | } | |
1294 | }, | |
1295 | ] | |
6d29edf5 JH |
1296 | }; |
1297 | if ($usable->{$mod}) { | |
87892b73 RGS |
1298 | for my $c (0..$#{$usable->{$mod}}) { |
1299 | my $code = $usable->{$mod}[$c]; | |
1300 | my $ret = eval { &$code() }; | |
1301 | $ret = "" unless defined $ret; | |
1302 | if ($@) { | |
1303 | # warn "DEBUG: c[$c]\$\@[$@]ret[$ret]"; | |
1304 | return; | |
1305 | } | |
de34a54b | 1306 | } |
de34a54b JH |
1307 | } |
1308 | return $HAS_USABLE->{$mod} = 1; | |
1309 | } | |
1310 | ||
55e314ee A |
1311 | #-> sub CPAN::has_inst |
1312 | sub has_inst { | |
1313 | my($self,$mod,$message) = @_; | |
1314 | Carp::croak("CPAN->has_inst() called without an argument") | |
f04ea8d1 | 1315 | unless defined $mod; |
4d1321a7 A |
1316 | my %dont = map { $_ => 1 } keys %{$CPAN::META->{dontload_hash}||{}}, |
1317 | keys %{$CPAN::Config->{dontload_hash}||{}}, | |
1318 | @{$CPAN::Config->{dontload_list}||[]}; | |
1319 | if (defined $message && $message eq "no" # afair only used by Nox | |
de34a54b | 1320 | || |
4d1321a7 | 1321 | $dont{$mod} |
de34a54b | 1322 | ) { |
6d29edf5 | 1323 | $CPAN::META->{dontload_hash}{$mod}||=1; # unsafe meta access, ok |
de34a54b | 1324 | return 0; |
55e314ee A |
1325 | } |
1326 | my $file = $mod; | |
c356248b | 1327 | my $obj; |
55e314ee | 1328 | $file =~ s|::|/|g; |
55e314ee | 1329 | $file .= ".pm"; |
c356248b | 1330 | if ($INC{$file}) { |
f04ea8d1 SP |
1331 | # checking %INC is wrong, because $INC{LWP} may be true |
1332 | # although $INC{"URI/URL.pm"} may have failed. But as | |
1333 | # I really want to say "bla loaded OK", I have to somehow | |
1334 | # cache results. | |
1335 | ### warn "$file in %INC"; #debug | |
1336 | return 1; | |
55e314ee | 1337 | } elsif (eval { require $file }) { |
f04ea8d1 SP |
1338 | # eval is good: if we haven't yet read the database it's |
1339 | # perfect and if we have installed the module in the meantime, | |
1340 | # it tries again. The second require is only a NOOP returning | |
1341 | # 1 if we had success, otherwise it's retrying | |
1342 | ||
1343 | my $mtime = (stat $INC{$file})[9]; | |
1344 | # privileged files loaded by has_inst; Note: we use $mtime | |
1345 | # as a proxy for a checksum. | |
1346 | $CPAN::Shell::reload->{$file} = $mtime; | |
6a935156 SP |
1347 | my $v = eval "\$$mod\::VERSION"; |
1348 | $v = $v ? " (v$v)" : ""; | |
f04ea8d1 SP |
1349 | CPAN::Shell->optprint("load_module","CPAN: $mod loaded ok$v\n"); |
1350 | if ($mod eq "CPAN::WAIT") { | |
1351 | push @CPAN::Shell::ISA, 'CPAN::WAIT'; | |
1352 | } | |
1353 | return 1; | |
55e314ee | 1354 | } elsif ($mod eq "Net::FTP") { |
f04ea8d1 | 1355 | $CPAN::Frontend->mywarn(qq{ |
55e314ee A |
1356 | Please, install Net::FTP as soon as possible. CPAN.pm installs it for you |
1357 | if you just type | |
1358 | install Bundle::libnet | |
5f05dabc | 1359 | |
5a5fac02 | 1360 | }) unless $Have_warned->{"Net::FTP"}++; |
f04ea8d1 SP |
1361 | $CPAN::Frontend->mysleep(3); |
1362 | } elsif ($mod eq "Digest::SHA") { | |
4d1321a7 | 1363 | if ($Have_warned->{"Digest::SHA"}++) { |
f04ea8d1 | 1364 | $CPAN::Frontend->mywarn(qq{CPAN: checksum security checks disabled }. |
4d1321a7 A |
1365 | qq{because Digest::SHA not installed.\n}); |
1366 | } else { | |
8962fc49 | 1367 | $CPAN::Frontend->mywarn(qq{ |
e82b9348 SP |
1368 | CPAN: checksum security checks disabled because Digest::SHA not installed. |
1369 | Please consider installing the Digest::SHA module. | |
c356248b A |
1370 | |
1371 | }); | |
8962fc49 | 1372 | $CPAN::Frontend->mysleep(2); |
4d1321a7 | 1373 | } |
f04ea8d1 | 1374 | } elsif ($mod eq "Module::Signature") { |
be34b10d SP |
1375 | # NOT prefs_lookup, we are not a distro |
1376 | my $check_sigs = $CPAN::Config->{check_sigs}; | |
1377 | if (not $check_sigs) { | |
ed84aac9 A |
1378 | # they do not want us:-( |
1379 | } elsif (not $Have_warned->{"Module::Signature"}++) { | |
f04ea8d1 SP |
1380 | # No point in complaining unless the user can |
1381 | # reasonably install and use it. | |
1382 | if (eval { require Crypt::OpenPGP; 1 } || | |
1383 | ( | |
ed84aac9 A |
1384 | defined $CPAN::Config->{'gpg'} |
1385 | && | |
1386 | $CPAN::Config->{'gpg'} =~ /\S/ | |
1387 | ) | |
1388 | ) { | |
f04ea8d1 | 1389 | $CPAN::Frontend->mywarn(qq{ |
554a9ef5 SP |
1390 | CPAN: Module::Signature security checks disabled because Module::Signature |
1391 | not installed. Please consider installing the Module::Signature module. | |
1392 | You may also need to be able to connect over the Internet to the public | |
1393 | keyservers like pgp.mit.edu (port 11371). | |
1394 | ||
1395 | }); | |
f04ea8d1 SP |
1396 | $CPAN::Frontend->mysleep(2); |
1397 | } | |
1398 | } | |
f14b5cec | 1399 | } else { |
f04ea8d1 | 1400 | delete $INC{$file}; # if it inc'd LWP but failed during, say, URI |
05454584 | 1401 | } |
55e314ee | 1402 | return 0; |
05454584 A |
1403 | } |
1404 | ||
10b2abe6 | 1405 | #-> sub CPAN::instance ; |
5f05dabc | 1406 | sub instance { |
1407 | my($mgr,$class,$id) = @_; | |
1408 | CPAN::Index->reload; | |
5f05dabc | 1409 | $id ||= ""; |
6d29edf5 JH |
1410 | # unsafe meta access, ok? |
1411 | return $META->{readwrite}{$class}{$id} if exists $META->{readwrite}{$class}{$id}; | |
1412 | $META->{readwrite}{$class}{$id} ||= $class->new(ID => $id); | |
5f05dabc | 1413 | } |
1414 | ||
10b2abe6 | 1415 | #-> sub CPAN::new ; |
5f05dabc | 1416 | sub new { |
1417 | bless {}, shift; | |
1418 | } | |
1419 | ||
10b2abe6 | 1420 | #-> sub CPAN::cleanup ; |
5f05dabc | 1421 | sub cleanup { |
e82b9348 | 1422 | # warn "cleanup called with arg[@_] End[$CPAN::End] Signal[$Signal]"; |
2e2b7522 GS |
1423 | local $SIG{__DIE__} = ''; |
1424 | my($message) = @_; | |
1425 | my $i = 0; | |
1426 | my $ineval = 0; | |
5fc0f0f6 JH |
1427 | my($subroutine); |
1428 | while ((undef,undef,undef,$subroutine) = caller(++$i)) { | |
2e2b7522 | 1429 | $ineval = 1, last if |
f04ea8d1 | 1430 | $subroutine eq '(eval)'; |
2e2b7522 | 1431 | } |
e82b9348 | 1432 | return if $ineval && !$CPAN::End; |
5fc0f0f6 JH |
1433 | return unless defined $META->{LOCK}; |
1434 | return unless -f $META->{LOCK}; | |
1435 | $META->savehist; | |
b72dd56f | 1436 | close $META->{LOCKFH}; |
5fc0f0f6 | 1437 | unlink $META->{LOCK}; |
2e2b7522 GS |
1438 | # require Carp; |
1439 | # Carp::cluck("DEBUGGING"); | |
6658a91b SP |
1440 | if ( $CPAN::CONFIG_DIRTY ) { |
1441 | $CPAN::Frontend->mywarn("Warning: Configuration not saved.\n"); | |
1442 | } | |
8962fc49 | 1443 | $CPAN::Frontend->myprint("Lockfile removed.\n"); |
5f05dabc | 1444 | } |
1445 | ||
f20de9f0 SP |
1446 | #-> sub CPAN::readhist |
1447 | sub readhist { | |
1448 | my($self,$term,$histfile) = @_; | |
1449 | my($fh) = FileHandle->new; | |
1450 | open $fh, "<$histfile" or last; | |
1451 | local $/ = "\n"; | |
1452 | while (<$fh>) { | |
1453 | chomp; | |
1454 | $term->AddHistory($_); | |
1455 | } | |
1456 | close $fh; | |
1457 | } | |
1458 | ||
5fc0f0f6 JH |
1459 | #-> sub CPAN::savehist |
1460 | sub savehist { | |
1461 | my($self) = @_; | |
1462 | my($histfile,$histsize); | |
f04ea8d1 | 1463 | unless ($histfile = $CPAN::Config->{'histfile'}) { |
5fc0f0f6 JH |
1464 | $CPAN::Frontend->mywarn("No history written (no histfile specified).\n"); |
1465 | return; | |
1466 | } | |
1467 | $histsize = $CPAN::Config->{'histsize'} || 100; | |
f04ea8d1 | 1468 | if ($CPAN::term) { |
35576f8c A |
1469 | unless ($CPAN::term->can("GetHistory")) { |
1470 | $CPAN::Frontend->mywarn("Terminal does not support GetHistory.\n"); | |
1471 | return; | |
1472 | } | |
1473 | } else { | |
5fc0f0f6 JH |
1474 | return; |
1475 | } | |
1476 | my @h = $CPAN::term->GetHistory; | |
1477 | splice @h, 0, @h-$histsize if @h>$histsize; | |
1478 | my($fh) = FileHandle->new; | |
35576f8c | 1479 | open $fh, ">$histfile" or $CPAN::Frontend->mydie("Couldn't open >$histfile: $!"); |
5fc0f0f6 JH |
1480 | local $\ = local $, = "\n"; |
1481 | print $fh @h; | |
1482 | close $fh; | |
1483 | } | |
1484 | ||
6658a91b | 1485 | #-> sub CPAN::is_tested |
4c070e31 | 1486 | sub is_tested { |
b72dd56f SP |
1487 | my($self,$what,$when) = @_; |
1488 | unless ($what) { | |
1489 | Carp::cluck("DEBUG: empty what"); | |
1490 | return; | |
1491 | } | |
1492 | $self->{is_tested}{$what} = $when; | |
4c070e31 IZ |
1493 | } |
1494 | ||
6658a91b | 1495 | #-> sub CPAN::is_installed |
135a59c2 A |
1496 | # unsets the is_tested flag: as soon as the thing is installed, it is |
1497 | # not needed in set_perl5lib anymore | |
4c070e31 IZ |
1498 | sub is_installed { |
1499 | my($self,$what) = @_; | |
1500 | delete $self->{is_tested}{$what}; | |
1501 | } | |
1502 | ||
b72dd56f SP |
1503 | sub _list_sorted_descending_is_tested { |
1504 | my($self) = @_; | |
1505 | sort | |
1506 | { ($self->{is_tested}{$b}||0) <=> ($self->{is_tested}{$a}||0) } | |
1507 | keys %{$self->{is_tested}} | |
1508 | } | |
1509 | ||
6658a91b | 1510 | #-> sub CPAN::set_perl5lib |
4c070e31 | 1511 | sub set_perl5lib { |
6658a91b SP |
1512 | my($self,$for) = @_; |
1513 | unless ($for) { | |
1514 | (undef,undef,undef,$for) = caller(1); | |
1515 | $for =~ s/.*://; | |
1516 | } | |
0362b508 | 1517 | $self->{is_tested} ||= {}; |
4c070e31 IZ |
1518 | return unless %{$self->{is_tested}}; |
1519 | my $env = $ENV{PERL5LIB}; | |
1520 | $env = $ENV{PERLLIB} unless defined $env; | |
1521 | my @env; | |
1522 | push @env, $env if defined $env and length $env; | |
6658a91b SP |
1523 | #my @dirs = map {("$_/blib/arch", "$_/blib/lib")} keys %{$self->{is_tested}}; |
1524 | #$CPAN::Frontend->myprint("Prepending @dirs to PERL5LIB.\n"); | |
b72dd56f SP |
1525 | |
1526 | my @dirs = map {("$_/blib/arch", "$_/blib/lib")} $self->_list_sorted_descending_is_tested; | |
1527 | if (@dirs < 12) { | |
1528 | $CPAN::Frontend->myprint("Prepending @dirs to PERL5LIB for '$for'\n"); | |
1529 | } elsif (@dirs < 24) { | |
1530 | my @d = map {my $cp = $_; | |
1531 | $cp =~ s/^\Q$CPAN::Config->{build_dir}\E/%BUILDDIR%/; | |
1532 | $cp | |
1533 | } @dirs; | |
1534 | $CPAN::Frontend->myprint("Prepending @d to PERL5LIB; ". | |
1535 | "%BUILDDIR%=$CPAN::Config->{build_dir} ". | |
1536 | "for '$for'\n" | |
1537 | ); | |
6658a91b | 1538 | } else { |
b72dd56f SP |
1539 | my $cnt = keys %{$self->{is_tested}}; |
1540 | $CPAN::Frontend->myprint("Prepending blib/arch and blib/lib of ". | |
1541 | "$cnt build dirs to PERL5LIB; ". | |
1542 | "for '$for'\n" | |
6658a91b SP |
1543 | ); |
1544 | } | |
1545 | ||
4c070e31 IZ |
1546 | $ENV{PERL5LIB} = join $Config::Config{path_sep}, @dirs, @env; |
1547 | } | |
1548 | ||
05454584 | 1549 | package CPAN::CacheMgr; |
e82b9348 | 1550 | use strict; |
5f05dabc | 1551 | |
05454584 A |
1552 | #-> sub CPAN::CacheMgr::as_string ; |
1553 | sub as_string { | |
1554 | eval { require Data::Dumper }; | |
1555 | if ($@) { | |
f04ea8d1 | 1556 | return shift->SUPER::as_string; |
5f05dabc | 1557 | } else { |
f04ea8d1 | 1558 | return Data::Dumper::Dumper(shift); |
5f05dabc | 1559 | } |
1560 | } | |
1561 | ||
05454584 A |
1562 | #-> sub CPAN::CacheMgr::cachesize ; |
1563 | sub cachesize { | |
1564 | shift->{DU}; | |
5f05dabc | 1565 | } |
5f05dabc | 1566 | |
c4d24d4c | 1567 | #-> sub CPAN::CacheMgr::tidyup ; |
09d9d230 A |
1568 | sub tidyup { |
1569 | my($self) = @_; | |
be34b10d | 1570 | return unless $CPAN::META->{LOCK}; |
09d9d230 | 1571 | return unless -d $self->{ID}; |
dc053c64 SP |
1572 | my @toremove = grep { $self->{SIZE}{$_}==0 } @{$self->{FIFO}}; |
1573 | for my $current (0..$#toremove) { | |
1574 | my $toremove = $toremove[$current]; | |
1575 | $CPAN::Frontend->myprint(sprintf( | |
1576 | "DEL(%d/%d): %s \n", | |
1577 | $current+1, | |
1578 | scalar @toremove, | |
1579 | $toremove, | |
1580 | ) | |
1581 | ); | |
09d9d230 | 1582 | return if $CPAN::Signal; |
810a0276 | 1583 | $self->_clean_cache($toremove); |
09d9d230 A |
1584 | return if $CPAN::Signal; |
1585 | } | |
1586 | } | |
5f05dabc | 1587 | |
05454584 A |
1588 | #-> sub CPAN::CacheMgr::dir ; |
1589 | sub dir { | |
1590 | shift->{ID}; | |
1591 | } | |
1592 | ||
1593 | #-> sub CPAN::CacheMgr::entries ; | |
1594 | sub entries { | |
1595 | my($self,$dir) = @_; | |
55e314ee | 1596 | return unless defined $dir; |
e50380aa | 1597 | $self->debug("reading dir[$dir]") if $CPAN::DEBUG; |
05454584 | 1598 | $dir ||= $self->{ID}; |
9d61fa1d | 1599 | my($cwd) = CPAN::anycwd(); |
05454584 | 1600 | chdir $dir or Carp::croak("Can't chdir to $dir: $!"); |
f14b5cec JH |
1601 | my $dh = DirHandle->new(File::Spec->curdir) |
1602 | or Carp::croak("Couldn't opendir $dir: $!"); | |
05454584 A |
1603 | my(@entries); |
1604 | for ($dh->read) { | |
f04ea8d1 SP |
1605 | next if $_ eq "." || $_ eq ".."; |
1606 | if (-f $_) { | |
1607 | push @entries, File::Spec->catfile($dir,$_); | |
1608 | } elsif (-d _) { | |
1609 | push @entries, File::Spec->catdir($dir,$_); | |
1610 | } else { | |
1611 | $CPAN::Frontend->mywarn("Warning: weird direntry in $dir: $_\n"); | |
1612 | } | |
5f05dabc | 1613 | } |
05454584 | 1614 | chdir $cwd or Carp::croak("Can't chdir to $cwd: $!"); |
dc053c64 | 1615 | sort { -M $a <=> -M $b} @entries; |
5f05dabc | 1616 | } |
1617 | ||
05454584 A |
1618 | #-> sub CPAN::CacheMgr::disk_usage ; |
1619 | sub disk_usage { | |
dc053c64 | 1620 | my($self,$dir,$fast) = @_; |
09d9d230 A |
1621 | return if exists $self->{SIZE}{$dir}; |
1622 | return if $CPAN::Signal; | |
1623 | my($Du) = 0; | |
c9869e1c | 1624 | if (-e $dir) { |
2b3bde2a SP |
1625 | if (-d $dir) { |
1626 | unless (-x $dir) { | |
1627 | unless (chmod 0755, $dir) { | |
1628 | $CPAN::Frontend->mywarn("I have neither the -x permission nor the ". | |
1629 | "permission to change the permission; cannot ". | |
1630 | "estimate disk usage of '$dir'\n"); | |
1631 | $CPAN::Frontend->mysleep(5); | |
1632 | return; | |
1633 | } | |
c9869e1c | 1634 | } |
2b3bde2a SP |
1635 | } elsif (-f $dir) { |
1636 | # nothing to say, no matter what the permissions | |
c9869e1c SP |
1637 | } |
1638 | } else { | |
2b3bde2a | 1639 | $CPAN::Frontend->mywarn("File or directory '$dir' has gone, ignoring\n"); |
0cf35e6a | 1640 | return; |
0cf35e6a | 1641 | } |
dc053c64 SP |
1642 | if ($fast) { |
1643 | $Du = 0; # placeholder | |
1644 | } else { | |
1645 | find( | |
1646 | sub { | |
0cf35e6a SP |
1647 | $File::Find::prune++ if $CPAN::Signal; |
1648 | return if -l $_; | |
1649 | if ($^O eq 'MacOS') { | |
1650 | require Mac::Files; | |
1651 | my $cat = Mac::Files::FSpGetCatInfo($_); | |
1652 | $Du += $cat->ioFlLgLen() + $cat->ioFlRLgLen() if $cat; | |
1653 | } else { | |
1654 | if (-d _) { | |
1655 | unless (-x _) { | |
1656 | unless (chmod 0755, $_) { | |
1657 | $CPAN::Frontend->mywarn("I have neither the -x permission nor ". | |
1658 | "the permission to change the permission; ". | |
1659 | "can only partially estimate disk usage ". | |
1660 | "of '$_'\n"); | |
8962fc49 | 1661 | $CPAN::Frontend->mysleep(5); |
0cf35e6a SP |
1662 | return; |
1663 | } | |
1664 | } | |
1665 | } else { | |
1666 | $Du += (-s _); | |
1667 | } | |
1668 | } | |
1669 | }, | |
1670 | $dir | |
dc053c64 SP |
1671 | ); |
1672 | } | |
09d9d230 | 1673 | return if $CPAN::Signal; |
05454584 | 1674 | $self->{SIZE}{$dir} = $Du/1024/1024; |
dc053c64 | 1675 | unshift @{$self->{FIFO}}, $dir; |
05454584 A |
1676 | $self->debug("measured $dir is $Du") if $CPAN::DEBUG; |
1677 | $self->{DU} += $Du/1024/1024; | |
05454584 | 1678 | $self->{DU}; |
5f05dabc | 1679 | } |
1680 | ||
810a0276 SP |
1681 | #-> sub CPAN::CacheMgr::_clean_cache ; |
1682 | sub _clean_cache { | |
05454584 | 1683 | my($self,$dir) = @_; |
09d9d230 | 1684 | return unless -e $dir; |
810a0276 | 1685 | unless (File::Spec->canonpath(File::Basename::dirname($dir)) |
f04ea8d1 | 1686 | eq File::Spec->canonpath($CPAN::Config->{build_dir})) { |
be34b10d SP |
1687 | $CPAN::Frontend->mywarn("Directory '$dir' not below $CPAN::Config->{build_dir}, ". |
1688 | "will not remove\n"); | |
1689 | $CPAN::Frontend->mysleep(5); | |
1690 | return; | |
1691 | } | |
05454584 | 1692 | $self->debug("have to rmtree $dir, will free $self->{SIZE}{$dir}") |
f04ea8d1 | 1693 | if $CPAN::DEBUG; |
05454584 | 1694 | File::Path::rmtree($dir); |
f20de9f0 SP |
1695 | my $id_deleted = 0; |
1696 | if ($dir !~ /\.yml$/ && -f "$dir.yml") { | |
1697 | my $yaml_module = CPAN::_yaml_module; | |
1698 | if ($CPAN::META->has_inst($yaml_module)) { | |
23a216b4 SP |
1699 | my($peek_yaml) = eval { CPAN->_yaml_loadfile("$dir.yml"); }; |
1700 | if ($@) { | |
1701 | $CPAN::Frontend->mywarn("(parse error on '$dir.yml' removing anyway)"); | |
1702 | unlink "$dir.yml" or | |
1703 | $CPAN::Frontend->mywarn("(Could not unlink '$dir.yml': $!)"); | |
1704 | return; | |
1705 | } elsif (my $id = $peek_yaml->[0]{distribution}{ID}) { | |
f20de9f0 | 1706 | $CPAN::META->delete("CPAN::Distribution", $id); |
23a216b4 SP |
1707 | |
1708 | # XXX we should restore the state NOW, otherise this | |
1709 | # distro does not exist until we read an index. BUG ALERT(?) | |
1710 | ||
f20de9f0 SP |
1711 | # $CPAN::Frontend->mywarn (" +++\n"); |
1712 | $id_deleted++; | |
1713 | } | |
1714 | } | |
1715 | unlink "$dir.yml"; # may fail | |
1716 | unless ($id_deleted) { | |
1717 | CPAN->debug("no distro found associated with '$dir'"); | |
1718 | } | |
1719 | } | |
05454584 A |
1720 | $self->{DU} -= $self->{SIZE}{$dir}; |
1721 | delete $self->{SIZE}{$dir}; | |
5f05dabc | 1722 | } |
1723 | ||
05454584 A |
1724 | #-> sub CPAN::CacheMgr::new ; |
1725 | sub new { | |
1726 | my $class = shift; | |
e50380aa A |
1727 | my $time = time; |
1728 | my($debug,$t2); | |
1729 | $debug = ""; | |
05454584 | 1730 | my $self = { |
f04ea8d1 SP |
1731 | ID => $CPAN::Config->{build_dir}, |
1732 | MAX => $CPAN::Config->{'build_cache'}, | |
1733 | SCAN => $CPAN::Config->{'scan_cache'} || 'atstart', | |
1734 | DU => 0 | |
1735 | }; | |
05454584 A |
1736 | File::Path::mkpath($self->{ID}); |
1737 | my $dh = DirHandle->new($self->{ID}); | |
1738 | bless $self, $class; | |
f610777f A |
1739 | $self->scan_cache; |
1740 | $t2 = time; | |
1741 | $debug .= "timing of CacheMgr->new: ".($t2 - $time); | |
1742 | $time = $t2; | |
1743 | CPAN->debug($debug) if $CPAN::DEBUG; | |
1744 | $self; | |
1745 | } | |
1746 | ||
1747 | #-> sub CPAN::CacheMgr::scan_cache ; | |
1748 | sub scan_cache { | |
1749 | my $self = shift; | |
1750 | return if $self->{SCAN} eq 'never'; | |
1751 | $CPAN::Frontend->mydie("Unknown scan_cache argument: $self->{SCAN}") | |
f04ea8d1 | 1752 | unless $self->{SCAN} eq 'atstart'; |
f20de9f0 | 1753 | return unless $CPAN::META->{LOCK}; |
09d9d230 | 1754 | $CPAN::Frontend->myprint( |
f04ea8d1 SP |
1755 | sprintf("Scanning cache %s for sizes\n", |
1756 | $self->{ID})); | |
f610777f | 1757 | my $e; |
dc053c64 | 1758 | my @entries = $self->entries($self->{ID}); |
b72dd56f SP |
1759 | my $i = 0; |
1760 | my $painted = 0; | |
1761 | for $e (@entries) { | |
dc053c64 SP |
1762 | my $symbol = "."; |
1763 | if ($self->{DU} > $self->{MAX}) { | |
1764 | $symbol = "-"; | |
1765 | $self->disk_usage($e,1); | |
1766 | } else { | |
1767 | $self->disk_usage($e); | |
1768 | } | |
b72dd56f SP |
1769 | $i++; |
1770 | while (($painted/76) < ($i/@entries)) { | |
dc053c64 | 1771 | $CPAN::Frontend->myprint($symbol); |
b72dd56f SP |
1772 | $painted++; |
1773 | } | |
f04ea8d1 | 1774 | return if $CPAN::Signal; |
5f05dabc | 1775 | } |
b72dd56f | 1776 | $CPAN::Frontend->myprint("DONE\n"); |
09d9d230 | 1777 | $self->tidyup; |
5f05dabc | 1778 | } |
1779 | ||
05454584 | 1780 | package CPAN::Shell; |
e82b9348 | 1781 | use strict; |
5f05dabc | 1782 | |
05454584 A |
1783 | #-> sub CPAN::Shell::h ; |
1784 | sub h { | |
1785 | my($class,$about) = @_; | |
1786 | if (defined $about) { | |
f04ea8d1 SP |
1787 | my $help; |
1788 | if (exists $Help->{$about}) { | |
1789 | if (ref $Help->{$about}) { # aliases | |
1790 | $about = ${$Help->{$about}}; | |
1791 | } | |
1792 | $help = $Help->{$about}; | |
1793 | } else { | |
1794 | $help = "No help available"; | |
1795 | } | |
1796 | $CPAN::Frontend->myprint("$about\: $help\n"); | |
05454584 | 1797 | } else { |
9ddc4ed0 | 1798 | my $filler = " " x (80 - 28 - length($CPAN::VERSION)); |
f04ea8d1 | 1799 | $CPAN::Frontend->myprint(qq{ |
9ddc4ed0 | 1800 | Display Information $filler (ver $CPAN::VERSION) |
c049f953 JH |
1801 | command argument description |
1802 | a,b,d,m WORD or /REGEXP/ about authors, bundles, distributions, modules | |
6a94b120 | 1803 | i WORD or /REGEXP/ about any of the above |
0cf35e6a | 1804 | ls AUTHOR or GLOB about files in the author's directory |
ec5fee46 A |
1805 | (with WORD being a module, bundle or author name or a distribution |
1806 | name of the form AUTHOR/DISTRIBUTION) | |
911a92db GS |
1807 | |
1808 | Download, Test, Make, Install... | |
ec5fee46 A |
1809 | get download clean make clean |
1810 | make make (implies get) look open subshell in dist directory | |
1811 | test make test (implies make) readme display these README files | |
1812 | install make install (implies test) perldoc display POD documentation | |
1813 | ||
135a59c2 A |
1814 | Upgrade |
1815 | r WORDs or /REGEXP/ or NONE report updates for some/matching/all modules | |
1816 | upgrade WORDs or /REGEXP/ or NONE upgrade some/matching/all modules | |
1817 | ||
ec5fee46 | 1818 | Pragmas |
b72dd56f | 1819 | force CMD try hard to do command fforce CMD try harder |
810a0276 | 1820 | notest CMD skip testing |
911a92db GS |
1821 | |
1822 | Other | |
1823 | h,? display this menu ! perl-code eval a perl command | |
1824 | o conf [opt] set and query options q quit the cpan shell | |
1825 | reload cpan load CPAN.pm again reload index load newer indices | |
ec5fee46 | 1826 | autobundle Snapshot recent latest CPAN uploads}); |
135a59c2 | 1827 | } |
05454584 | 1828 | } |
da199366 | 1829 | |
09d9d230 A |
1830 | *help = \&h; |
1831 | ||
05454584 | 1832 | #-> sub CPAN::Shell::a ; |
de34a54b JH |
1833 | sub a { |
1834 | my($self,@arg) = @_; | |
1835 | # authors are always UPPERCASE | |
1836 | for (@arg) { | |
c049f953 | 1837 | $_ = uc $_ unless /=/; |
de34a54b JH |
1838 | } |
1839 | $CPAN::Frontend->myprint($self->format_result('Author',@arg)); | |
1840 | } | |
6d29edf5 | 1841 | |
ca79d794 SP |
1842 | #-> sub CPAN::Shell::globls ; |
1843 | sub globls { | |
1844 | my($self,$s,$pragmas) = @_; | |
0cf35e6a SP |
1845 | # ls is really very different, but we had it once as an ordinary |
1846 | # command in the Shell (upto rev. 321) and we could not handle | |
1847 | # force well then | |
e82b9348 | 1848 | my(@accept,@preexpand); |
0cf35e6a SP |
1849 | if ($s =~ /[\*\?\/]/) { |
1850 | if ($CPAN::META->has_inst("Text::Glob")) { | |
1851 | if (my($au,$pathglob) = $s =~ m|(.*?)/(.*)|) { | |
1852 | my $rau = Text::Glob::glob_to_regex(uc $au); | |
1853 | CPAN::Shell->debug("au[$au]pathglob[$pathglob]rau[$rau]") | |
1854 | if $CPAN::DEBUG; | |
1855 | push @preexpand, map { $_->id . "/" . $pathglob } | |
1856 | CPAN::Shell->expand_by_method('CPAN::Author',['id'],"/$rau/"); | |
e82b9348 | 1857 | } else { |
0cf35e6a SP |
1858 | my $rau = Text::Glob::glob_to_regex(uc $s); |
1859 | push @preexpand, map { $_->id } | |
1860 | CPAN::Shell->expand_by_method('CPAN::Author', | |
1861 | ['id'], | |
1862 | "/$rau/"); | |
e82b9348 SP |
1863 | } |
1864 | } else { | |
0cf35e6a | 1865 | $CPAN::Frontend->mydie("Text::Glob not installed, cannot proceed"); |
e82b9348 | 1866 | } |
0cf35e6a SP |
1867 | } else { |
1868 | push @preexpand, uc $s; | |
554a9ef5 | 1869 | } |
e82b9348 SP |
1870 | for (@preexpand) { |
1871 | unless (/^[A-Z0-9\-]+(\/|$)/i) { | |
5fc0f0f6 | 1872 | $CPAN::Frontend->mywarn("ls command rejects argument $_: not an author\n"); |
c049f953 JH |
1873 | next; |
1874 | } | |
e82b9348 | 1875 | push @accept, $_; |
8d97e4a1 | 1876 | } |
554a9ef5 SP |
1877 | my $silent = @accept>1; |
1878 | my $last_alpha = ""; | |
ca79d794 | 1879 | my @results; |
f04ea8d1 | 1880 | for my $a (@accept) { |
e82b9348 SP |
1881 | my($author,$pathglob); |
1882 | if ($a =~ m|(.*?)/(.*)|) { | |
1883 | my $a2 = $1; | |
1884 | $pathglob = $2; | |
0cf35e6a SP |
1885 | $author = CPAN::Shell->expand_by_method('CPAN::Author', |
1886 | ['id'], | |
b72dd56f SP |
1887 | $a2) |
1888 | or $CPAN::Frontend->mydie("No author found for $a2\n"); | |
e82b9348 | 1889 | } else { |
0cf35e6a SP |
1890 | $author = CPAN::Shell->expand_by_method('CPAN::Author', |
1891 | ['id'], | |
b72dd56f SP |
1892 | $a) |
1893 | or $CPAN::Frontend->mydie("No author found for $a\n"); | |
e82b9348 | 1894 | } |
554a9ef5 | 1895 | if ($silent) { |
e82b9348 | 1896 | my $alpha = substr $author->id, 0, 1; |
554a9ef5 | 1897 | my $ad; |
e82b9348 SP |
1898 | if ($alpha eq $last_alpha) { |
1899 | $ad = ""; | |
554a9ef5 | 1900 | } else { |
e82b9348 SP |
1901 | $ad = "[$alpha]"; |
1902 | $last_alpha = $alpha; | |
554a9ef5 SP |
1903 | } |
1904 | $CPAN::Frontend->myprint($ad); | |
1905 | } | |
9ddc4ed0 A |
1906 | for my $pragma (@$pragmas) { |
1907 | if ($author->can($pragma)) { | |
1908 | $author->$pragma(); | |
1909 | } | |
1910 | } | |
ca79d794 SP |
1911 | push @results, $author->ls($pathglob,$silent); # silent if |
1912 | # more than one | |
1913 | # author | |
9ddc4ed0 | 1914 | for my $pragma (@$pragmas) { |
05bab18e SP |
1915 | my $unpragma = "un$pragma"; |
1916 | if ($author->can($unpragma)) { | |
1917 | $author->$unpragma(); | |
9ddc4ed0 A |
1918 | } |
1919 | } | |
8d97e4a1 | 1920 | } |
ca79d794 | 1921 | @results; |
8d97e4a1 | 1922 | } |
6d29edf5 | 1923 | |
8d97e4a1 | 1924 | #-> sub CPAN::Shell::local_bundles ; |
6d29edf5 | 1925 | sub local_bundles { |
05454584 | 1926 | my($self,@which) = @_; |
55e314ee | 1927 | my($incdir,$bdir,$dh); |
05454584 | 1928 | foreach $incdir ($CPAN::Config->{'cpan_home'},@INC) { |
8d97e4a1 JH |
1929 | my @bbase = "Bundle"; |
1930 | while (my $bbase = shift @bbase) { | |
5de3f0da | 1931 | $bdir = File::Spec->catdir($incdir,split /::/, $bbase); |
8d97e4a1 JH |
1932 | CPAN->debug("bdir[$bdir]\@bbase[@bbase]") if $CPAN::DEBUG; |
1933 | if ($dh = DirHandle->new($bdir)) { # may fail | |
1934 | my($entry); | |
1935 | for $entry ($dh->read) { | |
c049f953 | 1936 | next if $entry =~ /^\./; |
b96578bb | 1937 | next unless $entry =~ /^\w+(\.pm)?(?!\n)\Z/; |
f04ea8d1 | 1938 | if (-d File::Spec->catdir($bdir,$entry)) { |
8d97e4a1 JH |
1939 | push @bbase, "$bbase\::$entry"; |
1940 | } else { | |
1941 | next unless $entry =~ s/\.pm(?!\n)\Z//; | |
1942 | $CPAN::META->instance('CPAN::Bundle',"$bbase\::$entry"); | |
1943 | } | |
1944 | } | |
1945 | } | |
1946 | } | |
05454584 | 1947 | } |
6d29edf5 JH |
1948 | } |
1949 | ||
1950 | #-> sub CPAN::Shell::b ; | |
1951 | sub b { | |
1952 | my($self,@which) = @_; | |
1953 | CPAN->debug("which[@which]") if $CPAN::DEBUG; | |
1954 | $self->local_bundles; | |
c356248b | 1955 | $CPAN::Frontend->myprint($self->format_result('Bundle',@which)); |
05454584 | 1956 | } |
6d29edf5 | 1957 | |
05454584 | 1958 | #-> sub CPAN::Shell::d ; |
c356248b | 1959 | sub d { $CPAN::Frontend->myprint(shift->format_result('Distribution',@_));} |
6d29edf5 | 1960 | |
05454584 | 1961 | #-> sub CPAN::Shell::m ; |
f610777f | 1962 | sub m { # emacs confused here }; sub mimimimimi { # emacs in sync here |
35576f8c A |
1963 | my $self = shift; |
1964 | $CPAN::Frontend->myprint($self->format_result('Module',@_)); | |
f610777f | 1965 | } |
da199366 | 1966 | |
05454584 A |
1967 | #-> sub CPAN::Shell::i ; |
1968 | sub i { | |
1969 | my($self) = shift; | |
1970 | my(@args) = @_; | |
05454584 A |
1971 | @args = '/./' unless @args; |
1972 | my(@result); | |
190aa835 | 1973 | for my $type (qw/Bundle Distribution Module/) { |
f04ea8d1 | 1974 | push @result, $self->expand($type,@args); |
05454584 | 1975 | } |
190aa835 MS |
1976 | # Authors are always uppercase. |
1977 | push @result, $self->expand("Author", map { uc $_ } @args); | |
1978 | ||
8d97e4a1 | 1979 | my $result = @result == 1 ? |
f04ea8d1 | 1980 | $result[0]->as_string : |
8d97e4a1 JH |
1981 | @result == 0 ? |
1982 | "No objects found of any type for argument @args\n" : | |
1983 | join("", | |
1984 | (map {$_->as_glimpse} @result), | |
1985 | scalar @result, " items found\n", | |
1986 | ); | |
c356248b | 1987 | $CPAN::Frontend->myprint($result); |
da199366 | 1988 | } |
da199366 | 1989 | |
05454584 | 1990 | #-> sub CPAN::Shell::o ; |
5e05dca5 | 1991 | |
8962fc49 SP |
1992 | # CPAN::Shell::o and CPAN::HandleConfig::edit are closely related. 'o |
1993 | # conf' calls through to CPAN::HandleConfig::edit. 'o conf' should | |
135a59c2 A |
1994 | # probably have been called 'set' and 'o debug' maybe 'set debug' or |
1995 | # 'debug'; 'o conf ARGS' calls ->edit in CPAN/HandleConfig.pm | |
05454584 A |
1996 | sub o { |
1997 | my($self,$o_type,@o_what) = @_; | |
1998 | $o_type ||= ""; | |
1999 | CPAN->debug("o_type[$o_type] o_what[".join(" | ",@o_what)."]\n"); | |
2000 | if ($o_type eq 'conf') { | |
ecc7fca0 A |
2001 | my($cfilter); |
2002 | ($cfilter) = $o_what[0] =~ m|^/(.*)/$| if @o_what; | |
f04ea8d1 SP |
2003 | if (!@o_what or $cfilter) { # print all things, "o conf" |
2004 | $cfilter ||= ""; | |
2005 | my $qrfilter = eval 'qr/$cfilter/'; | |
2006 | my($k,$v); | |
2007 | $CPAN::Frontend->myprint("\$CPAN::Config options from "); | |
ed84aac9 | 2008 | my @from; |
f04ea8d1 | 2009 | if (exists $INC{'CPAN/Config.pm'}) { |
ed84aac9 | 2010 | push @from, $INC{'CPAN/Config.pm'}; |
f04ea8d1 SP |
2011 | } |
2012 | if (exists $INC{'CPAN/MyConfig.pm'}) { | |
ed84aac9 | 2013 | push @from, $INC{'CPAN/MyConfig.pm'}; |
f04ea8d1 | 2014 | } |
ed84aac9 | 2015 | $CPAN::Frontend->myprint(join " and ", map {"'$_'"} @from); |
f04ea8d1 SP |
2016 | $CPAN::Frontend->myprint(":\n"); |
2017 | for $k (sort keys %CPAN::HandleConfig::can) { | |
2018 | next unless $k =~ /$qrfilter/; | |
2019 | $v = $CPAN::HandleConfig::can{$k}; | |
2020 | $CPAN::Frontend->myprint(sprintf " %-18s [%s]\n", $k, $v); | |
2021 | } | |
2022 | $CPAN::Frontend->myprint("\n"); | |
2023 | for $k (sort keys %CPAN::HandleConfig::keys) { | |
2024 | next unless $k =~ /$qrfilter/; | |
e82b9348 | 2025 | CPAN::HandleConfig->prettyprint($k); |
f04ea8d1 SP |
2026 | } |
2027 | $CPAN::Frontend->myprint("\n"); | |
f20de9f0 | 2028 | } else { |
05bab18e | 2029 | if (CPAN::HandleConfig->edit(@o_what)) { |
05bab18e SP |
2030 | } else { |
2031 | $CPAN::Frontend->myprint(qq{Type 'o conf' to view all configuration }. | |
2032 | qq{items\n\n}); | |
2033 | } | |
f04ea8d1 | 2034 | } |
05454584 | 2035 | } elsif ($o_type eq 'debug') { |
f04ea8d1 SP |
2036 | my(%valid); |
2037 | @o_what = () if defined $o_what[0] && $o_what[0] =~ /help/i; | |
2038 | if (@o_what) { | |
2039 | while (@o_what) { | |
2040 | my($what) = shift @o_what; | |
8d97e4a1 JH |
2041 | if ($what =~ s/^-// && exists $CPAN::DEBUG{$what}) { |
2042 | $CPAN::DEBUG &= $CPAN::DEBUG ^ $CPAN::DEBUG{$what}; | |
2043 | next; | |
2044 | } | |
f04ea8d1 SP |
2045 | if ( exists $CPAN::DEBUG{$what} ) { |
2046 | $CPAN::DEBUG |= $CPAN::DEBUG{$what}; | |
2047 | } elsif ($what =~ /^\d/) { | |
2048 | $CPAN::DEBUG = $what; | |
2049 | } elsif (lc $what eq 'all') { | |
2050 | my($max) = 0; | |
2051 | for (values %CPAN::DEBUG) { | |
2052 | $max += $_; | |
2053 | } | |
2054 | $CPAN::DEBUG = $max; | |
2055 | } else { | |
2056 | my($known) = 0; | |
2057 | for (keys %CPAN::DEBUG) { | |
2058 | next unless lc($_) eq lc($what); | |
2059 | $CPAN::DEBUG |= $CPAN::DEBUG{$_}; | |
2060 | $known = 1; | |
2061 | } | |
2062 | $CPAN::Frontend->myprint("unknown argument [$what]\n") | |
2063 | unless $known; | |
2064 | } | |
2065 | } | |
2066 | } else { | |
2067 | my $raw = "Valid options for debug are ". | |
2068 | join(", ",sort(keys %CPAN::DEBUG), 'all'). | |
2069 | qq{ or a number. Completion works on the options. }. | |
2070 | qq{Case is ignored.}; | |
2071 | require Text::Wrap; | |
2072 | $CPAN::Frontend->myprint(Text::Wrap::fill("","",$raw)); | |
2073 | $CPAN::Frontend->myprint("\n\n"); | |
2074 | } | |
2075 | if ($CPAN::DEBUG) { | |
2076 | $CPAN::Frontend->myprint("Options set for debugging ($CPAN::DEBUG):\n"); | |
2077 | my($k,$v); | |
2078 | for $k (sort {$CPAN::DEBUG{$a} <=> $CPAN::DEBUG{$b}} keys %CPAN::DEBUG) { | |
2079 | $v = $CPAN::DEBUG{$k}; | |
2080 | $CPAN::Frontend->myprint(sprintf " %-14s(%s)\n", $k, $v) | |
05d2a450 | 2081 | if $v & $CPAN::DEBUG; |
f04ea8d1 SP |
2082 | } |
2083 | } else { | |
2084 | $CPAN::Frontend->myprint("Debugging turned off completely.\n"); | |
2085 | } | |
05454584 | 2086 | } else { |
f04ea8d1 | 2087 | $CPAN::Frontend->myprint(qq{ |
05454584 A |
2088 | Known options: |
2089 | conf set or get configuration variables | |
2090 | debug set or get debugging options | |
c356248b | 2091 | }); |
5f05dabc | 2092 | } |
5f05dabc | 2093 | } |
2094 | ||
6a935156 | 2095 | # CPAN::Shell::paintdots_onreload |
6d29edf5 | 2096 | sub paintdots_onreload { |
36263cb3 GS |
2097 | my($ref) = shift; |
2098 | sub { | |
f04ea8d1 SP |
2099 | if ( $_[0] =~ /[Ss]ubroutine ([\w:]+) redefined/ ) { |
2100 | my($subr) = $1; | |
2101 | ++$$ref; | |
2102 | local($|) = 1; | |
2103 | # $CPAN::Frontend->myprint(".($subr)"); | |
2104 | $CPAN::Frontend->myprint("."); | |
6a935156 SP |
2105 | if ($subr =~ /\bshell\b/i) { |
2106 | # warn "debug[$_[0]]"; | |
2107 | ||
2108 | # It would be nice if we could detect that a | |
2109 | # subroutine has actually changed, but for now we | |
2110 | # practically always set the GOTOSHELL global | |
2111 | ||
2112 | $CPAN::GOTOSHELL=1; | |
2113 | } | |
f04ea8d1 SP |
2114 | return; |
2115 | } | |
2116 | warn @_; | |
36263cb3 GS |
2117 | }; |
2118 | } | |
2119 | ||
05bab18e SP |
2120 | #-> sub CPAN::Shell::hosts ; |
2121 | sub hosts { | |
2122 | my($self) = @_; | |
2123 | my $fullstats = CPAN::FTP->_ftp_statistics(); | |
2124 | my $history = $fullstats->{history} || []; | |
2125 | my %S; # statistics | |
2126 | while (my $last = pop @$history) { | |
2127 | my $attempts = $last->{attempts} or next; | |
2128 | my $start; | |
2129 | if (@$attempts) { | |
2130 | $start = $attempts->[-1]{start}; | |
2131 | if ($#$attempts > 0) { | |
2132 | for my $i (0..$#$attempts-1) { | |
2133 | my $url = $attempts->[$i]{url} or next; | |
2134 | $S{no}{$url}++; | |
2135 | } | |
2136 | } | |
2137 | } else { | |
2138 | $start = $last->{start}; | |
2139 | } | |
2140 | next unless $last->{thesiteurl}; # C-C? bad filenames? | |
2141 | $S{start} = $start; | |
2142 | $S{end} ||= $last->{end}; | |
2143 | my $dltime = $last->{end} - $start; | |
2144 | my $dlsize = $last->{filesize} || 0; | |
f20de9f0 | 2145 | my $url = ref $last->{thesiteurl} ? $last->{thesiteurl}->text : $last->{thesiteurl}; |
05bab18e SP |
2146 | my $s = $S{ok}{$url} ||= {}; |
2147 | $s->{n}++; | |
2148 | $s->{dlsize} ||= 0; | |
2149 | $s->{dlsize} += $dlsize/1024; | |
2150 | $s->{dltime} ||= 0; | |
2151 | $s->{dltime} += $dltime; | |
2152 | } | |
2153 | my $res; | |
2154 | for my $url (keys %{$S{ok}}) { | |
2155 | next if $S{ok}{$url}{dltime} == 0; # div by zero | |
2156 | push @{$res->{ok}}, [@{$S{ok}{$url}}{qw(n dlsize dltime)}, | |
2157 | $S{ok}{$url}{dlsize}/$S{ok}{$url}{dltime}, | |
2158 | $url, | |
2159 | ]; | |
2160 | } | |
2161 | for my $url (keys %{$S{no}}) { | |
2162 | push @{$res->{no}}, [$S{no}{$url}, | |
2163 | $url, | |
2164 | ]; | |
2165 | } | |
2166 | my $R = ""; # report | |
b72dd56f SP |
2167 | if ($S{start} && $S{end}) { |
2168 | $R .= sprintf "Log starts: %s\n", $S{start} ? scalar(localtime $S{start}) : "unknown"; | |
2169 | $R .= sprintf "Log ends : %s\n", $S{end} ? scalar(localtime $S{end}) : "unknown"; | |
2170 | } | |
05bab18e SP |
2171 | if ($res->{ok} && @{$res->{ok}}) { |
2172 | $R .= sprintf "\nSuccessful downloads: | |
2173 | N kB secs kB/s url\n"; | |
be34b10d | 2174 | my $i = 20; |
05bab18e SP |
2175 | for (sort { $b->[3] <=> $a->[3] } @{$res->{ok}}) { |
2176 | $R .= sprintf "%4d %8d %5d %9.1f %s\n", @$_; | |
be34b10d | 2177 | last if --$i<=0; |
05bab18e SP |
2178 | } |
2179 | } | |
2180 | if ($res->{no} && @{$res->{no}}) { | |
2181 | $R .= sprintf "\nUnsuccessful downloads:\n"; | |
be34b10d | 2182 | my $i = 20; |
05bab18e SP |
2183 | for (sort { $b->[0] <=> $a->[0] } @{$res->{no}}) { |
2184 | $R .= sprintf "%4d %s\n", @$_; | |
be34b10d | 2185 | last if --$i<=0; |
05bab18e SP |
2186 | } |
2187 | } | |
2188 | $CPAN::Frontend->myprint($R); | |
2189 | } | |
2190 | ||
05454584 A |
2191 | #-> sub CPAN::Shell::reload ; |
2192 | sub reload { | |
d4fd5c69 A |
2193 | my($self,$command,@arg) = @_; |
2194 | $command ||= ""; | |
2195 | $self->debug("self[$self]command[$command]arg[@arg]") if $CPAN::DEBUG; | |
135a59c2 | 2196 | if ($command =~ /^cpan$/i) { |
e82b9348 | 2197 | my $redef = 0; |
0cf35e6a SP |
2198 | chdir $CPAN::iCwd if $CPAN::iCwd; # may fail |
2199 | my $failed; | |
8962fc49 SP |
2200 | my @relo = ( |
2201 | "CPAN.pm", | |
8962fc49 | 2202 | "CPAN/Debug.pm", |
810a0276 SP |
2203 | "CPAN/FirstTime.pm", |
2204 | "CPAN/HandleConfig.pm", | |
2205 | "CPAN/Kwalify.pm", | |
135a59c2 | 2206 | "CPAN/Queue.pm", |
f04ea8d1 SP |
2207 | "CPAN/Reporter/Config.pm", |
2208 | "CPAN/Reporter/History.pm", | |
135a59c2 | 2209 | "CPAN/Reporter.pm", |
f20de9f0 | 2210 | "CPAN/SQLite.pm", |
810a0276 SP |
2211 | "CPAN/Tarzip.pm", |
2212 | "CPAN/Version.pm", | |
8962fc49 | 2213 | ); |
8962fc49 | 2214 | MFILE: for my $f (@relo) { |
135a59c2 A |
2215 | next unless exists $INC{$f}; |
2216 | my $p = $f; | |
2217 | $p =~ s/\.pm$//; | |
2218 | $p =~ s|/|::|g; | |
2219 | $CPAN::Frontend->myprint("($p"); | |
5fc0f0f6 | 2220 | local($SIG{__WARN__}) = paintdots_onreload(\$redef); |
810a0276 | 2221 | $self->_reload_this($f) or $failed++; |
135a59c2 A |
2222 | my $v = eval "$p\::->VERSION"; |
2223 | $CPAN::Frontend->myprint("v$v)"); | |
5fc0f0f6 | 2224 | } |
e82b9348 | 2225 | $CPAN::Frontend->myprint("\n$redef subroutines redefined\n"); |
0cf35e6a | 2226 | if ($failed) { |
135a59c2 A |
2227 | my $errors = $failed == 1 ? "error" : "errors"; |
2228 | $CPAN::Frontend->mywarn("\n$failed $errors during reload. You better quit ". | |
0cf35e6a SP |
2229 | "this session.\n"); |
2230 | } | |
135a59c2 | 2231 | } elsif ($command =~ /^index$/i) { |
2e2b7522 | 2232 | CPAN::Index->force_reload; |
d4fd5c69 | 2233 | } else { |
135a59c2 | 2234 | $CPAN::Frontend->myprint(qq{cpan re-evals the CPAN modules |
f14b5cec | 2235 | index re-reads the index files\n}); |
05454584 A |
2236 | } |
2237 | } | |
2238 | ||
2ccf00a7 | 2239 | # reload means only load again what we have loaded before |
810a0276 SP |
2240 | #-> sub CPAN::Shell::_reload_this ; |
2241 | sub _reload_this { | |
6a935156 | 2242 | my($self,$f,$args) = @_; |
7d97ad34 | 2243 | CPAN->debug("f[$f]") if $CPAN::DEBUG; |
2ccf00a7 SP |
2244 | return 1 unless $INC{$f}; # we never loaded this, so we do not |
2245 | # reload but say OK | |
c9869e1c | 2246 | my $pwd = CPAN::anycwd(); |
7d97ad34 SP |
2247 | CPAN->debug("pwd[$pwd]") if $CPAN::DEBUG; |
2248 | my($file); | |
c9869e1c | 2249 | for my $inc (@INC) { |
7d97ad34 SP |
2250 | $file = File::Spec->catfile($inc,split /\//, $f); |
2251 | last if -f $file; | |
2252 | $file = ""; | |
2253 | } | |
2254 | CPAN->debug("file[$file]") if $CPAN::DEBUG; | |
2255 | my @inc = @INC; | |
2256 | unless ($file && -f $file) { | |
2257 | # this thingie is not in the INC path, maybe CPAN/MyConfig.pm? | |
2258 | $file = $INC{$f}; | |
6658a91b SP |
2259 | unless (CPAN->has_inst("File::Basename")) { |
2260 | @inc = File::Basename::dirname($file); | |
2261 | } else { | |
2262 | # do we ever need this? | |
2263 | @inc = substr($file,0,-length($f)-1); # bring in back to me! | |
2264 | } | |
7d97ad34 SP |
2265 | } |
2266 | CPAN->debug("file[$file]inc[@inc]") if $CPAN::DEBUG; | |
2267 | unless (-f $file) { | |
c9869e1c SP |
2268 | $CPAN::Frontend->mywarn("Found no file to reload for '$f'\n"); |
2269 | return; | |
2270 | } | |
6a935156 | 2271 | my $mtime = (stat $file)[9]; |
f04ea8d1 SP |
2272 | if ($reload->{$f}) { |
2273 | } elsif ($^T < $mtime) { | |
2274 | # since we started the file has changed, force it to be reloaded | |
2275 | $reload->{$f} = -1; | |
2276 | } else { | |
2277 | $reload->{$f} = $mtime; | |
2278 | } | |
2279 | my $must_reload = $mtime != $reload->{$f}; | |
6a935156 | 2280 | $args ||= {}; |
f04ea8d1 | 2281 | $must_reload ||= $args->{reloforce}; # o conf defaults needs this |
6a935156 SP |
2282 | if ($must_reload) { |
2283 | my $fh = FileHandle->new($file) or | |
2284 | $CPAN::Frontend->mydie("Could not open $file: $!"); | |
2285 | local($/); | |
2286 | local $^W = 1; | |
2287 | my $content = <$fh>; | |
2288 | CPAN->debug(sprintf("reload file[%s] content[%s...]",$file,substr($content,0,128))) | |
2289 | if $CPAN::DEBUG; | |
2290 | delete $INC{$f}; | |
2291 | local @INC = @inc; | |
2292 | eval "require '$f'"; | |
f04ea8d1 | 2293 | if ($@) { |
6a935156 SP |
2294 | warn $@; |
2295 | return; | |
2296 | } | |
f04ea8d1 | 2297 | $reload->{$f} = $mtime; |
6a935156 SP |
2298 | } else { |
2299 | $CPAN::Frontend->myprint("__unchanged__"); | |
c9869e1c SP |
2300 | } |
2301 | return 1; | |
2302 | } | |
2303 | ||
44d21104 A |
2304 | #-> sub CPAN::Shell::mkmyconfig ; |
2305 | sub mkmyconfig { | |
2306 | my($self, $cpanpm, %args) = @_; | |
2307 | require CPAN::FirstTime; | |
87892b73 RGS |
2308 | my $home = CPAN::HandleConfig::home; |
2309 | $cpanpm = $INC{'CPAN/MyConfig.pm'} || | |
2310 | File::Spec->catfile(split /\//, "$home/.cpan/CPAN/MyConfig.pm"); | |
44d21104 | 2311 | File::Path::mkpath(File::Basename::dirname($cpanpm)) unless -e $cpanpm; |
87892b73 | 2312 | CPAN::HandleConfig::require_myconfig_or_config; |
44d21104 A |
2313 | $CPAN::Config ||= {}; |
2314 | $CPAN::Config = { | |
2315 | %$CPAN::Config, | |
2316 | build_dir => undef, | |
2317 | cpan_home => undef, | |
2318 | keep_source_where => undef, | |
2319 | histfile => undef, | |
2320 | }; | |
2321 | CPAN::FirstTime::init($cpanpm, %args); | |
2322 | } | |
2323 | ||
05454584 A |
2324 | #-> sub CPAN::Shell::_binary_extensions ; |
2325 | sub _binary_extensions { | |
2326 | my($self) = shift @_; | |
2327 | my(@result,$module,%seen,%need,$headerdone); | |
2328 | for $module ($self->expand('Module','/./')) { | |
f04ea8d1 SP |
2329 | my $file = $module->cpan_file; |
2330 | next if $file eq "N/A"; | |
2331 | next if $file =~ /^Contact Author/; | |
05d2a450 | 2332 | my $dist = $CPAN::META->instance('CPAN::Distribution',$file); |
f04ea8d1 SP |
2333 | next if $dist->isa_perl; |
2334 | next unless $module->xs_file; | |
2335 | local($|) = 1; | |
2336 | $CPAN::Frontend->myprint("."); | |
2337 | push @result, $module; | |
05454584 A |
2338 | } |
2339 | # print join " | ", @result; | |
c356248b | 2340 | $CPAN::Frontend->myprint("\n"); |
05454584 A |
2341 | return @result; |
2342 | } | |
2343 | ||
2344 | #-> sub CPAN::Shell::recompile ; | |
2345 | sub recompile { | |
2346 | my($self) = shift @_; | |
2347 | my($module,@module,$cpan_file,%dist); | |
2348 | @module = $self->_binary_extensions(); | |
f04ea8d1 | 2349 | for $module (@module) { # we force now and compile later, so we |
c356248b | 2350 | # don't do it twice |
f04ea8d1 SP |
2351 | $cpan_file = $module->cpan_file; |
2352 | my $pack = $CPAN::META->instance('CPAN::Distribution',$cpan_file); | |
2353 | $pack->force; | |
2354 | $dist{$cpan_file}++; | |
05454584 A |
2355 | } |
2356 | for $cpan_file (sort keys %dist) { | |
f04ea8d1 SP |
2357 | $CPAN::Frontend->myprint(" CPAN: Recompiling $cpan_file\n\n"); |
2358 | my $pack = $CPAN::META->instance('CPAN::Distribution',$cpan_file); | |
2359 | $pack->install; | |
2360 | $CPAN::Signal = 0; # it's tempting to reset Signal, so we can | |
05454584 A |
2361 | # stop a package from recompiling, |
2362 | # e.g. IO-1.12 when we have perl5.003_10 | |
2363 | } | |
2364 | } | |
2365 | ||
ed84aac9 A |
2366 | #-> sub CPAN::Shell::scripts ; |
2367 | sub scripts { | |
2368 | my($self, $arg) = @_; | |
2369 | $CPAN::Frontend->mywarn(">>>> experimental command, currently unsupported <<<<\n\n"); | |
2370 | ||
8962fc49 SP |
2371 | for my $req (qw( HTML::LinkExtor Sort::Versions List::Util )) { |
2372 | unless ($CPAN::META->has_inst($req)) { | |
2373 | $CPAN::Frontend->mywarn(" $req not available\n"); | |
2374 | } | |
2375 | } | |
ed84aac9 A |
2376 | my $p = HTML::LinkExtor->new(); |
2377 | my $indexfile = "/home/ftp/pub/PAUSE/scripts/new/index.html"; | |
2378 | unless (-f $indexfile) { | |
2379 | $CPAN::Frontend->mydie("found no indexfile[$indexfile]\n"); | |
2380 | } | |
2381 | $p->parse_file($indexfile); | |
2382 | my @hrefs; | |
2383 | my $qrarg; | |
2384 | if ($arg =~ s|^/(.+)/$|$1|) { | |
8962fc49 | 2385 | $qrarg = eval 'qr/$arg/'; # hide construct from 5.004 |
ed84aac9 A |
2386 | } |
2387 | for my $l ($p->links) { | |
2388 | my $tag = shift @$l; | |
2389 | next unless $tag eq "a"; | |
2390 | my %att = @$l; | |
2391 | my $href = $att{href}; | |
2392 | next unless $href =~ s|^\.\./authors/id/./../||; | |
2393 | if ($arg) { | |
2394 | if ($qrarg) { | |
2395 | if ($href =~ $qrarg) { | |
2396 | push @hrefs, $href; | |
2397 | } | |
2398 | } else { | |
2399 | if ($href =~ /\Q$arg\E/) { | |
2400 | push @hrefs, $href; | |
2401 | } | |
2402 | } | |
2403 | } else { | |
2404 | push @hrefs, $href; | |
2405 | } | |
2406 | } | |
2407 | # now filter for the latest version if there is more than one of a name | |
2408 | my %stems; | |
2409 | for (sort @hrefs) { | |
2410 | my $href = $_; | |
2411 | s/-v?\d.*//; | |
2412 | my $stem = $_; | |
2413 | $stems{$stem} ||= []; | |
2414 | push @{$stems{$stem}}, $href; | |
2415 | } | |
2416 | for (sort keys %stems) { | |
2417 | my $highest; | |
2418 | if (@{$stems{$_}} > 1) { | |
2419 | $highest = List::Util::reduce { | |
2420 | Sort::Versions::versioncmp($a,$b) > 0 ? $a : $b | |
2421 | } @{$stems{$_}}; | |
2422 | } else { | |
2423 | $highest = $stems{$_}[0]; | |
2424 | } | |
2425 | $CPAN::Frontend->myprint("$highest\n"); | |
2426 | } | |
2427 | } | |
2428 | ||
8fc516fe SP |
2429 | #-> sub CPAN::Shell::report ; |
2430 | sub report { | |
2431 | my($self,@args) = @_; | |
2432 | unless ($CPAN::META->has_inst("CPAN::Reporter")) { | |
2433 | $CPAN::Frontend->mydie("CPAN::Reporter not installed; cannot continue"); | |
2434 | } | |
2435 | local $CPAN::Config->{test_report} = 1; | |
6658a91b SP |
2436 | $self->force("test",@args); # force is there so that the test be |
2437 | # re-run (as documented) | |
8fc516fe SP |
2438 | } |
2439 | ||
f20de9f0 | 2440 | # compare with is_tested |
05bab18e SP |
2441 | #-> sub CPAN::Shell::install_tested |
2442 | sub install_tested { | |
2443 | my($self,@some) = @_; | |
b72dd56f | 2444 | $CPAN::Frontend->mywarn("install_tested() must not be called with arguments.\n"), |
05bab18e SP |
2445 | return if @some; |
2446 | CPAN::Index->reload; | |
2447 | ||
b72dd56f SP |
2448 | for my $b (reverse $CPAN::META->_list_sorted_descending_is_tested) { |
2449 | my $yaml = "$b.yml"; | |
f04ea8d1 | 2450 | unless (-f $yaml) { |
b72dd56f SP |
2451 | $CPAN::Frontend->mywarn("No YAML file for $b available, skipping\n"); |
2452 | next; | |
2453 | } | |
f20de9f0 SP |
2454 | my $yaml_content = CPAN->_yaml_loadfile($yaml); |
2455 | my $id = $yaml_content->[0]{distribution}{ID}; | |
f04ea8d1 | 2456 | unless ($id) { |
b72dd56f SP |
2457 | $CPAN::Frontend->mywarn("No ID found in '$yaml', skipping\n"); |
2458 | next; | |
2459 | } | |
2460 | my $do = CPAN::Shell->expandany($id); | |
f04ea8d1 | 2461 | unless ($do) { |
b72dd56f SP |
2462 | $CPAN::Frontend->mywarn("Could not expand ID '$id', skipping\n"); |
2463 | next; | |
2464 | } | |
2465 | unless ($do->{build_dir}) { | |
2466 | $CPAN::Frontend->mywarn("Distro '$id' has no build_dir, skipping\n"); | |
2467 | next; | |
2468 | } | |
2469 | unless ($do->{build_dir} eq $b) { | |
2470 | $CPAN::Frontend->mywarn("Distro '$id' has build_dir '$do->{build_dir}' but expected '$b', skipping\n"); | |
2471 | next; | |
2472 | } | |
05bab18e SP |
2473 | push @some, $do; |
2474 | } | |
2475 | ||
2476 | $CPAN::Frontend->mywarn("No tested distributions found.\n"), | |
2477 | return unless @some; | |
2478 | ||
2479 | @some = grep { $_->{make_test} && ! $_->{make_test}->failed } @some; | |
2480 | $CPAN::Frontend->mywarn("No distributions tested with this build of perl found.\n"), | |
2481 | return unless @some; | |
2482 | ||
b72dd56f SP |
2483 | # @some = grep { not $_->uptodate } @some; |
2484 | # $CPAN::Frontend->mywarn("No non-uptodate distributions tested with this build of perl found.\n"), | |
2485 | # return unless @some; | |
05bab18e SP |
2486 | |
2487 | CPAN->debug("some[@some]"); | |
2488 | for my $d (@some) { | |
2489 | my $id = $d->can("pretty_id") ? $d->pretty_id : $d->id; | |
2490 | $CPAN::Frontend->myprint("install_tested: Running for $id\n"); | |
b72dd56f | 2491 | $CPAN::Frontend->mysleep(1); |
05bab18e SP |
2492 | $self->install($d); |
2493 | } | |
2494 | } | |
2495 | ||
ed84aac9 A |
2496 | #-> sub CPAN::Shell::upgrade ; |
2497 | sub upgrade { | |
135a59c2 A |
2498 | my($self,@args) = @_; |
2499 | $self->install($self->r(@args)); | |
ed84aac9 A |
2500 | } |
2501 | ||
05454584 A |
2502 | #-> sub CPAN::Shell::_u_r_common ; |
2503 | sub _u_r_common { | |
2504 | my($self) = shift @_; | |
2505 | my($what) = shift @_; | |
2506 | CPAN->debug("self[$self] what[$what] args[@_]") if $CPAN::DEBUG; | |
c4d24d4c A |
2507 | Carp::croak "Usage: \$obj->_u_r_common(a|r|u)" unless |
2508 | $what && $what =~ /^[aru]$/; | |
05454584 A |
2509 | my(@args) = @_; |
2510 | @args = '/./' unless @args; | |
c356248b | 2511 | my(@result,$module,%seen,%need,$headerdone, |
f04ea8d1 SP |
2512 | $version_undefs,$version_zeroes, |
2513 | @version_undefs,@version_zeroes); | |
c356248b | 2514 | $version_undefs = $version_zeroes = 0; |
9d61fa1d | 2515 | my $sprintf = "%s%-25s%s %9s %9s %s\n"; |
6d29edf5 JH |
2516 | my @expand = $self->expand('Module',@args); |
2517 | my $expand = scalar @expand; | |
2518 | if (0) { # Looks like noise to me, was very useful for debugging | |
2519 | # for metadata cache | |
2520 | $CPAN::Frontend->myprint(sprintf "%d matches in the database\n", $expand); | |
2521 | } | |
554a9ef5 | 2522 | MODULE: for $module (@expand) { |
f04ea8d1 SP |
2523 | my $file = $module->cpan_file; |
2524 | next MODULE unless defined $file; # ?? | |
2525 | $file =~ s!^./../!!; | |
2526 | my($latest) = $module->cpan_version; | |
2527 | my($inst_file) = $module->inst_file; | |
2528 | my($have); | |
2529 | return if $CPAN::Signal; | |
2530 | if ($inst_file) { | |
2531 | if ($what eq "a") { | |
2532 | $have = $module->inst_version; | |
2533 | } elsif ($what eq "r") { | |
2534 | $have = $module->inst_version; | |
2535 | local($^W) = 0; | |
2536 | if ($have eq "undef") { | |
2537 | $version_undefs++; | |
2538 | push @version_undefs, $module->as_glimpse; | |
2539 | } elsif (CPAN::Version->vcmp($have,0)==0) { | |
2540 | $version_zeroes++; | |
2541 | push @version_zeroes, $module->as_glimpse; | |
2542 | } | |
2543 | next MODULE unless CPAN::Version->vgt($latest, $have); | |
c356248b A |
2544 | # to be pedantic we should probably say: |
2545 | # && !($have eq "undef" && $latest ne "undef" && $latest gt ""); | |
2546 | # to catch the case where CPAN has a version 0 and we have a version undef | |
f04ea8d1 SP |
2547 | } elsif ($what eq "u") { |
2548 | next MODULE; | |
2549 | } | |
2550 | } else { | |
2551 | if ($what eq "a") { | |
2552 | next MODULE; | |
2553 | } elsif ($what eq "r") { | |
2554 | next MODULE; | |
2555 | } elsif ($what eq "u") { | |
2556 | $have = "-"; | |
2557 | } | |
2558 | } | |
2559 | return if $CPAN::Signal; # this is sometimes lengthy | |
2560 | $seen{$file} ||= 0; | |
2561 | if ($what eq "a") { | |
2562 | push @result, sprintf "%s %s\n", $module->id, $have; | |
2563 | } elsif ($what eq "r") { | |
2564 | push @result, $module->id; | |
2565 | next MODULE if $seen{$file}++; | |
2566 | } elsif ($what eq "u") { | |
2567 | push @result, $module->id; | |
2568 | next MODULE if $seen{$file}++; | |
2569 | next MODULE if $file =~ /^Contact/; | |
2570 | } | |
2571 | unless ($headerdone++) { | |
2572 | $CPAN::Frontend->myprint("\n"); | |
2573 | $CPAN::Frontend->myprint(sprintf( | |
9d61fa1d A |
2574 | $sprintf, |
2575 | "", | |
2576 | "Package namespace", | |
2577 | "", | |
2578 | "installed", | |
2579 | "latest", | |
2580 | "in CPAN file" | |
2581 | )); | |
f04ea8d1 | 2582 | } |
9d61fa1d A |
2583 | my $color_on = ""; |
2584 | my $color_off = ""; | |
2585 | if ( | |
2586 | $COLOR_REGISTERED | |
2587 | && | |
2588 | $CPAN::META->has_inst("Term::ANSIColor") | |
2589 | && | |
0cf35e6a | 2590 | $module->description |
9d61fa1d A |
2591 | ) { |
2592 | $color_on = Term::ANSIColor::color("green"); | |
2593 | $color_off = Term::ANSIColor::color("reset"); | |
2594 | } | |
f04ea8d1 | 2595 | $CPAN::Frontend->myprint(sprintf $sprintf, |
9d61fa1d | 2596 | $color_on, |
05d2a450 | 2597 | $module->id, |
9d61fa1d | 2598 | $color_off, |
05d2a450 A |
2599 | $have, |
2600 | $latest, | |
2601 | $file); | |
f04ea8d1 | 2602 | $need{$module->id}++; |
05454584 A |
2603 | } |
2604 | unless (%need) { | |
f04ea8d1 SP |
2605 | if ($what eq "u") { |
2606 | $CPAN::Frontend->myprint("No modules found for @args\n"); | |
2607 | } elsif ($what eq "r") { | |
2608 | $CPAN::Frontend->myprint("All modules are up to date for @args\n"); | |
2609 | } | |
05454584 | 2610 | } |
c356248b | 2611 | if ($what eq "r") { |
f04ea8d1 SP |
2612 | if ($version_zeroes) { |
2613 | my $s_has = $version_zeroes > 1 ? "s have" : " has"; | |
2614 | $CPAN::Frontend->myprint(qq{$version_zeroes installed module$s_has }. | |
2615 | qq{a version number of 0\n}); | |
2616 | if ($CPAN::Config->{show_zero_versions}) { | |
2617 | local $" = "\t"; | |
2618 | $CPAN::Frontend->myprint(qq{ they are\n\t@version_zeroes\n}); | |
2619 | $CPAN::Frontend->myprint(qq{(use 'o conf show_zero_versions 0' }. | |
2620 | qq{to hide them)\n}); | |
2621 | } else { | |
2622 | $CPAN::Frontend->myprint(qq{(use 'o conf show_zero_versions 1' }. | |
2623 | qq{to show them)\n}); | |
2624 | } | |
2625 | } | |
2626 | if ($version_undefs) { | |
2627 | my $s_has = $version_undefs > 1 ? "s have" : " has"; | |
2628 | $CPAN::Frontend->myprint(qq{$version_undefs installed module$s_has no }. | |
2629 | qq{parseable version number\n}); | |
2630 | if ($CPAN::Config->{show_unparsable_versions}) { | |
2631 | local $" = "\t"; | |
2632 | $CPAN::Frontend->myprint(qq{ they are\n\t@version_undefs\n}); | |
2633 | $CPAN::Frontend->myprint(qq{(use 'o conf show_unparsable_versions 0' }. | |
2634 | qq{to hide them)\n}); | |
2635 | } else { | |
2636 | $CPAN::Frontend->myprint(qq{(use 'o conf show_unparsable_versions 1' }. | |
2637 | qq{to show them)\n}); | |
2638 | } | |
2639 | } | |
05454584 A |
2640 | } |
2641 | @result; | |
2642 | } | |
2643 | ||
2644 | #-> sub CPAN::Shell::r ; | |
2645 | sub r { | |
2646 | shift->_u_r_common("r",@_); | |
2647 | } | |
2648 | ||
2649 | #-> sub CPAN::Shell::u ; | |
2650 | sub u { | |
2651 | shift->_u_r_common("u",@_); | |
2652 | } | |
2653 | ||
0cf35e6a SP |
2654 | #-> sub CPAN::Shell::failed ; |
2655 | sub failed { | |
9ddc4ed0 | 2656 | my($self,$only_id,$silent) = @_; |
c9869e1c | 2657 | my @failed; |
0cf35e6a SP |
2658 | DIST: for my $d ($CPAN::META->all_objects("CPAN::Distribution")) { |
2659 | my $failed = ""; | |
810a0276 | 2660 | NAY: for my $nosayer ( # order matters! |
6658a91b | 2661 | "unwrapped", |
87892b73 RGS |
2662 | "writemakefile", |
2663 | "signature_verify", | |
2664 | "make", | |
2665 | "make_test", | |
2666 | "install", | |
2667 | "make_clean", | |
2668 | ) { | |
0cf35e6a | 2669 | next unless exists $d->{$nosayer}; |
be34b10d | 2670 | next unless defined $d->{$nosayer}; |
44d21104 | 2671 | next unless ( |
be34b10d | 2672 | UNIVERSAL::can($d->{$nosayer},"failed") ? |
44d21104 A |
2673 | $d->{$nosayer}->failed : |
2674 | $d->{$nosayer} =~ /^NO/ | |
2675 | ); | |
87892b73 | 2676 | next NAY if $only_id && $only_id != ( |
be34b10d | 2677 | UNIVERSAL::can($d->{$nosayer},"commandid") |
87892b73 RGS |
2678 | ? |
2679 | $d->{$nosayer}->commandid | |
2680 | : | |
2681 | $CPAN::CurrentCommandId | |
2682 | ); | |
0cf35e6a SP |
2683 | $failed = $nosayer; |
2684 | last; | |
2685 | } | |
2686 | next DIST unless $failed; | |
2687 | my $id = $d->id; | |
2688 | $id =~ s|^./../||; | |
c9869e1c SP |
2689 | #$print .= sprintf( |
2690 | # " %-45s: %s %s\n", | |
44d21104 A |
2691 | push @failed, |
2692 | ( | |
be34b10d | 2693 | UNIVERSAL::can($d->{$failed},"failed") ? |
44d21104 A |
2694 | [ |
2695 | $d->{$failed}->commandid, | |
2696 | $id, | |
2697 | $failed, | |
2698 | $d->{$failed}->text, | |
be34b10d | 2699 | $d->{$failed}{TIME}||0, |
44d21104 A |
2700 | ] : |
2701 | [ | |
2702 | 1, | |
2703 | $id, | |
2704 | $failed, | |
2705 | $d->{$failed}, | |
be34b10d | 2706 | 0, |
44d21104 A |
2707 | ] |
2708 | ); | |
0cf35e6a | 2709 | } |
be34b10d SP |
2710 | my $scope; |
2711 | if ($only_id) { | |
2712 | $scope = "this command"; | |
2713 | } elsif ($CPAN::Index::HAVE_REANIMATED) { | |
2714 | $scope = "this or a previous session"; | |
2715 | # it might be nice to have a section for previous session and | |
2716 | # a second for this | |
2717 | } else { | |
2718 | $scope = "this session"; | |
2719 | } | |
c9869e1c | 2720 | if (@failed) { |
be34b10d SP |
2721 | my $print; |
2722 | my $debug = 0; | |
2723 | if ($debug) { | |
2724 | $print = join "", | |
2725 | map { sprintf "%5d %-45s: %s %s\n", @$_ } | |
2726 | sort { $a->[0] <=> $b->[0] } @failed; | |
2727 | } else { | |
2728 | $print = join "", | |
2729 | map { sprintf " %-45s: %s %s\n", @$_[1..3] } | |
2730 | sort { | |
2731 | $a->[0] <=> $b->[0] | |
2732 | || | |
2733 | $a->[4] <=> $b->[4] | |
2734 | } @failed; | |
2735 | } | |
2736 | $CPAN::Frontend->myprint("Failed during $scope:\n$print"); | |
9ddc4ed0 | 2737 | } elsif (!$only_id || !$silent) { |
be34b10d | 2738 | $CPAN::Frontend->myprint("Nothing failed in $scope\n"); |
0cf35e6a SP |
2739 | } |
2740 | } | |
2741 | ||
c9869e1c SP |
2742 | # XXX intentionally undocumented because completely bogus, unportable, |
2743 | # useless, etc. | |
2744 | ||
0cf35e6a SP |
2745 | #-> sub CPAN::Shell::status ; |
2746 | sub status { | |
2747 | my($self) = @_; | |
2748 | require Devel::Size; | |
2749 | my $ps = FileHandle->new; | |
2750 | open $ps, "/proc/$$/status"; | |
2751 | my $vm = 0; | |
2752 | while (<$ps>) { | |
2753 | next unless /VmSize:\s+(\d+)/; | |
2754 | $vm = $1; | |
2755 | last; | |
2756 | } | |
2757 | $CPAN::Frontend->mywarn(sprintf( | |
2758 | "%-27s %6d\n%-27s %6d\n", | |
2759 | "vm", | |
2760 | $vm, | |
2761 | "CPAN::META", | |
2762 | Devel::Size::total_size($CPAN::META)/1024, | |
2763 | )); | |
2764 | for my $k (sort keys %$CPAN::META) { | |
2765 | next unless substr($k,0,4) eq "read"; | |
2766 | warn sprintf " %-26s %6d\n", $k, Devel::Size::total_size($CPAN::META->{$k})/1024; | |
2767 | for my $k2 (sort keys %{$CPAN::META->{$k}}) { | |
7d97ad34 | 2768 | warn sprintf " %-25s %6d (keys: %6d)\n", |
0cf35e6a SP |
2769 | $k2, |
2770 | Devel::Size::total_size($CPAN::META->{$k}{$k2})/1024, | |
2771 | scalar keys %{$CPAN::META->{$k}{$k2}}; | |
2772 | } | |
2773 | } | |
2774 | } | |
2775 | ||
f20de9f0 | 2776 | # compare with install_tested |
b72dd56f | 2777 | #-> sub CPAN::Shell::is_tested |
f20de9f0 | 2778 | sub is_tested { |
b72dd56f | 2779 | my($self) = @_; |
f20de9f0 | 2780 | CPAN::Index->reload; |
b72dd56f SP |
2781 | for my $b (reverse $CPAN::META->_list_sorted_descending_is_tested) { |
2782 | my $time; | |
2783 | if ($CPAN::META->{is_tested}{$b}) { | |
2784 | $time = scalar(localtime $CPAN::META->{is_tested}{$b}); | |
2785 | } else { | |
2786 | $time = scalar localtime; | |
2787 | $time =~ s/\S/?/g; | |
2788 | } | |
2789 | $CPAN::Frontend->myprint(sprintf "%s %s\n", $time, $b); | |
2790 | } | |
2791 | } | |
2792 | ||
05454584 A |
2793 | #-> sub CPAN::Shell::autobundle ; |
2794 | sub autobundle { | |
2795 | my($self) = shift; | |
e82b9348 | 2796 | CPAN::HandleConfig->load unless $CPAN::Config_loaded++; |
05454584 | 2797 | my(@bundle) = $self->_u_r_common("a",@_); |
5de3f0da | 2798 | my($todir) = File::Spec->catdir($CPAN::Config->{'cpan_home'},"Bundle"); |
05454584 A |
2799 | File::Path::mkpath($todir); |
2800 | unless (-d $todir) { | |
f04ea8d1 SP |
2801 | $CPAN::Frontend->myprint("Couldn't mkdir $todir for some reason\n"); |
2802 | return; | |
05454584 A |
2803 | } |
2804 | my($y,$m,$d) = (localtime)[5,4,3]; | |
2805 | $y+=1900; | |
2806 | $m++; | |
2807 | my($c) = 0; | |
2808 | my($me) = sprintf "Snapshot_%04d_%02d_%02d_%02d", $y, $m, $d, $c; | |
5de3f0da | 2809 | my($to) = File::Spec->catfile($todir,"$me.pm"); |
05454584 | 2810 | while (-f $to) { |
f04ea8d1 SP |
2811 | $me = sprintf "Snapshot_%04d_%02d_%02d_%02d", $y, $m, $d, ++$c; |
2812 | $to = File::Spec->catfile($todir,"$me.pm"); | |
05454584 A |
2813 | } |
2814 | my($fh) = FileHandle->new(">$to") or Carp::croak "Can't open >$to: $!"; | |
2815 | $fh->print( | |
f04ea8d1 SP |
2816 | "package Bundle::$me;\n\n", |
2817 | "\$VERSION = '0.01';\n\n", | |
2818 | "1;\n\n", | |
2819 | "__END__\n\n", | |
2820 | "=head1 NAME\n\n", | |
2821 | "Bundle::$me - Snapshot of installation on ", | |
2822 | $Config::Config{'myhostname'}, | |
2823 | " on ", | |
2824 | scalar(localtime), | |
2825 | "\n\n=head1 SYNOPSIS\n\n", | |
2826 | "perl -MCPAN -e 'install Bundle::$me'\n\n", | |
2827 | "=head1 CONTENTS\n\n", | |
2828 | join("\n", @bundle), | |
2829 | "\n\n=head1 CONFIGURATION\n\n", | |
2830 | Config->myconfig, | |
2831 | "\n\n=head1 AUTHOR\n\n", | |
2832 | "This Bundle has been generated automatically ", | |
2833 | "by the autobundle routine in CPAN.pm.\n", | |
2834 | ); | |
05454584 | 2835 | $fh->close; |
c356248b A |
2836 | $CPAN::Frontend->myprint("\nWrote bundle file |
2837 | $to\n\n"); | |
05454584 A |
2838 | } |
2839 | ||
6d29edf5 JH |
2840 | #-> sub CPAN::Shell::expandany ; |
2841 | sub expandany { | |
2842 | my($self,$s) = @_; | |
2843 | CPAN->debug("s[$s]") if $CPAN::DEBUG; | |
8fc516fe | 2844 | if ($s =~ m|/| or substr($s,-1,1) eq ".") { # looks like a file or a directory |
8d97e4a1 | 2845 | $s = CPAN::Distribution->normalize($s); |
6d29edf5 JH |
2846 | return $CPAN::META->instance('CPAN::Distribution',$s); |
2847 | # Distributions spring into existence, not expand | |
2848 | } elsif ($s =~ m|^Bundle::|) { | |
2849 | $self->local_bundles; # scanning so late for bundles seems | |
2850 | # both attractive and crumpy: always | |
2851 | # current state but easy to forget | |
2852 | # somewhere | |
2853 | return $self->expand('Bundle',$s); | |
2854 | } else { | |
2855 | return $self->expand('Module',$s) | |
2856 | if $CPAN::META->exists('CPAN::Module',$s); | |
2857 | } | |
2858 | return; | |
2859 | } | |
2860 | ||
05454584 A |
2861 | #-> sub CPAN::Shell::expand ; |
2862 | sub expand { | |
e82b9348 | 2863 | my $self = shift; |
05454584 | 2864 | my($type,@args) = @_; |
8d97e4a1 | 2865 | CPAN->debug("type[$type]args[@args]") if $CPAN::DEBUG; |
e82b9348 SP |
2866 | my $class = "CPAN::$type"; |
2867 | my $methods = ['id']; | |
2868 | for my $meth (qw(name)) { | |
e82b9348 SP |
2869 | next unless $class->can($meth); |
2870 | push @$methods, $meth; | |
2871 | } | |
2872 | $self->expand_by_method($class,$methods,@args); | |
2873 | } | |
2874 | ||
05bab18e | 2875 | #-> sub CPAN::Shell::expand_by_method ; |
e82b9348 SP |
2876 | sub expand_by_method { |
2877 | my $self = shift; | |
2878 | my($class,$methods,@args) = @_; | |
2879 | my($arg,@m); | |
05454584 | 2880 | for $arg (@args) { |
f04ea8d1 SP |
2881 | my($regex,$command); |
2882 | if ($arg =~ m|^/(.*)/$|) { | |
2883 | $regex = $1; | |
b03f445c RGS |
2884 | # FIXME: there seem to be some ='s in the author data, which trigger |
2885 | # a failure here. This needs to be contemplated. | |
2886 | # } elsif ($arg =~ m/=/) { | |
2887 | # $command = 1; | |
6d29edf5 | 2888 | } |
f04ea8d1 | 2889 | my $obj; |
8d97e4a1 JH |
2890 | CPAN->debug(sprintf "class[%s]regex[%s]command[%s]", |
2891 | $class, | |
2892 | defined $regex ? $regex : "UNDEFINED", | |
e82b9348 | 2893 | defined $command ? $command : "UNDEFINED", |
8d97e4a1 | 2894 | ) if $CPAN::DEBUG; |
f04ea8d1 | 2895 | if (defined $regex) { |
810a0276 | 2896 | if (CPAN::_sqlite_running) { |
be34b10d SP |
2897 | $CPAN::SQLite->search($class, $regex); |
2898 | } | |
6d29edf5 | 2899 | for $obj ( |
6d29edf5 JH |
2900 | $CPAN::META->all_objects($class) |
2901 | ) { | |
f04ea8d1 | 2902 | unless ($obj && UNIVERSAL::can($obj,"id") && $obj->id) { |
6d29edf5 | 2903 | # BUG, we got an empty object somewhere |
8d97e4a1 | 2904 | require Data::Dumper; |
6d29edf5 | 2905 | CPAN->debug(sprintf( |
8d97e4a1 | 2906 | "Bug in CPAN: Empty id on obj[%s][%s]", |
6d29edf5 | 2907 | $obj, |
8d97e4a1 | 2908 | Data::Dumper::Dumper($obj) |
6d29edf5 JH |
2909 | )) if $CPAN::DEBUG; |
2910 | next; | |
2911 | } | |
e82b9348 | 2912 | for my $method (@$methods) { |
135a59c2 A |
2913 | my $match = eval {$obj->$method() =~ /$regex/i}; |
2914 | if ($@) { | |
2915 | my($err) = $@ =~ /^(.+) at .+? line \d+\.$/; | |
2916 | $err ||= $@; # if we were too restrictive above | |
2917 | $CPAN::Frontend->mydie("$err\n"); | |
2918 | } elsif ($match) { | |
e82b9348 SP |
2919 | push @m, $obj; |
2920 | last; | |
2921 | } | |
2922 | } | |
6d29edf5 JH |
2923 | } |
2924 | } elsif ($command) { | |
8d97e4a1 JH |
2925 | die "equal sign in command disabled (immature interface), ". |
2926 | "you can set | |
2927 | ! \$CPAN::Shell::ADVANCED_QUERY=1 | |
2928 | to enable it. But please note, this is HIGHLY EXPERIMENTAL code | |
2929 | that may go away anytime.\n" | |
2930 | unless $ADVANCED_QUERY; | |
2931 | my($method,$criterion) = $arg =~ /(.+?)=(.+)/; | |
2932 | my($matchcrit) = $criterion =~ m/^~(.+)/; | |
6d29edf5 JH |
2933 | for my $self ( |
2934 | sort | |
2935 | {$a->id cmp $b->id} | |
2936 | $CPAN::META->all_objects($class) | |
2937 | ) { | |
8d97e4a1 JH |
2938 | my $lhs = $self->$method() or next; # () for 5.00503 |
2939 | if ($matchcrit) { | |
2940 | push @m, $self if $lhs =~ m/$matchcrit/; | |
2941 | } else { | |
2942 | push @m, $self if $lhs eq $criterion; | |
2943 | } | |
6d29edf5 | 2944 | } |
f04ea8d1 SP |
2945 | } else { |
2946 | my($xarg) = $arg; | |
2947 | if ( $class eq 'CPAN::Bundle' ) { | |
2948 | $xarg =~ s/^(Bundle::)?(.*)/Bundle::$2/; | |
2949 | } elsif ($class eq "CPAN::Distribution") { | |
8d97e4a1 | 2950 | $xarg = CPAN::Distribution->normalize($arg); |
e82b9348 SP |
2951 | } else { |
2952 | $xarg =~ s/:+/::/g; | |
8d97e4a1 | 2953 | } |
f04ea8d1 SP |
2954 | if ($CPAN::META->exists($class,$xarg)) { |
2955 | $obj = $CPAN::META->instance($class,$xarg); | |
2956 | } elsif ($CPAN::META->exists($class,$arg)) { | |
2957 | $obj = $CPAN::META->instance($class,$arg); | |
2958 | } else { | |
2959 | next; | |
2960 | } | |
2961 | push @m, $obj; | |
2962 | } | |
05454584 | 2963 | } |
ecc7fca0 | 2964 | @m = sort {$a->id cmp $b->id} @m; |
e82b9348 SP |
2965 | if ( $CPAN::DEBUG ) { |
2966 | my $wantarray = wantarray; | |
2967 | my $join_m = join ",", map {$_->id} @m; | |
2968 | $self->debug("wantarray[$wantarray]join_m[$join_m]"); | |
2969 | } | |
e50380aa | 2970 | return wantarray ? @m : $m[0]; |
05454584 A |
2971 | } |
2972 | ||
2973 | #-> sub CPAN::Shell::format_result ; | |
2974 | sub format_result { | |
2975 | my($self) = shift; | |
2976 | my($type,@args) = @_; | |
2977 | @args = '/./' unless @args; | |
2978 | my(@result) = $self->expand($type,@args); | |
8d97e4a1 | 2979 | my $result = @result == 1 ? |
f04ea8d1 | 2980 | $result[0]->as_string : |
8d97e4a1 JH |
2981 | @result == 0 ? |
2982 | "No objects of type $type found for argument @args\n" : | |
2983 | join("", | |
2984 | (map {$_->as_glimpse} @result), | |
2985 | scalar @result, " items found\n", | |
2986 | ); | |
05454584 A |
2987 | $result; |
2988 | } | |
2989 | ||
554a9ef5 SP |
2990 | #-> sub CPAN::Shell::report_fh ; |
2991 | { | |
2992 | my $installation_report_fh; | |
2993 | my $previously_noticed = 0; | |
2994 | ||
2995 | sub report_fh { | |
2996 | return $installation_report_fh if $installation_report_fh; | |
b03f445c | 2997 | if ($CPAN::META->has_usable("File::Temp")) { |
4d1321a7 A |
2998 | $installation_report_fh |
2999 | = File::Temp->new( | |
917f1700 | 3000 | dir => File::Spec->tmpdir, |
4d1321a7 A |
3001 | template => 'cpan_install_XXXX', |
3002 | suffix => '.txt', | |
3003 | unlink => 0, | |
3004 | ); | |
3005 | } | |
554a9ef5 SP |
3006 | unless ( $installation_report_fh ) { |
3007 | warn("Couldn't open installation report file; " . | |
3008 | "no report file will be generated." | |
3009 | ) unless $previously_noticed++; | |
3010 | } | |
3011 | } | |
3012 | } | |
3013 | ||
3014 | ||
c356248b A |
3015 | # The only reason for this method is currently to have a reliable |
3016 | # debugging utility that reveals which output is going through which | |
3017 | # channel. No, I don't like the colors ;-) | |
8d97e4a1 | 3018 | |
8962fc49 SP |
3019 | # to turn colordebugging on, write |
3020 | # cpan> o conf colorize_output 1 | |
3021 | ||
3022 | #-> sub CPAN::Shell::print_ornamented ; | |
3023 | { | |
3024 | my $print_ornamented_have_warned = 0; | |
3025 | sub colorize_output { | |
3026 | my $colorize_output = $CPAN::Config->{colorize_output}; | |
3027 | if ($colorize_output && !$CPAN::META->has_inst("Term::ANSIColor")) { | |
3028 | unless ($print_ornamented_have_warned++) { | |
3029 | # no myprint/mywarn within myprint/mywarn! | |
3030 | warn "Colorize_output is set to true but Term::ANSIColor is not | |
3031 | installed. To activate colorized output, please install Term::ANSIColor.\n\n"; | |
3032 | } | |
3033 | $colorize_output = 0; | |
3034 | } | |
3035 | return $colorize_output; | |
3036 | } | |
3037 | } | |
3038 | ||
3039 | ||
05bab18e | 3040 | #-> sub CPAN::Shell::print_ornamented ; |
c356248b A |
3041 | sub print_ornamented { |
3042 | my($self,$what,$ornament) = @_; | |
8d97e4a1 | 3043 | return unless defined $what; |
c356248b | 3044 | |
554a9ef5 SP |
3045 | local $| = 1; # Flush immediately |
3046 | if ( $CPAN::Be_Silent ) { | |
3047 | print {report_fh()} $what; | |
3048 | return; | |
3049 | } | |
8962fc49 | 3050 | my $swhat = "$what"; # stringify if it is an object |
f04ea8d1 SP |
3051 | if ($CPAN::Config->{term_is_latin}) { |
3052 | # note: deprecated, need to switch to $LANG and $LC_* | |
8d97e4a1 | 3053 | # courtesy jhi: |
8962fc49 | 3054 | $swhat |
8d97e4a1 JH |
3055 | =~ s{([\xC0-\xDF])([\x80-\xBF])}{chr(ord($1)<<6&0xC0|ord($2)&0x3F)}eg; #}; |
3056 | } | |
8962fc49 | 3057 | if ($self->colorize_output) { |
135a59c2 A |
3058 | if ( $CPAN::DEBUG && $swhat =~ /^Debug\(/ ) { |
3059 | # if you want to have this configurable, please file a bugreport | |
b72dd56f | 3060 | $ornament = $CPAN::Config->{colorize_debug} || "black on_cyan"; |
135a59c2 | 3061 | } |
8962fc49 SP |
3062 | my $color_on = eval { Term::ANSIColor::color($ornament) } || ""; |
3063 | if ($@) { | |
3064 | print "Term::ANSIColor rejects color[$ornament]: $@\n | |
f20de9f0 | 3065 | Please choose a different color (Hint: try 'o conf init /color/')\n"; |
8962fc49 | 3066 | } |
f04ea8d1 SP |
3067 | # GGOLDBACH/Test-GreaterVersion-0.008 broke wthout this |
3068 | # $trailer construct. We want the newline be the last thing if | |
3069 | # there is a newline at the end ensuring that the next line is | |
3070 | # empty for other players | |
3071 | my $trailer = ""; | |
3072 | $trailer = $1 if $swhat =~ s/([\r\n]+)\z//; | |
135a59c2 A |
3073 | print $color_on, |
3074 | $swhat, | |
f04ea8d1 SP |
3075 | Term::ANSIColor::color("reset"), |
3076 | $trailer; | |
c356248b | 3077 | } else { |
8962fc49 | 3078 | print $swhat; |
c356248b A |
3079 | } |
3080 | } | |
3081 | ||
05bab18e SP |
3082 | #-> sub CPAN::Shell::myprint ; |
3083 | ||
f04ea8d1 SP |
3084 | # where is myprint/mywarn/Frontend/etc. documented? Where to use what? |
3085 | # I think, we send everything to STDOUT and use print for normal/good | |
3086 | # news and warn for news that need more attention. Yes, this is our | |
3087 | # working contract for now. | |
c356248b A |
3088 | sub myprint { |
3089 | my($self,$what) = @_; | |
f04ea8d1 SP |
3090 | $self->print_ornamented($what, |
3091 | $CPAN::Config->{colorize_print}||'bold blue on_white', | |
3092 | ); | |
3093 | } | |
8d97e4a1 | 3094 | |
f04ea8d1 SP |
3095 | sub optprint { |
3096 | my($self,$category,$what) = @_; | |
3097 | my $vname = $category . "_verbosity"; | |
3098 | CPAN::HandleConfig->load unless $CPAN::Config_loaded++; | |
3099 | if (!$CPAN::Config->{$vname} | |
3100 | || $CPAN::Config->{$vname} =~ /^v/ | |
3101 | ) { | |
3102 | $CPAN::Frontend->myprint($what); | |
3103 | } | |
c356248b A |
3104 | } |
3105 | ||
05bab18e | 3106 | #-> sub CPAN::Shell::myexit ; |
c356248b A |
3107 | sub myexit { |
3108 | my($self,$what) = @_; | |
3109 | $self->myprint($what); | |
3110 | exit; | |
3111 | } | |
3112 | ||
05bab18e | 3113 | #-> sub CPAN::Shell::mywarn ; |
c356248b A |
3114 | sub mywarn { |
3115 | my($self,$what) = @_; | |
2ccf00a7 | 3116 | $self->print_ornamented($what, $CPAN::Config->{colorize_warn}||'bold red on_white'); |
c356248b A |
3117 | } |
3118 | ||
b96578bb | 3119 | # only to be used for shell commands |
05bab18e | 3120 | #-> sub CPAN::Shell::mydie ; |
c356248b A |
3121 | sub mydie { |
3122 | my($self,$what) = @_; | |
dc053c64 | 3123 | $self->mywarn($what); |
b96578bb | 3124 | |
dc053c64 | 3125 | # If it is the shell, we want the following die to be silent, |
b96578bb SP |
3126 | # but if it is not the shell, we would need a 'die $what'. We need |
3127 | # to take care that only shell commands use mydie. Is this | |
3128 | # possible? | |
3129 | ||
c356248b A |
3130 | die "\n"; |
3131 | } | |
3132 | ||
05bab18e | 3133 | # sub CPAN::Shell::colorable_makemaker_prompt ; |
8962fc49 SP |
3134 | sub colorable_makemaker_prompt { |
3135 | my($foo,$bar) = @_; | |
3136 | if (CPAN::Shell->colorize_output) { | |
2ccf00a7 | 3137 | my $ornament = $CPAN::Config->{colorize_print}||'bold blue on_white'; |
8962fc49 SP |
3138 | my $color_on = eval { Term::ANSIColor::color($ornament); } || ""; |
3139 | print $color_on; | |
3140 | } | |
3141 | my $ans = ExtUtils::MakeMaker::prompt($foo,$bar); | |
3142 | if (CPAN::Shell->colorize_output) { | |
3143 | print Term::ANSIColor::color('reset'); | |
3144 | } | |
3145 | return $ans; | |
3146 | } | |
3147 | ||
c9869e1c | 3148 | # use this only for unrecoverable errors! |
05bab18e | 3149 | #-> sub CPAN::Shell::unrecoverable_error ; |
c9869e1c SP |
3150 | sub unrecoverable_error { |
3151 | my($self,$what) = @_; | |
3152 | my @lines = split /\n/, $what; | |
3153 | my $longest = 0; | |
3154 | for my $l (@lines) { | |
3155 | $longest = length $l if length $l > $longest; | |
3156 | } | |
3157 | $longest = 62 if $longest > 62; | |
3158 | for my $l (@lines) { | |
f04ea8d1 | 3159 | if ($l =~ /^\s*$/) { |
c9869e1c SP |
3160 | $l = "\n"; |
3161 | next; | |
3162 | } | |
3163 | $l = "==> $l"; | |
3164 | if (length $l < 66) { | |
3165 | $l = pack "A66 A*", $l, "<=="; | |
3166 | } | |
3167 | $l .= "\n"; | |
3168 | } | |
3169 | unshift @lines, "\n"; | |
3170 | $self->mydie(join "", @lines); | |
c9869e1c SP |
3171 | } |
3172 | ||
05bab18e | 3173 | #-> sub CPAN::Shell::mysleep ; |
9ddc4ed0 A |
3174 | sub mysleep { |
3175 | my($self, $sleep) = @_; | |
dc053c64 SP |
3176 | if (CPAN->has_inst("Time::HiRes")) { |
3177 | Time::HiRes::sleep($sleep); | |
3178 | } else { | |
3179 | sleep($sleep < 1 ? 1 : int($sleep + 0.5)); | |
3180 | } | |
9ddc4ed0 A |
3181 | } |
3182 | ||
05bab18e | 3183 | #-> sub CPAN::Shell::setup_output ; |
911a92db GS |
3184 | sub setup_output { |
3185 | return if -t STDOUT; | |
3186 | my $odef = select STDERR; | |
3187 | $| = 1; | |
3188 | select STDOUT; | |
3189 | $| = 1; | |
3190 | select $odef; | |
3191 | } | |
3192 | ||
05454584 | 3193 | #-> sub CPAN::Shell::rematein ; |
810a0276 | 3194 | # RE-adme||MA-ke||TE-st||IN-stall : nearly everything runs through here |
05454584 | 3195 | sub rematein { |
0cf35e6a | 3196 | my $self = shift; |
05454584 | 3197 | my($meth,@some) = @_; |
554a9ef5 | 3198 | my @pragma; |
b72dd56f | 3199 | while($meth =~ /^(ff?orce|notest)$/) { |
f04ea8d1 SP |
3200 | push @pragma, $meth; |
3201 | $meth = shift @some or | |
0cf35e6a SP |
3202 | $CPAN::Frontend->mydie("Pragma $pragma[-1] used without method: ". |
3203 | "cannot continue"); | |
05454584 | 3204 | } |
911a92db | 3205 | setup_output(); |
554a9ef5 | 3206 | CPAN->debug("pragma[@pragma]meth[$meth]some[@some]") if $CPAN::DEBUG; |
6d29edf5 JH |
3207 | |
3208 | # Here is the place to set "test_count" on all involved parties to | |
3209 | # 0. We then can pass this counter on to the involved | |
3210 | # distributions and those can refuse to test if test_count > X. In | |
3211 | # the first stab at it we could use a 1 for "X". | |
3212 | ||
3213 | # But when do I reset the distributions to start with 0 again? | |
3214 | # Jost suggested to have a random or cycling interaction ID that | |
3215 | # we pass through. But the ID is something that is just left lying | |
3216 | # around in addition to the counter, so I'd prefer to set the | |
3217 | # counter to 0 now, and repeat at the end of the loop. But what | |
3218 | # about dependencies? They appear later and are not reset, they | |
3219 | # enter the queue but not its copy. How do they get a sensible | |
3220 | # test_count? | |
3221 | ||
f04ea8d1 SP |
3222 | # With configure_requires, "get" is vulnerable in recursion. |
3223 | ||
3224 | my $needs_recursion_protection = "get|make|test|install"; | |
f20de9f0 | 3225 | |
6d29edf5 JH |
3226 | # construct the queue |
3227 | my($s,@s,@qcopy); | |
0cf35e6a | 3228 | STHING: foreach $s (@some) { |
f04ea8d1 SP |
3229 | my $obj; |
3230 | if (ref $s) { | |
6d29edf5 | 3231 | CPAN->debug("s is an object[$s]") if $CPAN::DEBUG; |
f04ea8d1 SP |
3232 | $obj = $s; |
3233 | } elsif ($s =~ m|[\$\@\%]|) { # looks like a perl variable | |
3234 | } elsif ($s =~ m|^/|) { # looks like a regexp | |
8fc516fe SP |
3235 | if (substr($s,-1,1) eq ".") { |
3236 | $obj = CPAN::Shell->expandany($s); | |
3237 | } else { | |
3238 | $CPAN::Frontend->mywarn("Sorry, $meth with a regular expression is ". | |
3239 | "not supported.\nRejecting argument '$s'\n"); | |
3240 | $CPAN::Frontend->mysleep(2); | |
3241 | next; | |
3242 | } | |
f04ea8d1 | 3243 | } elsif ($meth eq "ls") { |
ca79d794 | 3244 | $self->globls($s,\@pragma); |
0cf35e6a SP |
3245 | next STHING; |
3246 | } else { | |
6d29edf5 | 3247 | CPAN->debug("calling expandany [$s]") if $CPAN::DEBUG; |
f04ea8d1 SP |
3248 | $obj = CPAN::Shell->expandany($s); |
3249 | } | |
3250 | if (0) { | |
7d97ad34 | 3251 | } elsif (ref $obj) { |
f20de9f0 | 3252 | if ($meth =~ /^($needs_recursion_protection)$/) { |
ade94d80 SP |
3253 | # it would be silly to check for recursion for look or dump |
3254 | # (we are in CPAN::Shell::rematein) | |
3255 | CPAN->debug("Going to test against recursion") if $CPAN::DEBUG; | |
3256 | eval { $obj->color_cmd_tmps(0,1); }; | |
f04ea8d1 | 3257 | if ($@) { |
ade94d80 SP |
3258 | if (ref $@ |
3259 | and $@->isa("CPAN::Exception::RecursiveDependency")) { | |
3260 | $CPAN::Frontend->mywarn($@); | |
3261 | } else { | |
3262 | if (0) { | |
3263 | require Carp; | |
3264 | Carp::confess(sprintf "DEBUG: \$\@[%s]ref[%s]", $@, ref $@); | |
3265 | } | |
3266 | die; | |
3267 | } | |
3268 | } | |
f20de9f0 | 3269 | } |
f04ea8d1 | 3270 | CPAN::Queue->queue_item(qmod => $obj->id, reqtype => "c"); |
6d29edf5 | 3271 | push @qcopy, $obj; |
f04ea8d1 SP |
3272 | } elsif ($CPAN::META->exists('CPAN::Author',uc($s))) { |
3273 | $obj = $CPAN::META->instance('CPAN::Author',uc($s)); | |
dc053c64 | 3274 | if ($meth =~ /^(dump|ls|reports)$/) { |
5fc0f0f6 | 3275 | $obj->$meth(); |
8d97e4a1 | 3276 | } else { |
8962fc49 SP |
3277 | $CPAN::Frontend->mywarn( |
3278 | join "", | |
3279 | "Don't be silly, you can't $meth ", | |
3280 | $obj->fullname, | |
3281 | " ;-)\n" | |
3282 | ); | |
3283 | $CPAN::Frontend->mysleep(2); | |
8d97e4a1 | 3284 | } |
f04ea8d1 | 3285 | } elsif ($s =~ m|[\$\@\%]| && $meth eq "dump") { |
135a59c2 A |
3286 | CPAN::InfoObj->dump($s); |
3287 | } else { | |
f04ea8d1 SP |
3288 | $CPAN::Frontend |
3289 | ->mywarn(qq{Warning: Cannot $meth $s, }. | |
3290 | qq{don't know what it is. | |
e50380aa A |
3291 | Try the command |
3292 | ||
3293 | i /$s/ | |
3294 | ||
6d29edf5 | 3295 | to find objects with matching identifiers. |
c356248b | 3296 | }); |
8962fc49 | 3297 | $CPAN::Frontend->mysleep(2); |
f04ea8d1 | 3298 | } |
6d29edf5 JH |
3299 | } |
3300 | ||
3301 | # queuerunner (please be warned: when I started to change the | |
3302 | # queue to hold objects instead of names, I made one or two | |
3303 | # mistakes and never found which. I reverted back instead) | |
135a59c2 | 3304 | while (my $q = CPAN::Queue->first) { |
6d29edf5 | 3305 | my $obj; |
135a59c2 A |
3306 | my $s = $q->as_string; |
3307 | my $reqtype = $q->reqtype || ""; | |
3308 | $obj = CPAN::Shell->expandany($s); | |
f20de9f0 SP |
3309 | unless ($obj) { |
3310 | # don't know how this can happen, maybe we should panic, | |
3311 | # but maybe we get a solution from the first user who hits | |
3312 | # this unfortunate exception? | |
3313 | $CPAN::Frontend->mywarn("Warning: Could not expand string '$s' ". | |
2b3bde2a | 3314 | "to an object. Skipping.\n"); |
f20de9f0 | 3315 | $CPAN::Frontend->mysleep(5); |
2b3bde2a | 3316 | CPAN::Queue->delete_first($s); |
f20de9f0 SP |
3317 | next; |
3318 | } | |
135a59c2 | 3319 | $obj->{reqtype} ||= ""; |
810a0276 SP |
3320 | { |
3321 | # force debugging because CPAN::SQLite somehow delivers us | |
3322 | # an empty object; | |
3323 | ||
3324 | # local $CPAN::DEBUG = 1024; # Shell; probably fixed now | |
3325 | ||
3326 | CPAN->debug("s[$s]obj-reqtype[$obj->{reqtype}]". | |
3327 | "q-reqtype[$reqtype]") if $CPAN::DEBUG; | |
3328 | } | |
135a59c2 A |
3329 | if ($obj->{reqtype}) { |
3330 | if ($obj->{reqtype} eq "b" && $reqtype =~ /^[rc]$/) { | |
3331 | $obj->{reqtype} = $reqtype; | |
3332 | if ( | |
3333 | exists $obj->{install} | |
3334 | && | |
3335 | ( | |
be34b10d | 3336 | UNIVERSAL::can($obj->{install},"failed") ? |
135a59c2 A |
3337 | $obj->{install}->failed : |
3338 | $obj->{install} =~ /^NO/ | |
3339 | ) | |
3340 | ) { | |
3341 | delete $obj->{install}; | |
3342 | $CPAN::Frontend->mywarn | |
3343 | ("Promoting $obj->{ID} from 'build_requires' to 'requires'"); | |
3344 | } | |
3345 | } | |
3346 | } else { | |
3347 | $obj->{reqtype} = $reqtype; | |
3348 | } | |
3349 | ||
f04ea8d1 SP |
3350 | for my $pragma (@pragma) { |
3351 | if ($pragma | |
3352 | && | |
3353 | $obj->can($pragma)) { | |
3354 | $obj->$pragma($meth); | |
3355 | } | |
6d29edf5 | 3356 | } |
810a0276 | 3357 | if (UNIVERSAL::can($obj, 'called_for')) { |
6d29edf5 JH |
3358 | $obj->called_for($s); |
3359 | } | |
135a59c2 A |
3360 | CPAN->debug(qq{pragma[@pragma]meth[$meth]}. |
3361 | qq{ID[$obj->{ID}]}) if $CPAN::DEBUG; | |
6d29edf5 | 3362 | |
6a935156 | 3363 | push @qcopy, $obj; |
f04ea8d1 SP |
3364 | if ($meth =~ /^(report)$/) { # they came here with a pragma? |
3365 | $self->$meth($obj); | |
3366 | } elsif (! UNIVERSAL::can($obj,$meth)) { | |
810a0276 SP |
3367 | # Must never happen |
3368 | my $serialized = ""; | |
3369 | if (0) { | |
3370 | } elsif ($CPAN::META->has_inst("YAML::Syck")) { | |
3371 | $serialized = YAML::Syck::Dump($obj); | |
3372 | } elsif ($CPAN::META->has_inst("YAML")) { | |
3373 | $serialized = YAML::Dump($obj); | |
3374 | } elsif ($CPAN::META->has_inst("Data::Dumper")) { | |
3375 | $serialized = Data::Dumper::Dumper($obj); | |
3376 | } else { | |
3377 | require overload; | |
3378 | $serialized = overload::StrVal($obj); | |
3379 | } | |
23a216b4 | 3380 | CPAN->debug("Going to panic. meth[$meth]s[$s]") if $CPAN::DEBUG; |
810a0276 | 3381 | $CPAN::Frontend->mydie("Panic: obj[$serialized] cannot meth[$meth]"); |
f04ea8d1 | 3382 | } elsif ($obj->$meth()) { |
6d29edf5 | 3383 | CPAN::Queue->delete($s); |
23a216b4 | 3384 | CPAN->debug("From queue deleted. meth[$meth]s[$s]") if $CPAN::DEBUG; |
6d29edf5 | 3385 | } else { |
23a216b4 | 3386 | CPAN->debug("Failed. pragma[@pragma]meth[$meth]") if $CPAN::DEBUG; |
6d29edf5 JH |
3387 | } |
3388 | ||
3389 | $obj->undelay; | |
f04ea8d1 | 3390 | for my $pragma (@pragma) { |
05bab18e | 3391 | my $unpragma = "un$pragma"; |
f04ea8d1 SP |
3392 | if ($obj->can($unpragma)) { |
3393 | $obj->$unpragma(); | |
3394 | } | |
05bab18e | 3395 | } |
f04ea8d1 | 3396 | CPAN::Queue->delete_first($s); |
05454584 | 3397 | } |
f20de9f0 SP |
3398 | if ($meth =~ /^($needs_recursion_protection)$/) { |
3399 | for my $obj (@qcopy) { | |
3400 | $obj->color_cmd_tmps(0,0); | |
3401 | } | |
6d29edf5 | 3402 | } |
05454584 A |
3403 | } |
3404 | ||
554a9ef5 SP |
3405 | #-> sub CPAN::Shell::recent ; |
3406 | sub recent { | |
f3fe0ae6 | 3407 | my($self) = @_; |
f04ea8d1 SP |
3408 | if ($CPAN::META->has_inst("XML::LibXML")) { |
3409 | my $url = $CPAN::Defaultrecent; | |
3410 | $CPAN::Frontend->myprint("Going to fetch '$url'\n"); | |
3411 | unless ($CPAN::META->has_usable("LWP")) { | |
3412 | $CPAN::Frontend->mydie("LWP not installed; cannot continue"); | |
3413 | } | |
3414 | CPAN::LWP::UserAgent->config; | |
3415 | my $Ua; | |
3416 | eval { $Ua = CPAN::LWP::UserAgent->new; }; | |
3417 | if ($@) { | |
3418 | $CPAN::Frontend->mydie("CPAN::LWP::UserAgent->new dies with $@\n"); | |
3419 | } | |
3420 | my $resp = $Ua->get($url); | |
3421 | unless ($resp->is_success) { | |
3422 | $CPAN::Frontend->mydie(sprintf "Could not download '%s': %s\n", $url, $resp->code); | |
3423 | } | |
3424 | $CPAN::Frontend->myprint("DONE\n\n"); | |
3425 | my $xml = XML::LibXML->new->parse_string($resp->content); | |
3426 | if (0) { | |
3427 | my $s = $xml->serialize(2); | |
3428 | $s =~ s/\n\s*\n/\n/g; | |
3429 | $CPAN::Frontend->myprint($s); | |
3430 | return; | |
3431 | } | |
3432 | my @distros; | |
3433 | if ($url =~ /winnipeg/) { | |
3434 | my $pubdate = $xml->findvalue("/rss/channel/pubDate"); | |
3435 | $CPAN::Frontend->myprint(" pubDate: $pubdate\n\n"); | |
3436 | for my $eitem ($xml->findnodes("/rss/channel/item")) { | |
3437 | my $distro = $eitem->findvalue("enclosure/\@url"); | |
3438 | $distro =~ s|.*?/authors/id/./../||; | |
3439 | my $size = $eitem->findvalue("enclosure/\@length"); | |
3440 | my $desc = $eitem->findvalue("description"); | |
3441 | \0 $desc =~ s/.+? - //; | |
3442 | $CPAN::Frontend->myprint("$distro [$size b]\n $desc\n"); | |
3443 | push @distros, $distro; | |
3444 | } | |
3445 | } elsif ($url =~ /search.*uploads.rdf/) { | |
3446 | # xmlns:rdf="http://www.w3.org/1999/02/22-rdf-syntax-ns#" | |
3447 | # xmlns="http://purl.org/rss/1.0/" | |
3448 | # xmlns:taxo="http://purl.org/rss/1.0/modules/taxonomy/" | |
3449 | # xmlns:dc="http://purl.org/dc/elements/1.1/" | |
3450 | # xmlns:syn="http://purl.org/rss/1.0/modules/syndication/" | |
3451 | # xmlns:admin="http://webns.net/mvcb/" | |
3452 | ||
3453 | ||
3454 | my $dc_date = $xml->findvalue("//*[local-name(.) = 'RDF']/*[local-name(.) = 'channel']/*[local-name(.) = 'date']"); | |
3455 | $CPAN::Frontend->myprint(" dc:date: $dc_date\n\n"); | |
3456 | my $finish_eitem = 0; | |
3457 | local $SIG{INT} = sub { $finish_eitem = 1 }; | |
3458 | EITEM: for my $eitem ($xml->findnodes("//*[local-name(.) = 'RDF']/*[local-name(.) = 'item']")) { | |
3459 | my $distro = $eitem->findvalue("\@rdf:about"); | |
3460 | $distro =~ s|.*~||; # remove up to the tilde before the name | |
3461 | $distro =~ s|/$||; # remove trailing slash | |
3462 | $distro =~ s|([^/]+)|\U$1\E|; # upcase the name | |
3463 | my $author = uc $1 or die "distro[$distro] without author, cannot continue"; | |
3464 | my $desc = $eitem->findvalue("*[local-name(.) = 'description']"); | |
3465 | my $i = 0; | |
3466 | SUBDIRTEST: while () { | |
3467 | last SUBDIRTEST if ++$i >= 6; # half a dozen must do! | |
3468 | if (my @ret = $self->globls("$distro*")) { | |
3469 | @ret = grep {$_->[2] !~ /meta/} @ret; | |
3470 | @ret = grep {length $_->[2]} @ret; | |
3471 | if (@ret) { | |
3472 | $distro = "$author/$ret[0][2]"; | |
3473 | last SUBDIRTEST; | |
3474 | } | |
3475 | } | |
3476 | $distro =~ s|/|/*/|; # allow it to reside in a subdirectory | |
3477 | } | |
3478 | ||
3479 | next EITEM if $distro =~ m|\*|; # did not find the thing | |
3480 | $CPAN::Frontend->myprint("____$desc\n"); | |
3481 | push @distros, $distro; | |
3482 | last EITEM if $finish_eitem; | |
3483 | } | |
3484 | } | |
3485 | return \@distros; | |
3486 | } else { | |
3487 | # deprecated old version | |
3488 | $CPAN::Frontend->mydie("no XML::LibXML installed, cannot continue\n"); | |
3489 | } | |
3490 | } | |
554a9ef5 | 3491 | |
f04ea8d1 SP |
3492 | #-> sub CPAN::Shell::smoke ; |
3493 | sub smoke { | |
3494 | my($self) = @_; | |
3495 | my $distros = $self->recent; | |
3496 | DISTRO: for my $distro (@$distros) { | |
3497 | $CPAN::Frontend->myprint(sprintf "Going to download and test '$distro'\n"); | |
3498 | { | |
3499 | my $skip = 0; | |
3500 | local $SIG{INT} = sub { $skip = 1 }; | |
3501 | for (0..9) { | |
3502 | $CPAN::Frontend->myprint(sprintf "\r%2d (Hit ^C to skip)", 10-$_); | |
3503 | sleep 1; | |
3504 | if ($skip) { | |
3505 | $CPAN::Frontend->myprint(" skipped\n"); | |
3506 | next DISTRO; | |
3507 | } | |
3508 | } | |
3509 | } | |
3510 | $CPAN::Frontend->myprint("\r \n"); # leave the dirty line with a newline | |
3511 | $self->test($distro); | |
3512 | } | |
554a9ef5 SP |
3513 | } |
3514 | ||
3515 | { | |
3516 | # set up the dispatching methods | |
3517 | no strict "refs"; | |
3518 | for my $command (qw( | |
0cf35e6a SP |
3519 | clean |
3520 | cvs_import | |
3521 | dump | |
3522 | force | |
b72dd56f | 3523 | fforce |
0cf35e6a SP |
3524 | get |
3525 | install | |
3526 | look | |
3527 | ls | |
3528 | make | |
3529 | notest | |
3530 | perldoc | |
3531 | readme | |
dc053c64 | 3532 | reports |
0cf35e6a | 3533 | test |
554a9ef5 SP |
3534 | )) { |
3535 | *$command = sub { shift->rematein($command, @_); }; | |
3536 | } | |
3537 | } | |
05454584 | 3538 | |
c049f953 | 3539 | package CPAN::LWP::UserAgent; |
e82b9348 | 3540 | use strict; |
c049f953 JH |
3541 | |
3542 | sub config { | |
3543 | return if $SETUPDONE; | |
3544 | if ($CPAN::META->has_usable('LWP::UserAgent')) { | |
3545 | require LWP::UserAgent; | |
3546 | @ISA = qw(Exporter LWP::UserAgent); | |
3547 | $SETUPDONE++; | |
3548 | } else { | |
8962fc49 | 3549 | $CPAN::Frontend->mywarn(" LWP::UserAgent not available\n"); |
c049f953 JH |
3550 | } |
3551 | } | |
3552 | ||
3553 | sub get_basic_credentials { | |
3554 | my($self, $realm, $uri, $proxy) = @_; | |
c049f953 | 3555 | if ($USER && $PASSWD) { |
ed84aac9 A |
3556 | return ($USER, $PASSWD); |
3557 | } | |
3558 | if ( $proxy ) { | |
3559 | ($USER,$PASSWD) = $self->get_proxy_credentials(); | |
c049f953 | 3560 | } else { |
ed84aac9 A |
3561 | ($USER,$PASSWD) = $self->get_non_proxy_credentials(); |
3562 | } | |
3563 | return($USER,$PASSWD); | |
3564 | } | |
3565 | ||
3566 | sub get_proxy_credentials { | |
3567 | my $self = shift; | |
3568 | my ($user, $password); | |
3569 | if ( defined $CPAN::Config->{proxy_user} && | |
3570 | defined $CPAN::Config->{proxy_pass}) { | |
3571 | $user = $CPAN::Config->{proxy_user}; | |
3572 | $password = $CPAN::Config->{proxy_pass}; | |
3573 | return ($user, $password); | |
3574 | } | |
3575 | my $username_prompt = "\nProxy authentication needed! | |
c049f953 JH |
3576 | (Note: to permanently configure username and password run |
3577 | o conf proxy_user your_username | |
3578 | o conf proxy_pass your_password | |
ed84aac9 A |
3579 | )\nUsername:"; |
3580 | ($user, $password) = | |
3581 | _get_username_and_password_from_user($username_prompt); | |
3582 | return ($user,$password); | |
3583 | } | |
3584 | ||
3585 | sub get_non_proxy_credentials { | |
3586 | my $self = shift; | |
3587 | my ($user,$password); | |
3588 | if ( defined $CPAN::Config->{username} && | |
3589 | defined $CPAN::Config->{password}) { | |
3590 | $user = $CPAN::Config->{username}; | |
3591 | $password = $CPAN::Config->{password}; | |
3592 | return ($user, $password); | |
3593 | } | |
3594 | my $username_prompt = "\nAuthentication needed! | |
3595 | (Note: to permanently configure username and password run | |
3596 | o conf username your_username | |
3597 | o conf password your_password | |
3598 | )\nUsername:"; | |
8962fc49 | 3599 | |
ed84aac9 A |
3600 | ($user, $password) = |
3601 | _get_username_and_password_from_user($username_prompt); | |
3602 | return ($user,$password); | |
3603 | } | |
3604 | ||
3605 | sub _get_username_and_password_from_user { | |
ed84aac9 A |
3606 | my $username_message = shift; |
3607 | my ($username,$password); | |
3608 | ||
3609 | ExtUtils::MakeMaker->import(qw(prompt)); | |
3610 | $username = prompt($username_message); | |
c049f953 JH |
3611 | if ($CPAN::META->has_inst("Term::ReadKey")) { |
3612 | Term::ReadKey::ReadMode("noecho"); | |
c049f953 | 3613 | } |
ed84aac9 A |
3614 | else { |
3615 | $CPAN::Frontend->mywarn( | |
3616 | "Warning: Term::ReadKey seems not to be available, your password will be echoed to the terminal!\n" | |
3617 | ); | |
3618 | } | |
3619 | $password = prompt("Password:"); | |
3620 | ||
c049f953 JH |
3621 | if ($CPAN::META->has_inst("Term::ReadKey")) { |
3622 | Term::ReadKey::ReadMode("restore"); | |
3623 | } | |
3624 | $CPAN::Frontend->myprint("\n\n"); | |
ed84aac9 | 3625 | return ($username,$password); |
c049f953 JH |
3626 | } |
3627 | ||
1426a145 JH |
3628 | # mirror(): Its purpose is to deal with proxy authentication. When we |
3629 | # call SUPER::mirror, we relly call the mirror method in | |
3630 | # LWP::UserAgent. LWP::UserAgent will then call | |
3631 | # $self->get_basic_credentials or some equivalent and this will be | |
3632 | # $self->dispatched to our own get_basic_credentials method. | |
3633 | ||
3634 | # Our own get_basic_credentials sets $USER and $PASSWD, two globals. | |
3635 | ||
3636 | # 407 stands for HTTP_PROXY_AUTHENTICATION_REQUIRED. Which means | |
3637 | # although we have gone through our get_basic_credentials, the proxy | |
3638 | # server refuses to connect. This could be a case where the username or | |
3639 | # password has changed in the meantime, so I'm trying once again without | |
3640 | # $USER and $PASSWD to give the get_basic_credentials routine another | |
3641 | # chance to set $USER and $PASSWD. | |
3642 | ||
554a9ef5 SP |
3643 | # mirror(): Its purpose is to deal with proxy authentication. When we |
3644 | # call SUPER::mirror, we relly call the mirror method in | |
3645 | # LWP::UserAgent. LWP::UserAgent will then call | |
3646 | # $self->get_basic_credentials or some equivalent and this will be | |
3647 | # $self->dispatched to our own get_basic_credentials method. | |
3648 | ||
3649 | # Our own get_basic_credentials sets $USER and $PASSWD, two globals. | |
3650 | ||
3651 | # 407 stands for HTTP_PROXY_AUTHENTICATION_REQUIRED. Which means | |
3652 | # although we have gone through our get_basic_credentials, the proxy | |
3653 | # server refuses to connect. This could be a case where the username or | |
3654 | # password has changed in the meantime, so I'm trying once again without | |
3655 | # $USER and $PASSWD to give the get_basic_credentials routine another | |
3656 | # chance to set $USER and $PASSWD. | |
3657 | ||
c049f953 JH |
3658 | sub mirror { |
3659 | my($self,$url,$aslocal) = @_; | |
3660 | my $result = $self->SUPER::mirror($url,$aslocal); | |
3661 | if ($result->code == 407) { | |
3662 | undef $USER; | |
3663 | undef $PASSWD; | |
3664 | $result = $self->SUPER::mirror($url,$aslocal); | |
3665 | } | |
3666 | $result; | |
3667 | } | |
3668 | ||
05454584 | 3669 | package CPAN::FTP; |
e82b9348 | 3670 | use strict; |
05454584 | 3671 | |
05bab18e SP |
3672 | #-> sub CPAN::FTP::ftp_statistics |
3673 | # if they want to rewrite, they need to pass in a filehandle | |
3674 | sub _ftp_statistics { | |
3675 | my($self,$fh) = @_; | |
3676 | my $locktype = $fh ? LOCK_EX : LOCK_SH; | |
3677 | $fh ||= FileHandle->new; | |
3678 | my $file = File::Spec->catfile($CPAN::Config->{cpan_home},"FTPstats.yml"); | |
3679 | open $fh, "+>>$file" or $CPAN::Frontend->mydie("Could not open '$file': $!"); | |
3680 | my $sleep = 1; | |
810a0276 | 3681 | my $waitstart; |
f04ea8d1 | 3682 | while (!CPAN::_flock($fh, $locktype|LOCK_NB)) { |
810a0276 | 3683 | $waitstart ||= localtime(); |
05bab18e | 3684 | if ($sleep>3) { |
810a0276 | 3685 | $CPAN::Frontend->mywarn("Waiting for a read lock on '$file' (since $waitstart)\n"); |
be34b10d SP |
3686 | } |
3687 | $CPAN::Frontend->mysleep($sleep); | |
3688 | if ($sleep <= 3) { | |
3689 | $sleep+=0.33; | |
810a0276 SP |
3690 | } elsif ($sleep <=6) { |
3691 | $sleep+=0.11; | |
05bab18e | 3692 | } |
05bab18e | 3693 | } |
b72dd56f SP |
3694 | my $stats = eval { CPAN->_yaml_loadfile($file); }; |
3695 | if ($@) { | |
3696 | if (ref $@) { | |
3697 | if (ref $@ eq "CPAN::Exception::yaml_not_installed") { | |
3698 | $CPAN::Frontend->myprint("Warning (usually harmless): $@"); | |
3699 | return; | |
3700 | } elsif (ref $@ eq "CPAN::Exception::yaml_process_error") { | |
3701 | $CPAN::Frontend->mydie($@); | |
3702 | } | |
3703 | } else { | |
3704 | $CPAN::Frontend->mydie($@); | |
3705 | } | |
3706 | } | |
05bab18e SP |
3707 | return $stats->[0]; |
3708 | } | |
3709 | ||
810a0276 | 3710 | #-> sub CPAN::FTP::_mytime |
05bab18e SP |
3711 | sub _mytime () { |
3712 | if (CPAN->has_inst("Time::HiRes")) { | |
3713 | return Time::HiRes::time(); | |
3714 | } else { | |
3715 | return time; | |
3716 | } | |
3717 | } | |
3718 | ||
810a0276 | 3719 | #-> sub CPAN::FTP::_new_stats |
05bab18e SP |
3720 | sub _new_stats { |
3721 | my($self,$file) = @_; | |
3722 | my $ret = { | |
3723 | file => $file, | |
3724 | attempts => [], | |
3725 | start => _mytime, | |
3726 | }; | |
3727 | $ret; | |
3728 | } | |
3729 | ||
810a0276 | 3730 | #-> sub CPAN::FTP::_add_to_statistics |
05bab18e SP |
3731 | sub _add_to_statistics { |
3732 | my($self,$stats) = @_; | |
b72dd56f | 3733 | my $yaml_module = CPAN::_yaml_module; |
f20de9f0 | 3734 | $self->debug("yaml_module[$yaml_module]") if $CPAN::DEBUG; |
810a0276 SP |
3735 | if ($CPAN::META->has_inst($yaml_module)) { |
3736 | $stats->{thesiteurl} = $ThesiteURL; | |
3737 | if (CPAN->has_inst("Time::HiRes")) { | |
3738 | $stats->{end} = Time::HiRes::time(); | |
3739 | } else { | |
3740 | $stats->{end} = time; | |
3741 | } | |
3742 | my $fh = FileHandle->new; | |
b72dd56f SP |
3743 | my $time = time; |
3744 | my $sdebug = 0; | |
3745 | my @debug; | |
3746 | @debug = $time if $sdebug; | |
810a0276 | 3747 | my $fullstats = $self->_ftp_statistics($fh); |
b72dd56f | 3748 | close $fh; |
810a0276 | 3749 | $fullstats->{history} ||= []; |
b72dd56f SP |
3750 | push @debug, scalar @{$fullstats->{history}} if $sdebug; |
3751 | push @debug, time if $sdebug; | |
810a0276 | 3752 | push @{$fullstats->{history}}, $stats; |
b72dd56f | 3753 | # arbitrary hardcoded constants until somebody demands to have |
ed756621 SP |
3754 | # them settable; YAML.pm 0.62 is unacceptably slow with 999; |
3755 | # YAML::Syck 0.82 has no noticable performance problem with 999; | |
b72dd56f | 3756 | while ( |
ed756621 SP |
3757 | @{$fullstats->{history}} > 99 |
3758 | || $time - $fullstats->{history}[0]{start} > 14*86400 | |
b72dd56f SP |
3759 | ) { |
3760 | shift @{$fullstats->{history}} | |
3761 | } | |
3762 | push @debug, scalar @{$fullstats->{history}} if $sdebug; | |
3763 | push @debug, time if $sdebug; | |
3764 | push @debug, scalar localtime($fullstats->{history}[0]{start}) if $sdebug; | |
3765 | # need no eval because if this fails, it is serious | |
3766 | my $sfile = File::Spec->catfile($CPAN::Config->{cpan_home},"FTPstats.yml"); | |
3767 | CPAN->_yaml_dumpfile("$sfile.$$",$fullstats); | |
ade94d80 | 3768 | if ( $sdebug ) { |
b72dd56f SP |
3769 | local $CPAN::DEBUG = 512; # FTP |
3770 | push @debug, time; | |
3771 | CPAN->debug(sprintf("DEBUG history: before_read[%d]before[%d]at[%d]". | |
3772 | "after[%d]at[%d]oldest[%s]dumped backat[%d]", | |
810a0276 | 3773 | @debug, |
b72dd56f | 3774 | )); |
810a0276 | 3775 | } |
b72dd56f SP |
3776 | # Win32 cannot rename a file to an existing filename |
3777 | unlink($sfile) if ($^O eq 'MSWin32'); | |
3778 | rename "$sfile.$$", $sfile | |
3779 | or $CPAN::Frontend->mydie("Could not rename '$sfile.$$' to '$sfile': $!\n"); | |
05bab18e | 3780 | } |
05bab18e SP |
3781 | } |
3782 | ||
3783 | # if file is CHECKSUMS, suggest the place where we got the file to be | |
3784 | # checked from, maybe only for young files? | |
810a0276 | 3785 | #-> sub CPAN::FTP::_recommend_url_for |
05bab18e SP |
3786 | sub _recommend_url_for { |
3787 | my($self, $file) = @_; | |
3788 | my $urllist = $self->_get_urllist; | |
3789 | if ($file =~ s|/CHECKSUMS(.gz)?$||) { | |
3790 | my $fullstats = $self->_ftp_statistics(); | |
3791 | my $history = $fullstats->{history} || []; | |
3792 | while (my $last = pop @$history) { | |
3793 | last if $last->{end} - time > 3600; # only young results are interesting | |
be34b10d | 3794 | next unless $last->{file}; # dirname of nothing dies! |
05bab18e SP |
3795 | next unless $file eq File::Basename::dirname($last->{file}); |
3796 | return $last->{thesiteurl}; | |
3797 | } | |
3798 | } | |
3799 | if ($CPAN::Config->{randomize_urllist} | |
3800 | && | |
3801 | rand(1) < $CPAN::Config->{randomize_urllist} | |
3802 | ) { | |
3803 | $urllist->[int rand scalar @$urllist]; | |
3804 | } else { | |
3805 | return (); | |
3806 | } | |
3807 | } | |
3808 | ||
810a0276 | 3809 | #-> sub CPAN::FTP::_get_urllist |
05bab18e SP |
3810 | sub _get_urllist { |
3811 | my($self) = @_; | |
3812 | $CPAN::Config->{urllist} ||= []; | |
3813 | unless (ref $CPAN::Config->{urllist} eq 'ARRAY') { | |
3814 | $CPAN::Frontend->mywarn("Malformed urllist; ignoring. Configuration file corrupt?\n"); | |
3815 | $CPAN::Config->{urllist} = []; | |
3816 | } | |
3817 | my @urllist = grep { defined $_ and length $_ } @{$CPAN::Config->{urllist}}; | |
3818 | for my $u (@urllist) { | |
3819 | CPAN->debug("u[$u]") if $CPAN::DEBUG; | |
3820 | if (UNIVERSAL::can($u,"text")) { | |
3821 | $u->{TEXT} .= "/" unless substr($u->{TEXT},-1) eq "/"; | |
3822 | } else { | |
3823 | $u .= "/" unless substr($u,-1) eq "/"; | |
3824 | $u = CPAN::URL->new(TEXT => $u, FROM => "USER"); | |
3825 | } | |
3826 | } | |
3827 | \@urllist; | |
3828 | } | |
3829 | ||
05454584 A |
3830 | #-> sub CPAN::FTP::ftp_get ; |
3831 | sub ftp_get { | |
9ddc4ed0 A |
3832 | my($class,$host,$dir,$file,$target) = @_; |
3833 | $class->debug( | |
3834 | qq[Going to fetch file [$file] from dir [$dir] | |
05454584 | 3835 | on host [$host] as local [$target]\n] |
9ddc4ed0 A |
3836 | ) if $CPAN::DEBUG; |
3837 | my $ftp = Net::FTP->new($host); | |
3838 | unless ($ftp) { | |
3839 | $CPAN::Frontend->mywarn(" Could not connect to host '$host' with Net::FTP\n"); | |
3840 | return; | |
3841 | } | |
3842 | return 0 unless defined $ftp; | |
3843 | $ftp->debug(1) if $CPAN::DEBUG{'FTP'} & $CPAN::DEBUG; | |
3844 | $class->debug(qq[Going to login("anonymous","$Config::Config{cf_email}")]); | |
f04ea8d1 | 3845 | unless ( $ftp->login("anonymous",$Config::Config{'cf_email'}) ) { |
9ddc4ed0 A |
3846 | my $msg = $ftp->message; |
3847 | $CPAN::Frontend->mywarn(" Couldn't login on $host: $msg"); | |
3848 | return; | |
3849 | } | |
f04ea8d1 | 3850 | unless ( $ftp->cwd($dir) ) { |
9ddc4ed0 A |
3851 | my $msg = $ftp->message; |
3852 | $CPAN::Frontend->mywarn(" Couldn't cwd $dir: $msg"); | |
3853 | return; | |
3854 | } | |
3855 | $ftp->binary; | |
3856 | $class->debug(qq[Going to ->get("$file","$target")\n]) if $CPAN::DEBUG; | |
f04ea8d1 | 3857 | unless ( $ftp->get($file,$target) ) { |
9ddc4ed0 A |
3858 | my $msg = $ftp->message; |
3859 | $CPAN::Frontend->mywarn(" Couldn't fetch $file from $host: $msg"); | |
3860 | return; | |
3861 | } | |
3862 | $ftp->quit; # it's ok if this fails | |
3863 | return 1; | |
05454584 A |
3864 | } |
3865 | ||
09d9d230 | 3866 | # If more accuracy is wanted/needed, Chris Leach sent me this patch... |
f610777f | 3867 | |
6d29edf5 JH |
3868 | # > *** /install/perl/live/lib/CPAN.pm- Wed Sep 24 13:08:48 1997 |
3869 | # > --- /tmp/cp Wed Sep 24 13:26:40 1997 | |
3870 | # > *************** | |
3871 | # > *** 1562,1567 **** | |
3872 | # > --- 1562,1580 ---- | |
3873 | # > return 1 if substr($url,0,4) eq "file"; | |
3874 | # > return 1 unless $url =~ m|://([^/]+)|; | |
3875 | # > my $host = $1; | |
3876 | # > + my $proxy = $CPAN::Config->{'http_proxy'} || $ENV{'http_proxy'}; | |
3877 | # > + if ($proxy) { | |
3878 | # > + $proxy =~ m|://([^/:]+)|; | |
3879 | # > + $proxy = $1; | |
3880 | # > + my $noproxy = $CPAN::Config->{'no_proxy'} || $ENV{'no_proxy'}; | |
3881 | # > + if ($noproxy) { | |
3882 | # > + if ($host !~ /$noproxy$/) { | |
3883 | # > + $host = $proxy; | |
3884 | # > + } | |
3885 | # > + } else { | |
3886 | # > + $host = $proxy; | |
3887 | # > + } | |
3888 | # > + } | |
3889 | # > require Net::Ping; | |
3890 | # > return 1 unless $Net::Ping::VERSION >= 2; | |
3891 | # > my $p; | |
09d9d230 A |
3892 | |
3893 | ||
05454584 A |
3894 | #-> sub CPAN::FTP::localize ; |
3895 | sub localize { | |
3896 | my($self,$file,$aslocal,$force) = @_; | |
3897 | $force ||= 0; | |
3898 | Carp::croak "Usage: ->localize(cpan_file,as_local_file[,$force])" | |
f04ea8d1 | 3899 | unless defined $aslocal; |
55e314ee | 3900 | $self->debug("file[$file] aslocal[$aslocal] force[$force]") |
f04ea8d1 | 3901 | if $CPAN::DEBUG; |
05454584 | 3902 | |
f14b5cec | 3903 | if ($^O eq 'MacOS') { |
6d29edf5 JH |
3904 | # Comment by AK on 2000-09-03: Uniq short filenames would be |
3905 | # available in CHECKSUMS file | |
f14b5cec JH |
3906 | my($name, $path) = File::Basename::fileparse($aslocal, ''); |
3907 | if (length($name) > 31) { | |
6d29edf5 JH |
3908 | $name =~ s/( |
3909 | \.( | |
3910 | readme(\.(gz|Z))? | | |
3911 | (tar\.)?(gz|Z) | | |
3912 | tgz | | |
3913 | zip | | |
3914 | pm\.(gz|Z) | |
3915 | ) | |
3916 | )$//x; | |
f14b5cec JH |
3917 | my $suf = $1; |
3918 | my $size = 31 - length($suf); | |
3919 | while (length($name) > $size) { | |
3920 | chop $name; | |
3921 | } | |
3922 | $name .= $suf; | |
3923 | $aslocal = File::Spec->catfile($path, $name); | |
3924 | } | |
3925 | } | |
3926 | ||
f04ea8d1 | 3927 | if (-f $aslocal && -r _ && !($force & 1)) { |
b96578bb SP |
3928 | my $size; |
3929 | if ($size = -s $aslocal) { | |
3930 | $self->debug("aslocal[$aslocal]size[$size]") if $CPAN::DEBUG; | |
3931 | return $aslocal; | |
3932 | } else { | |
3933 | # empty file from a previous unsuccessful attempt to download it | |
3934 | unlink $aslocal or | |
ed84aac9 A |
3935 | $CPAN::Frontend->mydie("Found a zero-length '$aslocal' that I ". |
3936 | "could not remove."); | |
b96578bb | 3937 | } |
0cf35e6a | 3938 | } |
05bab18e | 3939 | my($maybe_restore) = 0; |
f04ea8d1 SP |
3940 | if (-f $aslocal) { |
3941 | rename $aslocal, "$aslocal.bak$$"; | |
3942 | $maybe_restore++; | |
55e314ee | 3943 | } |
05454584 A |
3944 | |
3945 | my($aslocal_dir) = File::Basename::dirname($aslocal); | |
f04ea8d1 | 3946 | $self->mymkpath($aslocal_dir); # too early for file URLs / RT #28438 |
05454584 | 3947 | # Inheritance is not easier to manage than a few if/else branches |
de34a54b | 3948 | if ($CPAN::META->has_usable('LWP::UserAgent')) { |
f04ea8d1 | 3949 | unless ($Ua) { |
c049f953 | 3950 | CPAN::LWP::UserAgent->config; |
f04ea8d1 | 3951 | eval {$Ua = CPAN::LWP::UserAgent->new;}; # Why is has_usable still not fit enough? |
d8773709 | 3952 | if ($@) { |
5fc0f0f6 | 3953 | $CPAN::Frontend->mywarn("CPAN::LWP::UserAgent->new dies with $@\n") |
d8773709 JH |
3954 | if $CPAN::DEBUG; |
3955 | } else { | |
3956 | my($var); | |
3957 | $Ua->proxy('ftp', $var) | |
3958 | if $var = $CPAN::Config->{ftp_proxy} || $ENV{ftp_proxy}; | |
3959 | $Ua->proxy('http', $var) | |
3960 | if $var = $CPAN::Config->{http_proxy} || $ENV{http_proxy}; | |
3961 | $Ua->no_proxy($var) | |
3962 | if $var = $CPAN::Config->{no_proxy} || $ENV{no_proxy}; | |
3963 | } | |
f04ea8d1 | 3964 | } |
05454584 | 3965 | } |
35576f8c A |
3966 | for my $prx (qw(ftp_proxy http_proxy no_proxy)) { |
3967 | $ENV{$prx} = $CPAN::Config->{$prx} if $CPAN::Config->{$prx}; | |
3968 | } | |
05454584 A |
3969 | |
3970 | # Try the list of urls for each single object. We keep a record | |
3971 | # where we did get a file from | |
c356248b | 3972 | my(@reordered,$last); |
05bab18e SP |
3973 | my $ccurllist = $self->_get_urllist; |
3974 | $last = $#$ccurllist; | |
c356248b | 3975 | if ($force & 2) { # local cpans probably out of date, don't reorder |
f04ea8d1 | 3976 | @reordered = (0..$last); |
c356248b | 3977 | } else { |
f04ea8d1 SP |
3978 | @reordered = |
3979 | sort { | |
3980 | (substr($ccurllist->[$b],0,4) eq "file") | |
3981 | <=> | |
3982 | (substr($ccurllist->[$a],0,4) eq "file") | |
3983 | or | |
3984 | defined($ThesiteURL) | |
3985 | and | |
05bab18e | 3986 | ($ccurllist->[$b] eq $ThesiteURL) |
f04ea8d1 | 3987 | <=> |
05bab18e | 3988 | ($ccurllist->[$a] eq $ThesiteURL) |
f04ea8d1 | 3989 | } 0..$last; |
c356248b | 3990 | } |
c4d24d4c | 3991 | my(@levels); |
7fefbd44 | 3992 | $Themethod ||= ""; |
05bab18e | 3993 | $self->debug("Themethod[$Themethod]reordered[@reordered]") if $CPAN::DEBUG; |
f04ea8d1 SP |
3994 | my @all_levels = ( |
3995 | ["dleasy", "file"], | |
3996 | ["dleasy"], | |
3997 | ["dlhard"], | |
3998 | ["dlhardest"], | |
3999 | ["dleasy", "http","defaultsites"], | |
4000 | ["dlhard", "http","defaultsites"], | |
4001 | ["dleasy", "ftp", "defaultsites"], | |
4002 | ["dlhard", "ftp", "defaultsites"], | |
4003 | ["dlhardest","", "defaultsites"], | |
4004 | ); | |
c356248b | 4005 | if ($Themethod) { |
f04ea8d1 SP |
4006 | @levels = grep {$_->[0] eq $Themethod} @all_levels; |
4007 | push @levels, grep {$_->[0] ne $Themethod} @all_levels; | |
c356248b | 4008 | } else { |
f04ea8d1 | 4009 | @levels = @all_levels; |
c356248b | 4010 | } |
f04ea8d1 | 4011 | @levels = qw/dleasy/ if $^O eq 'MacOS'; |
c4d24d4c | 4012 | my($levelno); |
f04ea8d1 | 4013 | local $ENV{FTP_PASSIVE} = |
4d1321a7 A |
4014 | exists $CPAN::Config->{ftp_passive} ? |
4015 | $CPAN::Config->{ftp_passive} : 1; | |
05bab18e SP |
4016 | my $ret; |
4017 | my $stats = $self->_new_stats($file); | |
4018 | LEVEL: for $levelno (0..$#levels) { | |
f04ea8d1 SP |
4019 | my $level_tuple = $levels[$levelno]; |
4020 | my($level,$scheme,$sitetag) = @$level_tuple; | |
4021 | my $defaultsites = $sitetag && $sitetag eq "defaultsites"; | |
4022 | my @urllist; | |
4023 | if ($defaultsites) { | |
4024 | unless (defined $connect_to_internet_ok) { | |
4025 | $CPAN::Frontend->myprint(sprintf qq{ | |
4026 | I would like to connect to one of the following sites to get '%s': | |
4027 | ||
4028 | %s | |
4029 | }, | |
4030 | $file, | |
4031 | join("",map { " ".$_->text."\n" } @CPAN::Defaultsites), | |
4032 | ); | |
4033 | my $answer = CPAN::Shell::colorable_makemaker_prompt("Is it OK to try to connect to the Internet?", "yes"); | |
4034 | if ($answer =~ /^y/i) { | |
4035 | $connect_to_internet_ok = 1; | |
4036 | } else { | |
4037 | $connect_to_internet_ok = 0; | |
4038 | } | |
4039 | } | |
4040 | if ($connect_to_internet_ok) { | |
4041 | @urllist = @CPAN::Defaultsites; | |
4042 | } else { | |
4043 | @urllist = (); | |
4044 | } | |
4045 | } else { | |
4046 | my @host_seq = $level =~ /dleasy/ ? | |
4047 | @reordered : 0..$last; # reordered has file and $Thesiteurl first | |
4048 | @urllist = map { $ccurllist->[$_] } @host_seq; | |
ca79d794 SP |
4049 | } |
4050 | $self->debug("synth. urllist[@urllist]") if $CPAN::DEBUG; | |
05bab18e SP |
4051 | my $aslocal_tempfile = $aslocal . ".tmp" . $$; |
4052 | if (my $recommend = $self->_recommend_url_for($file)) { | |
4053 | @urllist = grep { $_ ne $recommend } @urllist; | |
4054 | unshift @urllist, $recommend; | |
4055 | } | |
4056 | $self->debug("synth. urllist[@urllist]") if $CPAN::DEBUG; | |
f04ea8d1 SP |
4057 | $ret = $self->hostdlxxx($level,$scheme,\@urllist,$file,$aslocal_tempfile,$stats); |
4058 | if ($ret) { | |
05bab18e SP |
4059 | CPAN->debug("ret[$ret]aslocal[$aslocal]") if $CPAN::DEBUG; |
4060 | if ($ret eq $aslocal_tempfile) { | |
4061 | # if we got it exactly as we asked for, only then we | |
4062 | # want to rename | |
4063 | rename $aslocal_tempfile, $aslocal | |
4064 | or $CPAN::Frontend->mydie("Error while trying to rename ". | |
4065 | "'$ret' to '$aslocal': $!"); | |
4066 | $ret = $aslocal; | |
4067 | } | |
4068 | $Themethod = $level; | |
4069 | my $now = time; | |
4070 | # utime $now, $now, $aslocal; # too bad, if we do that, we | |
4071 | # might alter a local mirror | |
4072 | $self->debug("level[$level]") if $CPAN::DEBUG; | |
4073 | last LEVEL; | |
f04ea8d1 | 4074 | } else { |
05bab18e SP |
4075 | unlink $aslocal_tempfile; |
4076 | last if $CPAN::Signal; # need to cleanup | |
f04ea8d1 | 4077 | } |
c356248b | 4078 | } |
05bab18e SP |
4079 | if ($ret) { |
4080 | $stats->{filesize} = -s $ret; | |
4081 | } | |
f20de9f0 | 4082 | $self->debug("before _add_to_statistics") if $CPAN::DEBUG; |
05bab18e | 4083 | $self->_add_to_statistics($stats); |
f20de9f0 | 4084 | $self->debug("after _add_to_statistics") if $CPAN::DEBUG; |
05bab18e | 4085 | if ($ret) { |
be34b10d | 4086 | unlink "$aslocal.bak$$"; |
05bab18e SP |
4087 | return $ret; |
4088 | } | |
c4d24d4c A |
4089 | unless ($CPAN::Signal) { |
4090 | my(@mess); | |
8962fc49 SP |
4091 | local $" = " "; |
4092 | if (@{$CPAN::Config->{urllist}}) { | |
4093 | push @mess, | |
4094 | qq{Please check, if the URLs I found in your configuration file \(}. | |
4095 | join(", ", @{$CPAN::Config->{urllist}}). | |
4096 | qq{\) are valid.}; | |
4097 | } else { | |
4098 | push @mess, qq{Your urllist is empty!}; | |
4099 | } | |
4100 | push @mess, qq{The urllist can be edited.}, | |
4101 | qq{E.g. with 'o conf urllist push ftp://myurl/'}; | |
4102 | $CPAN::Frontend->mywarn(Text::Wrap::wrap("","","@mess"). "\n\n"); | |
4103 | $CPAN::Frontend->mywarn("Could not fetch $file\n"); | |
4104 | $CPAN::Frontend->mysleep(2); | |
c4d24d4c | 4105 | } |
05bab18e | 4106 | if ($maybe_restore) { |
f04ea8d1 SP |
4107 | rename "$aslocal.bak$$", $aslocal; |
4108 | $CPAN::Frontend->myprint("Trying to get away with old file:\n" . | |
4109 | $self->ls($aslocal)); | |
4110 | return $aslocal; | |
c356248b A |
4111 | } |
4112 | return; | |
4113 | } | |
4114 | ||
f04ea8d1 SP |
4115 | sub mymkpath { |
4116 | my($self, $aslocal_dir) = @_; | |
4117 | File::Path::mkpath($aslocal_dir); | |
4118 | $CPAN::Frontend->mywarn(qq{Warning: You are not allowed to write into }. | |
4119 | qq{directory "$aslocal_dir". | |
4120 | I\'ll continue, but if you encounter problems, they may be due | |
4121 | to insufficient permissions.\n}) unless -w $aslocal_dir; | |
4122 | } | |
4123 | ||
4124 | sub hostdlxxx { | |
4125 | my $self = shift; | |
4126 | my $level = shift; | |
4127 | my $scheme = shift; | |
4128 | my $h = shift; | |
4129 | $h = [ grep /^\Q$scheme\E:/, @$h ] if $scheme; | |
4130 | my $method = "host$level"; | |
4131 | $self->$method($h, @_); | |
4132 | } | |
4133 | ||
05bab18e SP |
4134 | sub _set_attempt { |
4135 | my($self,$stats,$method,$url) = @_; | |
4136 | push @{$stats->{attempts}}, { | |
4137 | method => $method, | |
4138 | start => _mytime, | |
4139 | url => $url, | |
4140 | }; | |
4141 | } | |
4142 | ||
ca79d794 | 4143 | # package CPAN::FTP; |
f04ea8d1 | 4144 | sub hostdleasy { |
05bab18e | 4145 | my($self,$host_seq,$file,$aslocal,$stats) = @_; |
ca79d794 SP |
4146 | my($ro_url); |
4147 | HOSTEASY: for $ro_url (@$host_seq) { | |
f04ea8d1 SP |
4148 | $self->_set_attempt($stats,"dleasy",$ro_url); |
4149 | my $url .= "$ro_url$file"; | |
4150 | $self->debug("localizing perlish[$url]") if $CPAN::DEBUG; | |
4151 | if ($url =~ /^file:/) { | |
4152 | my $l; | |
4153 | if ($CPAN::META->has_inst('URI::URL')) { | |
4154 | my $u = URI::URL->new($url); | |
4155 | $l = $u->path; | |
4156 | } else { # works only on Unix, is poorly constructed, but | |
4157 | # hopefully better than nothing. | |
4158 | # RFC 1738 says fileurl BNF is | |
4159 | # fileurl = "file://" [ host | "localhost" ] "/" fpath | |
4160 | # Thanks to "Mark D. Baushke" <mdb@cisco.com> for | |
4161 | # the code | |
4162 | ($l = $url) =~ s|^file://[^/]*/|/|; # discard the host part | |
4163 | $l =~ s|^file:||; # assume they | |
36263cb3 GS |
4164 | # meant |
4165 | # file://localhost | |
f04ea8d1 | 4166 | $l =~ s|^/||s |
4d1321a7 | 4167 | if ! -f $l && $l =~ m|^/\w:|; # e.g. /P: |
f04ea8d1 | 4168 | } |
4d1321a7 | 4169 | $self->debug("local file[$l]") if $CPAN::DEBUG; |
f04ea8d1 SP |
4170 | if ( -f $l && -r _) { |
4171 | $ThesiteURL = $ro_url; | |
4172 | return $l; | |
4173 | } | |
4d1321a7 A |
4174 | if ($l =~ /(.+)\.gz$/) { |
4175 | my $ungz = $1; | |
4176 | if ( -f $ungz && -r _) { | |
4177 | $ThesiteURL = $ro_url; | |
4178 | return $ungz; | |
4179 | } | |
4180 | } | |
f04ea8d1 SP |
4181 | # Maybe mirror has compressed it? |
4182 | if (-f "$l.gz") { | |
4183 | $self->debug("found compressed $l.gz") if $CPAN::DEBUG; | |
4184 | eval { CPAN::Tarzip->new("$l.gz")->gunzip($aslocal) }; | |
4185 | if ( -f $aslocal) { | |
4186 | $ThesiteURL = $ro_url; | |
4187 | return $aslocal; | |
4188 | } | |
4189 | } | |
4190 | $CPAN::Frontend->mywarn("Could not find '$l'\n"); | |
4191 | } | |
4192 | $self->debug("it was not a file URL") if $CPAN::DEBUG; | |
c4d24d4c | 4193 | if ($CPAN::META->has_usable('LWP')) { |
7fefbd44 | 4194 | $CPAN::Frontend->myprint("Fetching with LWP: |
c356248b A |
4195 | $url |
4196 | "); | |
7fefbd44 RGS |
4197 | unless ($Ua) { |
4198 | CPAN::LWP::UserAgent->config; | |
4199 | eval { $Ua = CPAN::LWP::UserAgent->new; }; | |
4200 | if ($@) { | |
4201 | $CPAN::Frontend->mywarn("CPAN::LWP::UserAgent->new dies with $@\n"); | |
4202 | } | |
4203 | } | |
4204 | my $res = $Ua->mirror($url, $aslocal); | |
4205 | if ($res->is_success) { | |
4206 | $ThesiteURL = $ro_url; | |
4207 | my $now = time; | |
4208 | utime $now, $now, $aslocal; # download time is more | |
4209 | # important than upload | |
4210 | # time | |
4211 | return $aslocal; | |
4212 | } elsif ($url !~ /\.gz(?!\n)\Z/) { | |
4213 | my $gzurl = "$url.gz"; | |
4214 | $CPAN::Frontend->myprint("Fetching with LWP: | |
c356248b A |
4215 | $gzurl |
4216 | "); | |
7fefbd44 | 4217 | $res = $Ua->mirror($gzurl, "$aslocal.gz"); |
be34b10d SP |
4218 | if ($res->is_success) { |
4219 | if (eval {CPAN::Tarzip->new("$aslocal.gz")->gunzip($aslocal)}) { | |
4220 | $ThesiteURL = $ro_url; | |
4221 | return $aslocal; | |
4222 | } | |
7fefbd44 RGS |
4223 | } |
4224 | } else { | |
4225 | $CPAN::Frontend->myprint(sprintf( | |
4226 | "LWP failed with code[%s] message[%s]\n", | |
4227 | $res->code, | |
4228 | $res->message, | |
4229 | )); | |
4230 | # Alan Burlison informed me that in firewall environments | |
4231 | # Net::FTP can still succeed where LWP fails. So we do not | |
4232 | # skip Net::FTP anymore when LWP is available. | |
4233 | } | |
7fefbd44 | 4234 | } else { |
8962fc49 | 4235 | $CPAN::Frontend->mywarn(" LWP not available\n"); |
f04ea8d1 | 4236 | } |
c4d24d4c | 4237 | return if $CPAN::Signal; |
f04ea8d1 SP |
4238 | if ($url =~ m|^ftp://(.*?)/(.*)/(.*)|) { |
4239 | # that's the nice and easy way thanks to Graham | |
05bab18e | 4240 | $self->debug("recognized ftp") if $CPAN::DEBUG; |
f04ea8d1 SP |
4241 | my($host,$dir,$getfile) = ($1,$2,$3); |
4242 | if ($CPAN::META->has_usable('Net::FTP')) { | |
4243 | $dir =~ s|/+|/|g; | |
4244 | $CPAN::Frontend->myprint("Fetching with Net::FTP: | |
09d9d230 | 4245 | $url |
c356248b | 4246 | "); |
f04ea8d1 SP |
4247 | $self->debug("getfile[$getfile]dir[$dir]host[$host]" . |
4248 | "aslocal[$aslocal]") if $CPAN::DEBUG; | |
4249 | if (CPAN::FTP->ftp_get($host,$dir,$getfile,$aslocal)) { | |
4250 | $ThesiteURL = $ro_url; | |
4251 | return $aslocal; | |
4252 | } | |
4253 | if ($aslocal !~ /\.gz(?!\n)\Z/) { | |
4254 | my $gz = "$aslocal.gz"; | |
4255 | $CPAN::Frontend->myprint("Fetching with Net::FTP | |
09d9d230 | 4256 | $url.gz |
c356248b | 4257 | "); |
e82b9348 SP |
4258 | if (CPAN::FTP->ftp_get($host, |
4259 | $dir, | |
4260 | "$getfile.gz", | |
4261 | $gz) && | |
f04ea8d1 SP |
4262 | eval{CPAN::Tarzip->new($gz)->gunzip($aslocal)} |
4263 | ) { | |
4264 | $ThesiteURL = $ro_url; | |
4265 | return $aslocal; | |
4266 | } | |
4267 | } | |
4268 | # next HOSTEASY; | |
4269 | } else { | |
05bab18e SP |
4270 | CPAN->debug("Net::FTP does not count as usable atm") if $CPAN::DEBUG; |
4271 | } | |
f04ea8d1 | 4272 | } |
05bab18e SP |
4273 | if ( |
4274 | UNIVERSAL::can($ro_url,"text") | |
4275 | and | |
4276 | $ro_url->{FROM} eq "USER" | |
f04ea8d1 | 4277 | ) { |
05bab18e SP |
4278 | ##address #17973: default URLs should not try to override |
4279 | ##user-defined URLs just because LWP is not available | |
f04ea8d1 | 4280 | my $ret = $self->hostdlhard([$ro_url],$file,$aslocal,$stats); |
05bab18e SP |
4281 | return $ret if $ret; |
4282 | } | |
c4d24d4c | 4283 | return if $CPAN::Signal; |
c356248b A |
4284 | } |
4285 | } | |
05454584 | 4286 | |
ca79d794 | 4287 | # package CPAN::FTP; |
f04ea8d1 SP |
4288 | sub hostdlhard { |
4289 | my($self,$host_seq,$file,$aslocal,$stats) = @_; | |
4290 | ||
4291 | # Came back if Net::FTP couldn't establish connection (or | |
4292 | # failed otherwise) Maybe they are behind a firewall, but they | |
4293 | # gave us a socksified (or other) ftp program... | |
4294 | ||
4295 | my($ro_url); | |
4296 | my($devnull) = $CPAN::Config->{devnull} || ""; | |
4297 | # < /dev/null "; | |
4298 | my($aslocal_dir) = File::Basename::dirname($aslocal); | |
4299 | File::Path::mkpath($aslocal_dir); | |
ca79d794 | 4300 | HOSTHARD: for $ro_url (@$host_seq) { |
f04ea8d1 SP |
4301 | $self->_set_attempt($stats,"dlhard",$ro_url); |
4302 | my $url = "$ro_url$file"; | |
4303 | my($proto,$host,$dir,$getfile); | |
4304 | ||
4305 | # Courtesy Mark Conty mark_conty@cargill.com change from | |
4306 | # if ($url =~ m|^ftp://(.*?)/(.*)/(.*)|) { | |
4307 | # to | |
4308 | if ($url =~ m|^([^:]+)://(.*?)/(.*)/(.*)|) { | |
4309 | # proto not yet used | |
4310 | ($proto,$host,$dir,$getfile) = ($1,$2,$3,$4); | |
4311 | } else { | |
4312 | next HOSTHARD; # who said, we could ftp anything except ftp? | |
4313 | } | |
5a5fac02 JH |
4314 | next HOSTHARD if $proto eq "file"; # file URLs would have had |
4315 | # success above. Likely a bogus URL | |
911a92db | 4316 | |
f04ea8d1 | 4317 | $self->debug("localizing funkyftpwise[$url]") if $CPAN::DEBUG; |
73beb80c | 4318 | |
f04ea8d1 | 4319 | # Try the most capable first and leave ncftp* for last as it only |
73beb80c | 4320 | # does FTP. |
44d21104 | 4321 | DLPRG: for my $f (qw(curl wget lynx ncftpget ncftp)) { |
f04ea8d1 SP |
4322 | my $funkyftp = CPAN::HandleConfig->safe_quote($CPAN::Config->{$f}); |
4323 | next unless defined $funkyftp; | |
4324 | next if $funkyftp =~ /^\s*$/; | |
4325 | ||
4326 | my($asl_ungz, $asl_gz); | |
4327 | ($asl_ungz = $aslocal) =~ s/\.gz//; | |
4328 | $asl_gz = "$asl_ungz.gz"; | |
4329 | ||
4330 | my($src_switch) = ""; | |
4331 | my($chdir) = ""; | |
4332 | my($stdout_redir) = " > $asl_ungz"; | |
4333 | if ($f eq "lynx") { | |
4334 | $src_switch = " -source"; | |
4335 | } elsif ($f eq "ncftp") { | |
4336 | $src_switch = " -c"; | |
4337 | } elsif ($f eq "wget") { | |
4338 | $src_switch = " -O $asl_ungz"; | |
4339 | $stdout_redir = ""; | |
4340 | } elsif ($f eq 'curl') { | |
4341 | $src_switch = ' -L -f -s -S --netrc-optional'; | |
4342 | } | |
4343 | ||
4344 | if ($f eq "ncftpget") { | |
4345 | $chdir = "cd $aslocal_dir && "; | |
4346 | $stdout_redir = ""; | |
4347 | } | |
4348 | $CPAN::Frontend->myprint( | |
4349 | qq[ | |
de34a54b | 4350 | Trying with "$funkyftp$src_switch" to get |
c356248b | 4351 | $url |
2e2b7522 | 4352 | ]); |
f04ea8d1 SP |
4353 | my($system) = |
4354 | "$chdir$funkyftp$src_switch \"$url\" $devnull$stdout_redir"; | |
4355 | $self->debug("system[$system]") if $CPAN::DEBUG; | |
4356 | my($wstatus) = system($system); | |
4357 | if ($f eq "lynx") { | |
4358 | # lynx returns 0 when it fails somewhere | |
4359 | if (-s $asl_ungz) { | |
4360 | my $content = do { local *FH; | |
4361 | open FH, $asl_ungz or die; | |
4362 | local $/; | |
4363 | <FH> }; | |
4364 | if ($content =~ /^<.*(<title>[45]|Error [45])/si) { | |
4365 | $CPAN::Frontend->mywarn(qq{ | |
4366 | No success, the file that lynx has downloaded looks like an error message: | |
44d21104 A |
4367 | $content |
4368 | }); | |
f04ea8d1 SP |
4369 | $CPAN::Frontend->mysleep(1); |
4370 | next DLPRG; | |
4371 | } | |
be34b10d | 4372 | } else { |
f04ea8d1 SP |
4373 | $CPAN::Frontend->myprint(qq{ |
4374 | No success, the file that lynx has downloaded is an empty file. | |
4375 | }); | |
4376 | next DLPRG; | |
4377 | } | |
4378 | } | |
4379 | if ($wstatus == 0) { | |
4380 | if (-s $aslocal) { | |
4381 | # Looks good | |
4382 | } elsif ($asl_ungz ne $aslocal) { | |
4383 | # test gzip integrity | |
4384 | if (eval{CPAN::Tarzip->new($asl_ungz)->gtest}) { | |
4385 | # e.g. foo.tar is gzipped --> foo.tar.gz | |
4386 | rename $asl_ungz, $aslocal; | |
4387 | } else { | |
4388 | eval{CPAN::Tarzip->new($asl_gz)->gzip($asl_ungz)}; | |
4389 | } | |
be34b10d SP |
4390 | } |
4391 | $ThesiteURL = $ro_url; | |
4392 | return $aslocal; | |
f04ea8d1 SP |
4393 | } elsif ($url !~ /\.gz(?!\n)\Z/) { |
4394 | unlink $asl_ungz if | |
4395 | -f $asl_ungz && -s _ == 0; | |
4396 | my $gz = "$aslocal.gz"; | |
4397 | my $gzurl = "$url.gz"; | |
4398 | $CPAN::Frontend->myprint( | |
4399 | qq[ | |
4400 | Trying with "$funkyftp$src_switch" to get | |
4401 | $url.gz | |
4402 | ]); | |
4403 | my($system) = "$funkyftp$src_switch \"$url.gz\" $devnull > $asl_gz"; | |
4404 | $self->debug("system[$system]") if $CPAN::DEBUG; | |
4405 | my($wstatus); | |
4406 | if (($wstatus = system($system)) == 0 | |
4407 | && | |
4408 | -s $asl_gz | |
4409 | ) { | |
4410 | # test gzip integrity | |
4411 | my $ct = eval{CPAN::Tarzip->new($asl_gz)}; | |
4412 | if ($ct && $ct->gtest) { | |
4413 | $ct->gunzip($aslocal); | |
4414 | } else { | |
4415 | # somebody uncompressed file for us? | |
4416 | rename $asl_ungz, $aslocal; | |
4417 | } | |
4418 | $ThesiteURL = $ro_url; | |
4419 | return $aslocal; | |
4420 | } else { | |
4421 | unlink $asl_gz if -f $asl_gz; | |
4422 | } | |
4423 | } else { | |
4424 | my $estatus = $wstatus >> 8; | |
4425 | my $size = -f $aslocal ? | |
4426 | ", left\n$aslocal with size ".-s _ : | |
4427 | "\nWarning: expected file [$aslocal] doesn't exist"; | |
4428 | $CPAN::Frontend->myprint(qq{ | |
4429 | System call "$system" | |
4430 | returned status $estatus (wstat $wstatus)$size | |
4431 | }); | |
4432 | } | |
4433 | return if $CPAN::Signal; | |
4434 | } # transfer programs | |
c4d24d4c | 4435 | } # host |
c356248b | 4436 | } |
05454584 | 4437 | |
ca79d794 | 4438 | # package CPAN::FTP; |
f04ea8d1 | 4439 | sub hostdlhardest { |
05bab18e | 4440 | my($self,$host_seq,$file,$aslocal,$stats) = @_; |
c356248b | 4441 | |
f04ea8d1 | 4442 | return unless @$host_seq; |
ca79d794 | 4443 | my($ro_url); |
c356248b A |
4444 | my($aslocal_dir) = File::Basename::dirname($aslocal); |
4445 | File::Path::mkpath($aslocal_dir); | |
35576f8c | 4446 | my $ftpbin = $CPAN::Config->{ftp}; |
8fc516fe | 4447 | unless ($ftpbin && length $ftpbin && MM->maybe_command($ftpbin)) { |
ca79d794 SP |
4448 | $CPAN::Frontend->myprint("No external ftp command available\n\n"); |
4449 | return; | |
4450 | } | |
8962fc49 | 4451 | $CPAN::Frontend->mywarn(qq{ |
ca79d794 SP |
4452 | As a last ressort we now switch to the external ftp command '$ftpbin' |
4453 | to get '$aslocal'. | |
4454 | ||
8962fc49 | 4455 | Doing so often leads to problems that are hard to diagnose. |
ca79d794 SP |
4456 | |
4457 | If you're victim of such problems, please consider unsetting the ftp | |
4458 | config variable with | |
4459 | ||
4460 | o conf ftp "" | |
4461 | o conf commit | |
4462 | ||
4463 | }); | |
8962fc49 | 4464 | $CPAN::Frontend->mysleep(2); |
ca79d794 | 4465 | HOSTHARDEST: for $ro_url (@$host_seq) { |
f04ea8d1 SP |
4466 | $self->_set_attempt($stats,"dlhardest",$ro_url); |
4467 | my $url = "$ro_url$file"; | |
4468 | $self->debug("localizing ftpwise[$url]") if $CPAN::DEBUG; | |
4469 | unless ($url =~ m|^ftp://(.*?)/(.*)/(.*)|) { | |
4470 | next; | |
4471 | } | |
4472 | my($host,$dir,$getfile) = ($1,$2,$3); | |
4473 | my $timestamp = 0; | |
4474 | my($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime, | |
4475 | $ctime,$blksize,$blocks) = stat($aslocal); | |
4476 | $timestamp = $mtime ||= 0; | |
4477 | my($netrc) = CPAN::FTP::netrc->new; | |
4478 | my($netrcfile) = $netrc->netrc; | |
4479 | my($verbose) = $CPAN::DEBUG{'FTP'} & $CPAN::DEBUG ? " -v" : ""; | |
4480 | my $targetfile = File::Basename::basename($aslocal); | |
4481 | my(@dialog); | |
4482 | push( | |
4483 | @dialog, | |
4484 | "lcd $aslocal_dir", | |
4485 | "cd /", | |
4486 | map("cd $_", split /\//, $dir), # RFC 1738 | |
4487 | "bin", | |
4488 | "get $getfile $targetfile", | |
4489 | "quit" | |
4490 | ); | |
4491 | if (! $netrcfile) { | |
4492 | CPAN->debug("No ~/.netrc file found") if $CPAN::DEBUG; | |
4493 | } elsif ($netrc->hasdefault || $netrc->contains($host)) { | |
4494 | CPAN->debug(sprintf("hasdef[%d]cont($host)[%d]", | |
4495 | $netrc->hasdefault, | |
4496 | $netrc->contains($host))) if $CPAN::DEBUG; | |
4497 | if ($netrc->protected) { | |
ca79d794 SP |
4498 | my $dialog = join "", map { " $_\n" } @dialog; |
4499 | my $netrc_explain; | |
4500 | if ($netrc->contains($host)) { | |
4501 | $netrc_explain = "Relying that your .netrc entry for '$host' ". | |
4502 | "manages the login"; | |
4503 | } else { | |
4504 | $netrc_explain = "Relying that your default .netrc entry ". | |
4505 | "manages the login"; | |
4506 | } | |
f04ea8d1 | 4507 | $CPAN::Frontend->myprint(qq{ |
05454584 A |
4508 | Trying with external ftp to get |
4509 | $url | |
ca79d794 SP |
4510 | $netrc_explain |
4511 | Going to send the dialog | |
4512 | $dialog | |
05454584 | 4513 | } |
f04ea8d1 SP |
4514 | ); |
4515 | $self->talk_ftp("$ftpbin$verbose $host", | |
4516 | @dialog); | |
4517 | ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size, | |
4518 | $atime,$mtime,$ctime,$blksize,$blocks) = stat($aslocal); | |
4519 | $mtime ||= 0; | |
4520 | if ($mtime > $timestamp) { | |
4521 | $CPAN::Frontend->myprint("GOT $aslocal\n"); | |
4522 | $ThesiteURL = $ro_url; | |
4523 | return $aslocal; | |
4524 | } else { | |
4525 | $CPAN::Frontend->myprint("Hmm... Still failed!\n"); | |
4526 | } | |
4527 | return if $CPAN::Signal; | |
4528 | } else { | |
4529 | $CPAN::Frontend->mywarn(qq{Your $netrcfile is not }. | |
4530 | qq{correctly protected.\n}); | |
4531 | } | |
4532 | } else { | |
4533 | $CPAN::Frontend->mywarn("Your ~/.netrc neither contains $host | |
c356248b | 4534 | nor does it have a default entry\n"); |
f04ea8d1 SP |
4535 | } |
4536 | ||
4537 | # OK, they don't have a valid ~/.netrc. Use 'ftp -n' | |
4538 | # then and login manually to host, using e-mail as | |
4539 | # password. | |
4540 | $CPAN::Frontend->myprint(qq{Issuing "$ftpbin$verbose -n"\n}); | |
4541 | unshift( | |
4542 | @dialog, | |
4543 | "open $host", | |
4544 | "user anonymous $Config::Config{'cf_email'}" | |
4545 | ); | |
ca79d794 SP |
4546 | my $dialog = join "", map { " $_\n" } @dialog; |
4547 | $CPAN::Frontend->myprint(qq{ | |
4548 | Trying with external ftp to get | |
4549 | $url | |
4550 | Going to send the dialog | |
4551 | $dialog | |
4552 | } | |
f04ea8d1 SP |
4553 | ); |
4554 | $self->talk_ftp("$ftpbin$verbose -n", @dialog); | |
4555 | ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size, | |
4556 | $atime,$mtime,$ctime,$blksize,$blocks) = stat($aslocal); | |
4557 | $mtime ||= 0; | |
4558 | if ($mtime > $timestamp) { | |
4559 | $CPAN::Frontend->myprint("GOT $aslocal\n"); | |
4560 | $ThesiteURL = $ro_url; | |
4561 | return $aslocal; | |
4562 | } else { | |
4563 | $CPAN::Frontend->myprint("Bad luck... Still failed!\n"); | |
4564 | } | |
c4d24d4c | 4565 | return if $CPAN::Signal; |
f04ea8d1 SP |
4566 | $CPAN::Frontend->mywarn("Can't access URL $url.\n\n"); |
4567 | $CPAN::Frontend->mysleep(2); | |
c4d24d4c | 4568 | } # host |
c356248b A |
4569 | } |
4570 | ||
ca79d794 | 4571 | # package CPAN::FTP; |
c356248b A |
4572 | sub talk_ftp { |
4573 | my($self,$command,@dialog) = @_; | |
4574 | my $fh = FileHandle->new; | |
4575 | $fh->open("|$command") or die "Couldn't open ftp: $!"; | |
4576 | foreach (@dialog) { $fh->print("$_\n") } | |
f04ea8d1 | 4577 | $fh->close; # Wait for process to complete |
c356248b A |
4578 | my $wstatus = $?; |
4579 | my $estatus = $wstatus >> 8; | |
4580 | $CPAN::Frontend->myprint(qq{ | |
4581 | Subprocess "|$command" | |
4582 | returned status $estatus (wstat $wstatus) | |
4583 | }) if $wstatus; | |
05454584 A |
4584 | } |
4585 | ||
e50380aa A |
4586 | # find2perl needs modularization, too, all the following is stolen |
4587 | # from there | |
09d9d230 | 4588 | # CPAN::FTP::ls |
e50380aa A |
4589 | sub ls { |
4590 | my($self,$name) = @_; | |
4591 | my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$sizemm, | |
4592 | $atime,$mtime,$ctime,$blksize,$blocks) = lstat($name); | |
4593 | ||
4594 | my($perms,%user,%group); | |
4595 | my $pname = $name; | |
4596 | ||
55e314ee | 4597 | if ($blocks) { |
f04ea8d1 | 4598 | $blocks = int(($blocks + 1) / 2); |
e50380aa A |
4599 | } |
4600 | else { | |
f04ea8d1 | 4601 | $blocks = int(($sizemm + 1023) / 1024); |
e50380aa A |
4602 | } |
4603 | ||
4604 | if (-f _) { $perms = '-'; } | |
4605 | elsif (-d _) { $perms = 'd'; } | |
4606 | elsif (-c _) { $perms = 'c'; $sizemm = &sizemm; } | |
4607 | elsif (-b _) { $perms = 'b'; $sizemm = &sizemm; } | |
4608 | elsif (-p _) { $perms = 'p'; } | |
4609 | elsif (-S _) { $perms = 's'; } | |
4610 | else { $perms = 'l'; $pname .= ' -> ' . readlink($_); } | |
4611 | ||
4612 | my(@rwx) = ('---','--x','-w-','-wx','r--','r-x','rw-','rwx'); | |
4613 | my(@moname) = qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec); | |
4614 | my $tmpmode = $mode; | |
4615 | my $tmp = $rwx[$tmpmode & 7]; | |
4616 | $tmpmode >>= 3; | |
4617 | $tmp = $rwx[$tmpmode & 7] . $tmp; | |
4618 | $tmpmode >>= 3; | |
4619 | $tmp = $rwx[$tmpmode & 7] . $tmp; | |
4620 | substr($tmp,2,1) =~ tr/-x/Ss/ if -u _; | |
4621 | substr($tmp,5,1) =~ tr/-x/Ss/ if -g _; | |
4622 | substr($tmp,8,1) =~ tr/-x/Tt/ if -k _; | |
4623 | $perms .= $tmp; | |
4624 | ||
4625 | my $user = $user{$uid} || $uid; # too lazy to implement lookup | |
4626 | my $group = $group{$gid} || $gid; | |
4627 | ||
4628 | my($sec,$min,$hour,$mday,$mon,$year) = localtime($mtime); | |
4629 | my($timeyear); | |
4630 | my($moname) = $moname[$mon]; | |
4631 | if (-M _ > 365.25 / 2) { | |
f04ea8d1 | 4632 | $timeyear = $year + 1900; |
e50380aa A |
4633 | } |
4634 | else { | |
f04ea8d1 | 4635 | $timeyear = sprintf("%02d:%02d", $hour, $min); |
e50380aa A |
4636 | } |
4637 | ||
4638 | sprintf "%5lu %4ld %-10s %2d %-8s %-8s %8s %s %2d %5s %s\n", | |
f04ea8d1 SP |
4639 | $ino, |
4640 | $blocks, | |
4641 | $perms, | |
4642 | $nlink, | |
4643 | $user, | |
4644 | $group, | |
4645 | $sizemm, | |
4646 | $moname, | |
4647 | $mday, | |
4648 | $timeyear, | |
4649 | $pname; | |
e50380aa A |
4650 | } |
4651 | ||
05454584 | 4652 | package CPAN::FTP::netrc; |
e82b9348 | 4653 | use strict; |
05454584 | 4654 | |
ca79d794 | 4655 | # package CPAN::FTP::netrc; |
05454584 A |
4656 | sub new { |
4657 | my($class) = @_; | |
87892b73 RGS |
4658 | my $home = CPAN::HandleConfig::home; |
4659 | my $file = File::Spec->catfile($home,".netrc"); | |
05454584 A |
4660 | |
4661 | my($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size, | |
4662 | $atime,$mtime,$ctime,$blksize,$blocks) | |
f04ea8d1 | 4663 | = stat($file); |
05454584 A |
4664 | $mode ||= 0; |
4665 | my $protected = 0; | |
4666 | ||
42d3b621 A |
4667 | my($fh,@machines,$hasdefault); |
4668 | $hasdefault = 0; | |
da199366 A |
4669 | $fh = FileHandle->new or die "Could not create a filehandle"; |
4670 | ||
f04ea8d1 SP |
4671 | if($fh->open($file)) { |
4672 | $protected = ($mode & 077) == 0; | |
4673 | local($/) = ""; | |
42d3b621 | 4674 | NETRC: while (<$fh>) { |
f04ea8d1 SP |
4675 | my(@tokens) = split " ", $_; |
4676 | TOKEN: while (@tokens) { | |
4677 | my($t) = shift @tokens; | |
4678 | if ($t eq "default") { | |
4679 | $hasdefault++; | |
4680 | last NETRC; | |
4681 | } | |
4682 | last TOKEN if $t eq "macdef"; | |
4683 | if ($t eq "machine") { | |
4684 | push @machines, shift @tokens; | |
4685 | } | |
4686 | } | |
4687 | } | |
10b2abe6 | 4688 | } else { |
f04ea8d1 | 4689 | $file = $hasdefault = $protected = ""; |
10b2abe6 | 4690 | } |
da199366 | 4691 | |
10b2abe6 | 4692 | bless { |
f04ea8d1 SP |
4693 | 'mach' => [@machines], |
4694 | 'netrc' => $file, | |
4695 | 'hasdefault' => $hasdefault, | |
4696 | 'protected' => $protected, | |
4697 | }, $class; | |
10b2abe6 CS |
4698 | } |
4699 | ||
ca79d794 | 4700 | # CPAN::FTP::netrc::hasdefault; |
42d3b621 | 4701 | sub hasdefault { shift->{'hasdefault'} } |
da199366 A |
4702 | sub netrc { shift->{'netrc'} } |
4703 | sub protected { shift->{'protected'} } | |
10b2abe6 CS |
4704 | sub contains { |
4705 | my($self,$mach) = @_; | |
da199366 | 4706 | for ( @{$self->{'mach'}} ) { |
f04ea8d1 | 4707 | return 1 if $_ eq $mach; |
da199366 A |
4708 | } |
4709 | return 0; | |
10b2abe6 CS |
4710 | } |
4711 | ||
5f05dabc | 4712 | package CPAN::Complete; |
e82b9348 | 4713 | use strict; |
5f05dabc | 4714 | |
36263cb3 GS |
4715 | sub gnu_cpl { |
4716 | my($text, $line, $start, $end) = @_; | |
4717 | my(@perlret) = cpl($text, $line, $start); | |
4718 | # find longest common match. Can anybody show me how to peruse | |
4719 | # T::R::Gnu to have this done automatically? Seems expensive. | |
4720 | return () unless @perlret; | |
4721 | my($newtext) = $text; | |
4722 | for (my $i = length($text)+1;;$i++) { | |
f04ea8d1 SP |
4723 | last unless length($perlret[0]) && length($perlret[0]) >= $i; |
4724 | my $try = substr($perlret[0],0,$i); | |
4725 | my @tries = grep {substr($_,0,$i) eq $try} @perlret; | |
4726 | # warn "try[$try]tries[@tries]"; | |
4727 | if (@tries == @perlret) { | |
4728 | $newtext = $try; | |
4729 | } else { | |
4730 | last; | |
4731 | } | |
36263cb3 GS |
4732 | } |
4733 | ($newtext,@perlret); | |
4734 | } | |
4735 | ||
55e314ee A |
4736 | #-> sub CPAN::Complete::cpl ; |
4737 | sub cpl { | |
5f05dabc | 4738 | my($word,$line,$pos) = @_; |
4739 | $word ||= ""; | |
4740 | $line ||= ""; | |
4741 | $pos ||= 0; | |
4742 | CPAN->debug("word [$word] line[$line] pos[$pos]") if $CPAN::DEBUG; | |
4743 | $line =~ s/^\s*//; | |
f20de9f0 | 4744 | if ($line =~ s/^((?:notest|f?force)\s*)//) { |
f04ea8d1 | 4745 | $pos -= length($1); |
da199366 | 4746 | } |
5f05dabc | 4747 | my @return; |
f04ea8d1 SP |
4748 | if ($pos == 0 || $line =~ /^(?:h(?:elp)?|\?)\s/) { |
4749 | @return = grep /^\Q$word\E/, @CPAN::Complete::COMMANDS; | |
c049f953 | 4750 | } elsif ( $line !~ /^[\!abcdghimorutl]/ ) { |
f04ea8d1 | 4751 | @return = (); |
8d97e4a1 | 4752 | } elsif ($line =~ /^(a|ls)\s/) { |
f04ea8d1 | 4753 | @return = cplx('CPAN::Author',uc($word)); |
5f05dabc | 4754 | } elsif ($line =~ /^b\s/) { |
8d97e4a1 | 4755 | CPAN::Shell->local_bundles; |
f04ea8d1 | 4756 | @return = cplx('CPAN::Bundle',$word); |
5f05dabc | 4757 | } elsif ($line =~ /^d\s/) { |
f04ea8d1 | 4758 | @return = cplx('CPAN::Distribution',$word); |
6d29edf5 | 4759 | } elsif ($line =~ m/^( |
554a9ef5 | 4760 | [mru]|make|clean|dump|get|test|install|readme|look|cvs_import|perldoc|recent |
6d29edf5 | 4761 | )\s/x ) { |
d8773709 JH |
4762 | if ($word =~ /^Bundle::/) { |
4763 | CPAN::Shell->local_bundles; | |
4764 | } | |
f04ea8d1 | 4765 | @return = (cplx('CPAN::Module',$word),cplx('CPAN::Bundle',$word)); |
5f05dabc | 4766 | } elsif ($line =~ /^i\s/) { |
f04ea8d1 | 4767 | @return = cpl_any($word); |
5f05dabc | 4768 | } elsif ($line =~ /^reload\s/) { |
f04ea8d1 | 4769 | @return = cpl_reload($word,$line,$pos); |
5f05dabc | 4770 | } elsif ($line =~ /^o\s/) { |
f04ea8d1 | 4771 | @return = cpl_option($word,$line,$pos); |
9d61fa1d A |
4772 | } elsif ($line =~ m/^\S+\s/ ) { |
4773 | # fallback for future commands and what we have forgotten above | |
f04ea8d1 | 4774 | @return = (cplx('CPAN::Module',$word),cplx('CPAN::Bundle',$word)); |
5f05dabc | 4775 | } else { |
f04ea8d1 | 4776 | @return = (); |
5f05dabc | 4777 | } |
4778 | return @return; | |
4779 | } | |
4780 | ||
55e314ee A |
4781 | #-> sub CPAN::Complete::cplx ; |
4782 | sub cplx { | |
5f05dabc | 4783 | my($class, $word) = @_; |
b72dd56f SP |
4784 | if (CPAN::_sqlite_running) { |
4785 | $CPAN::SQLite->search($class, "^\Q$word\E"); | |
4786 | } | |
de34a54b | 4787 | sort grep /^\Q$word\E/, map { $_->id } $CPAN::META->all_objects($class); |
5f05dabc | 4788 | } |
4789 | ||
55e314ee A |
4790 | #-> sub CPAN::Complete::cpl_any ; |
4791 | sub cpl_any { | |
5f05dabc | 4792 | my($word) = shift; |
4793 | return ( | |
f04ea8d1 SP |
4794 | cplx('CPAN::Author',$word), |
4795 | cplx('CPAN::Bundle',$word), | |
4796 | cplx('CPAN::Distribution',$word), | |
4797 | cplx('CPAN::Module',$word), | |
4798 | ); | |
5f05dabc | 4799 | } |
4800 | ||
55e314ee A |
4801 | #-> sub CPAN::Complete::cpl_reload ; |
4802 | sub cpl_reload { | |
5f05dabc | 4803 | my($word,$line,$pos) = @_; |
4804 | $word ||= ""; | |
4805 | my(@words) = split " ", $line; | |
4806 | CPAN->debug("word[$word] line[$line] pos[$pos]") if $CPAN::DEBUG; | |
4807 | my(@ok) = qw(cpan index); | |
e50380aa A |
4808 | return @ok if @words == 1; |
4809 | return grep /^\Q$word\E/, @ok if @words == 2 && $word; | |
5f05dabc | 4810 | } |
4811 | ||
55e314ee A |
4812 | #-> sub CPAN::Complete::cpl_option ; |
4813 | sub cpl_option { | |
5f05dabc | 4814 | my($word,$line,$pos) = @_; |
4815 | $word ||= ""; | |
4816 | my(@words) = split " ", $line; | |
4817 | CPAN->debug("word[$word] line[$line] pos[$pos]") if $CPAN::DEBUG; | |
4818 | my(@ok) = qw(conf debug); | |
e50380aa | 4819 | return @ok if @words == 1; |
c356248b | 4820 | return grep /^\Q$word\E/, @ok if @words == 2 && length($word); |
5f05dabc | 4821 | if (0) { |
4822 | } elsif ($words[1] eq 'index') { | |
f04ea8d1 | 4823 | return (); |
5f05dabc | 4824 | } elsif ($words[1] eq 'conf') { |
f04ea8d1 | 4825 | return CPAN::HandleConfig::cpl(@_); |
5f05dabc | 4826 | } elsif ($words[1] eq 'debug') { |
f04ea8d1 | 4827 | return sort grep /^\Q$word\E/i, |
554a9ef5 | 4828 | sort keys %CPAN::DEBUG, 'all'; |
5f05dabc | 4829 | } |
4830 | } | |
4831 | ||
4832 | package CPAN::Index; | |
e82b9348 | 4833 | use strict; |
5f05dabc | 4834 | |
10b2abe6 | 4835 | #-> sub CPAN::Index::force_reload ; |
5f05dabc | 4836 | sub force_reload { |
4837 | my($class) = @_; | |
c049f953 | 4838 | $CPAN::Index::LAST_TIME = 0; |
5f05dabc | 4839 | $class->reload(1); |
4840 | } | |
4841 | ||
10b2abe6 | 4842 | #-> sub CPAN::Index::reload ; |
5f05dabc | 4843 | sub reload { |
05bab18e | 4844 | my($self,$force) = @_; |
5f05dabc | 4845 | my $time = time; |
4846 | ||
c356248b A |
4847 | # XXX check if a newer one is available. (We currently read it |
4848 | # from time to time) | |
e50380aa | 4849 | for ($CPAN::Config->{index_expire}) { |
f04ea8d1 | 4850 | $_ = 0.001 unless $_ && $_ > 0.001; |
e50380aa | 4851 | } |
9d61fa1d A |
4852 | unless (1 || $CPAN::Have_warned->{readmetadatacache}++) { |
4853 | # debug here when CPAN doesn't seem to read the Metadata | |
4854 | require Carp; | |
4855 | Carp::cluck("META-PROTOCOL[$CPAN::META->{PROTOCOL}]"); | |
4856 | } | |
4857 | unless ($CPAN::META->{PROTOCOL}) { | |
05bab18e | 4858 | $self->read_metadata_cache; |
9d61fa1d A |
4859 | $CPAN::META->{PROTOCOL} ||= "1.0"; |
4860 | } | |
6d29edf5 JH |
4861 | if ( $CPAN::META->{PROTOCOL} < PROTOCOL ) { |
4862 | # warn "Setting last_time to 0"; | |
c049f953 | 4863 | $LAST_TIME = 0; # No warning necessary |
6d29edf5 | 4864 | } |
05bab18e | 4865 | if ($LAST_TIME + $CPAN::Config->{index_expire}*86400 > $time |
f04ea8d1 | 4866 | and ! $force) { |
05bab18e SP |
4867 | # called too often |
4868 | # CPAN->debug("LAST_TIME[$LAST_TIME]index_expire[$CPAN::Config->{index_expire}]time[$time]"); | |
4869 | } elsif (0) { | |
6d29edf5 JH |
4870 | # IFF we are developing, it helps to wipe out the memory |
4871 | # between reloads, otherwise it is not what a user expects. | |
4872 | undef $CPAN::META; # Neue Gruendlichkeit since v1.52(r1.274) | |
4873 | $CPAN::META = CPAN->new; | |
05bab18e | 4874 | } else { |
6d29edf5 | 4875 | my($debug,$t2); |
c049f953 | 4876 | local $LAST_TIME = $time; |
6d29edf5 JH |
4877 | local $CPAN::META->{PROTOCOL} = PROTOCOL; |
4878 | ||
4879 | my $needshort = $^O eq "dos"; | |
4880 | ||
05bab18e | 4881 | $self->rd_authindex($self |
6d29edf5 JH |
4882 | ->reload_x( |
4883 | "authors/01mailrc.txt.gz", | |
4884 | $needshort ? | |
4885 | File::Spec->catfile('authors', '01mailrc.gz') : | |
4886 | File::Spec->catfile('authors', '01mailrc.txt.gz'), | |
4887 | $force)); | |
4888 | $t2 = time; | |
4889 | $debug = "timing reading 01[".($t2 - $time)."]"; | |
4890 | $time = $t2; | |
4891 | return if $CPAN::Signal; # this is sometimes lengthy | |
05bab18e | 4892 | $self->rd_modpacks($self |
6d29edf5 JH |
4893 | ->reload_x( |
4894 | "modules/02packages.details.txt.gz", | |
4895 | $needshort ? | |
4896 | File::Spec->catfile('modules', '02packag.gz') : | |
4897 | File::Spec->catfile('modules', '02packages.details.txt.gz'), | |
4898 | $force)); | |
4899 | $t2 = time; | |
4900 | $debug .= "02[".($t2 - $time)."]"; | |
4901 | $time = $t2; | |
4902 | return if $CPAN::Signal; # this is sometimes lengthy | |
05bab18e | 4903 | $self->rd_modlist($self |
6d29edf5 JH |
4904 | ->reload_x( |
4905 | "modules/03modlist.data.gz", | |
4906 | $needshort ? | |
4907 | File::Spec->catfile('modules', '03mlist.gz') : | |
4908 | File::Spec->catfile('modules', '03modlist.data.gz'), | |
4909 | $force)); | |
05bab18e | 4910 | $self->write_metadata_cache; |
6d29edf5 JH |
4911 | $t2 = time; |
4912 | $debug .= "03[".($t2 - $time)."]"; | |
4913 | $time = $t2; | |
4914 | CPAN->debug($debug) if $CPAN::DEBUG; | |
4915 | } | |
05bab18e SP |
4916 | if ($CPAN::Config->{build_dir_reuse}) { |
4917 | $self->reanimate_build_dir; | |
4918 | } | |
810a0276 | 4919 | if (CPAN::_sqlite_running) { |
be34b10d SP |
4920 | $CPAN::SQLite->reload(time => $time, force => $force) |
4921 | if not $LAST_TIME; | |
4922 | } | |
c049f953 | 4923 | $LAST_TIME = $time; |
6d29edf5 | 4924 | $CPAN::META->{PROTOCOL} = PROTOCOL; |
5f05dabc | 4925 | } |
4926 | ||
05bab18e SP |
4927 | #-> sub CPAN::Index::reanimate_build_dir ; |
4928 | sub reanimate_build_dir { | |
4929 | my($self) = @_; | |
4930 | unless ($CPAN::META->has_inst($CPAN::Config->{yaml_module}||"YAML")) { | |
4931 | return; | |
4932 | } | |
4933 | return if $HAVE_REANIMATED++; | |
4934 | my $d = $CPAN::Config->{build_dir}; | |
4935 | my $dh = DirHandle->new; | |
4936 | opendir $dh, $d or return; # does not exist | |
4937 | my $dirent; | |
4938 | my $i = 0; | |
4939 | my $painted = 0; | |
4940 | my $restored = 0; | |
4941 | $CPAN::Frontend->myprint("Going to read $CPAN::Config->{build_dir}/\n"); | |
be34b10d SP |
4942 | my @candidates = map { $_->[0] } |
4943 | sort { $b->[1] <=> $a->[1] } | |
4944 | map { [ $_, -M File::Spec->catfile($d,$_) ] } | |
4945 | grep {/\.yml$/} readdir $dh; | |
23a216b4 SP |
4946 | DISTRO: for $i (0..$#candidates) { |
4947 | my $dirent = $candidates[$i]; | |
b72dd56f | 4948 | my $y = eval {CPAN->_yaml_loadfile(File::Spec->catfile($d,$dirent))}; |
23a216b4 SP |
4949 | if ($@) { |
4950 | warn "Error while parsing file '$dirent'; error: '$@'"; | |
4951 | next DISTRO; | |
4952 | } | |
b72dd56f | 4953 | my $c = $y->[0]; |
05bab18e SP |
4954 | if ($c && CPAN->_perl_fingerprint($c->{perl})) { |
4955 | my $key = $c->{distribution}{ID}; | |
4956 | for my $k (keys %{$c->{distribution}}) { | |
4957 | if ($c->{distribution}{$k} | |
4958 | && ref $c->{distribution}{$k} | |
4959 | && UNIVERSAL::isa($c->{distribution}{$k},"CPAN::Distrostatus")) { | |
be34b10d | 4960 | $c->{distribution}{$k}{COMMANDID} = $i - @candidates; |
05bab18e SP |
4961 | } |
4962 | } | |
4963 | ||
4964 | #we tried to restore only if element already | |
4965 | #exists; but then we do not work with metadata | |
4966 | #turned off. | |
b72dd56f SP |
4967 | my $do |
4968 | = $CPAN::META->{readwrite}{'CPAN::Distribution'}{$key} | |
4969 | = $c->{distribution}; | |
f04ea8d1 SP |
4970 | for my $skipper (qw( |
4971 | badtestcnt | |
4972 | configure_requires_later | |
4973 | configure_requires_later_for | |
4974 | force_update | |
4975 | later | |
4976 | later_for | |
4977 | notest | |
4978 | should_report | |
4979 | sponsored_mods | |
4980 | )) { | |
23a216b4 SP |
4981 | delete $do->{$skipper}; |
4982 | } | |
b72dd56f SP |
4983 | # $DB::single = 1; |
4984 | if ($do->{make_test} | |
4985 | && $do->{build_dir} | |
917f1700 SP |
4986 | && !(UNIVERSAL::can($do->{make_test},"failed") ? |
4987 | $do->{make_test}->failed : | |
4988 | $do->{make_test} =~ /^YES/ | |
4989 | ) | |
b72dd56f SP |
4990 | && ( |
4991 | !$do->{install} | |
4992 | || | |
4993 | $do->{install}->failed | |
4994 | ) | |
4995 | ) { | |
4996 | $CPAN::META->is_tested($do->{build_dir},$do->{make_test}{TIME}); | |
4997 | } | |
05bab18e SP |
4998 | $restored++; |
4999 | } | |
5000 | $i++; | |
5001 | while (($painted/76) < ($i/@candidates)) { | |
5002 | $CPAN::Frontend->myprint("."); | |
5003 | $painted++; | |
5004 | } | |
5005 | } | |
5006 | $CPAN::Frontend->myprint(sprintf( | |
23a216b4 | 5007 | "DONE\nFound %s old build%s, restored the state of %s\n", |
05bab18e | 5008 | @candidates ? sprintf("%d",scalar @candidates) : "no", |
23a216b4 | 5009 | @candidates==1 ? "" : "s", |
05bab18e SP |
5010 | $restored || "none", |
5011 | )); | |
5012 | } | |
5013 | ||
5014 | ||
10b2abe6 | 5015 | #-> sub CPAN::Index::reload_x ; |
5f05dabc | 5016 | sub reload_x { |
5017 | my($cl,$wanted,$localname,$force) = @_; | |
c356248b | 5018 | $force |= 2; # means we're dealing with an index here |
135a59c2 A |
5019 | CPAN::HandleConfig->load; # we should guarantee loading wherever |
5020 | # we rely on Config XXX | |
c356248b | 5021 | $localname ||= $wanted; |
5de3f0da | 5022 | my $abs_wanted = File::Spec->catfile($CPAN::Config->{'keep_source_where'}, |
f04ea8d1 | 5023 | $localname); |
e50380aa | 5024 | if ( |
f04ea8d1 SP |
5025 | -f $abs_wanted && |
5026 | -M $abs_wanted < $CPAN::Config->{'index_expire'} && | |
5027 | !($force & 1) | |
e50380aa | 5028 | ) { |
f04ea8d1 SP |
5029 | my $s = $CPAN::Config->{'index_expire'} == 1 ? "" : "s"; |
5030 | $cl->debug(qq{$abs_wanted younger than $CPAN::Config->{'index_expire'} }. | |
5031 | qq{day$s. I\'ll use that.}); | |
5032 | return $abs_wanted; | |
5f05dabc | 5033 | } else { |
f04ea8d1 | 5034 | $force |= 1; # means we're quite serious about it. |
5f05dabc | 5035 | } |
5036 | return CPAN::FTP->localize($wanted,$abs_wanted,$force); | |
5037 | } | |
5038 | ||
55e314ee A |
5039 | #-> sub CPAN::Index::rd_authindex ; |
5040 | sub rd_authindex { | |
f14b5cec | 5041 | my($cl, $index_target) = @_; |
c356248b | 5042 | return unless defined $index_target; |
810a0276 SP |
5043 | return if CPAN::_sqlite_running; |
5044 | my @lines; | |
c356248b | 5045 | $CPAN::Frontend->myprint("Going to read $index_target\n"); |
09d9d230 | 5046 | local(*FH); |
ec5fee46 | 5047 | tie *FH, 'CPAN::Tarzip', $index_target; |
52128c7b | 5048 | local($/) = "\n"; |
e82b9348 | 5049 | local($_); |
f14b5cec | 5050 | push @lines, split /\012/ while <FH>; |
7d97ad34 | 5051 | my $i = 0; |
be34b10d | 5052 | my $painted = 0; |
f14b5cec | 5053 | foreach (@lines) { |
f04ea8d1 SP |
5054 | my($userid,$fullname,$email) = |
5055 | m/alias\s+(\S+)\s+\"([^\"\<]*)\s+\<(.*)\>\"/; | |
8fc516fe | 5056 | $fullname ||= $email; |
f04ea8d1 | 5057 | if ($userid && $fullname && $email) { |
8fc516fe SP |
5058 | my $userobj = $CPAN::META->instance('CPAN::Author',$userid); |
5059 | $userobj->set('FULLNAME' => $fullname, 'EMAIL' => $email); | |
5060 | } else { | |
5061 | CPAN->debug(sprintf "line[%s]", $_) if $CPAN::DEBUG; | |
5062 | } | |
be34b10d SP |
5063 | $i++; |
5064 | while (($painted/76) < ($i/@lines)) { | |
5065 | $CPAN::Frontend->myprint("."); | |
5066 | $painted++; | |
5067 | } | |
f04ea8d1 | 5068 | return if $CPAN::Signal; |
5f05dabc | 5069 | } |
7d97ad34 | 5070 | $CPAN::Frontend->myprint("DONE\n"); |
09d9d230 A |
5071 | } |
5072 | ||
5073 | sub userid { | |
5074 | my($self,$dist) = @_; | |
5075 | $dist = $self->{'id'} unless defined $dist; | |
5076 | my($ret) = $dist =~ m|(?:\w/\w\w/)?([^/]+)/|; | |
5077 | $ret; | |
5f05dabc | 5078 | } |
5079 | ||
55e314ee A |
5080 | #-> sub CPAN::Index::rd_modpacks ; |
5081 | sub rd_modpacks { | |
05d2a450 | 5082 | my($self, $index_target) = @_; |
c356248b | 5083 | return unless defined $index_target; |
810a0276 | 5084 | return if CPAN::_sqlite_running; |
c356248b | 5085 | $CPAN::Frontend->myprint("Going to read $index_target\n"); |
09d9d230 | 5086 | my $fh = CPAN::Tarzip->TIEHANDLE($index_target); |
e82b9348 | 5087 | local $_; |
7d97ad34 SP |
5088 | CPAN->debug(sprintf "start[%d]", time) if $CPAN::DEBUG; |
5089 | my $slurp = ""; | |
5090 | my $chunk; | |
5091 | while (my $bytes = $fh->READ(\$chunk,8192)) { | |
5092 | $slurp.=$chunk; | |
5093 | } | |
5094 | my @lines = split /\012/, $slurp; | |
5095 | CPAN->debug(sprintf "end[%d]", time) if $CPAN::DEBUG; | |
5096 | undef $fh; | |
de34a54b | 5097 | # read header |
c049f953 | 5098 | my($line_count,$last_updated); |
f14b5cec | 5099 | while (@lines) { |
f04ea8d1 SP |
5100 | my $shift = shift(@lines); |
5101 | last if $shift =~ /^\s*$/; | |
5102 | $shift =~ /^Line-Count:\s+(\d+)/ and $line_count = $1; | |
c049f953 | 5103 | $shift =~ /^Last-Updated:\s+(.+)/ and $last_updated = $1; |
f14b5cec | 5104 | } |
7d97ad34 | 5105 | CPAN->debug("line_count[$line_count]last_updated[$last_updated]") if $CPAN::DEBUG; |
de34a54b | 5106 | if (not defined $line_count) { |
05d2a450 | 5107 | |
f04ea8d1 | 5108 | $CPAN::Frontend->mywarn(qq{Warning: Your $index_target does not contain a Line-Count header. |
05d2a450 A |
5109 | Please check the validity of the index file by comparing it to more |
5110 | than one CPAN mirror. I'll continue but problems seem likely to | |
5111 | happen.\a | |
8962fc49 | 5112 | }); |
05d2a450 | 5113 | |
f04ea8d1 | 5114 | $CPAN::Frontend->mysleep(5); |
de34a54b JH |
5115 | } elsif ($line_count != scalar @lines) { |
5116 | ||
f04ea8d1 | 5117 | $CPAN::Frontend->mywarn(sprintf qq{Warning: Your %s |
de34a54b JH |
5118 | contains a Line-Count header of %d but I see %d lines there. Please |
5119 | check the validity of the index file by comparing it to more than one | |
5120 | CPAN mirror. I'll continue but problems seem likely to happen.\a\n}, | |
7fefbd44 | 5121 | $index_target, $line_count, scalar(@lines)); |
de34a54b JH |
5122 | |
5123 | } | |
c049f953 JH |
5124 | if (not defined $last_updated) { |
5125 | ||
f04ea8d1 | 5126 | $CPAN::Frontend->mywarn(qq{Warning: Your $index_target does not contain a Last-Updated header. |
c049f953 JH |
5127 | Please check the validity of the index file by comparing it to more |
5128 | than one CPAN mirror. I'll continue but problems seem likely to | |
5129 | happen.\a | |
8962fc49 | 5130 | }); |
c049f953 | 5131 | |
f04ea8d1 | 5132 | $CPAN::Frontend->mysleep(5); |
c049f953 JH |
5133 | } else { |
5134 | ||
f04ea8d1 | 5135 | $CPAN::Frontend |
c049f953 JH |
5136 | ->myprint(sprintf qq{ Database was generated on %s\n}, |
5137 | $last_updated); | |
5138 | $DATE_OF_02 = $last_updated; | |
5139 | ||
9ddc4ed0 | 5140 | my $age = time; |
ec5fee46 | 5141 | if ($CPAN::META->has_inst('HTTP::Date')) { |
c049f953 | 5142 | require HTTP::Date; |
9ddc4ed0 A |
5143 | $age -= HTTP::Date::str2time($last_updated); |
5144 | } else { | |
8962fc49 | 5145 | $CPAN::Frontend->mywarn(" HTTP::Date not available\n"); |
9ddc4ed0 A |
5146 | require Time::Local; |
5147 | my(@d) = $last_updated =~ / (\d+) (\w+) (\d+) (\d+):(\d+):(\d+) /; | |
5148 | $d[1] = index("Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec", $d[1])/4; | |
5149 | $age -= $d[1]>=0 ? Time::Local::timegm(@d[5,4,3,0,1,2]) : 0; | |
5150 | } | |
5151 | $age /= 3600*24; | |
5152 | if ($age > 30) { | |
c049f953 | 5153 | |
9ddc4ed0 A |
5154 | $CPAN::Frontend |
5155 | ->mywarn(sprintf | |
5156 | qq{Warning: This index file is %d days old. | |
c049f953 JH |
5157 | Please check the host you chose as your CPAN mirror for staleness. |
5158 | I'll continue but problems seem likely to happen.\a\n}, | |
9ddc4ed0 A |
5159 | $age); |
5160 | ||
5161 | } elsif ($age < -1) { | |
5162 | ||
5163 | $CPAN::Frontend | |
5164 | ->mywarn(sprintf | |
5165 | qq{Warning: Your system date is %d days behind this index file! | |
5166 | System time: %s | |
5167 | Timestamp index file: %s | |
5168 | Please fix your system time, problems with the make command expected.\n}, | |
5169 | -$age, | |
5170 | scalar gmtime, | |
5171 | $DATE_OF_02, | |
5172 | ); | |
c049f953 | 5173 | |
c049f953 JH |
5174 | } |
5175 | } | |
5176 | ||
5177 | ||
c4d24d4c A |
5178 | # A necessity since we have metadata_cache: delete what isn't |
5179 | # there anymore | |
5180 | my $secondtime = $CPAN::META->exists("CPAN::Module","CPAN"); | |
5181 | CPAN->debug("secondtime[$secondtime]") if $CPAN::DEBUG; | |
5182 | my(%exists); | |
7d97ad34 | 5183 | my $i = 0; |
be34b10d | 5184 | my $painted = 0; |
f14b5cec | 5185 | foreach (@lines) { |
05d2a450 A |
5186 | # before 1.56 we split into 3 and discarded the rest. From |
5187 | # 1.57 we assign remaining text to $comment thus allowing to | |
5188 | # influence isa_perl | |
f04ea8d1 SP |
5189 | my($mod,$version,$dist,$comment) = split " ", $_, 4; |
5190 | my($bundle,$id,$userid); | |
5191 | ||
5192 | if ($mod eq 'CPAN' && | |
5193 | ! ( | |
5194 | CPAN::Queue->exists('Bundle::CPAN') || | |
5195 | CPAN::Queue->exists('CPAN') | |
5196 | ) | |
5197 | ) { | |
c4d24d4c | 5198 | local($^W)= 0; |
f04ea8d1 | 5199 | if ($version > $CPAN::VERSION) { |
8962fc49 | 5200 | $CPAN::Frontend->mywarn(qq{ |
ed84aac9 A |
5201 | New CPAN.pm version (v$version) available. |
5202 | [Currently running version is v$CPAN::VERSION] | |
e50380aa | 5203 | You might want to try |
b96578bb | 5204 | install CPAN |
5f05dabc | 5205 | reload cpan |
ed84aac9 A |
5206 | to both upgrade CPAN.pm and run the new version without leaving |
5207 | the current session. | |
5208 | ||
c4d24d4c | 5209 | }); #}); |
8962fc49 | 5210 | $CPAN::Frontend->mysleep(2); |
f04ea8d1 SP |
5211 | $CPAN::Frontend->myprint(qq{\n}); |
5212 | } | |
5213 | last if $CPAN::Signal; | |
5214 | } elsif ($mod =~ /^Bundle::(.*)/) { | |
5215 | $bundle = $1; | |
5216 | } | |
5217 | ||
5218 | if ($bundle) { | |
5219 | $id = $CPAN::META->instance('CPAN::Bundle',$mod); | |
5220 | # Let's make it a module too, because bundles have so much | |
5221 | # in common with modules. | |
6d29edf5 JH |
5222 | |
5223 | # Changed in 1.57_63: seems like memory bloat now without | |
5224 | # any value, so commented out | |
5225 | ||
f04ea8d1 | 5226 | # $CPAN::META->instance('CPAN::Module',$mod); |
c356248b | 5227 | |
f04ea8d1 | 5228 | } else { |
c356248b | 5229 | |
f04ea8d1 SP |
5230 | # instantiate a module object |
5231 | $id = $CPAN::META->instance('CPAN::Module',$mod); | |
c4d24d4c | 5232 | |
f04ea8d1 | 5233 | } |
5f05dabc | 5234 | |
ec5fee46 A |
5235 | # Although CPAN prohibits same name with different version the |
5236 | # indexer may have changed the version for the same distro | |
5237 | # since the last time ("Force Reindexing" feature) | |
f04ea8d1 | 5238 | if ($id->cpan_file ne $dist |
ec5fee46 A |
5239 | || |
5240 | $id->cpan_version ne $version | |
f04ea8d1 SP |
5241 | ) { |
5242 | $userid = $id->userid || $self->userid($dist); | |
5243 | $id->set( | |
5244 | 'CPAN_USERID' => $userid, | |
5245 | 'CPAN_VERSION' => $version, | |
5246 | 'CPAN_FILE' => $dist, | |
5247 | ); | |
5248 | } | |
5249 | ||
5250 | # instantiate a distribution object | |
5251 | if ($CPAN::META->exists('CPAN::Distribution',$dist)) { | |
5252 | # we do not need CONTAINSMODS unless we do something with | |
5253 | # this dist, so we better produce it on demand. | |
5254 | ||
5255 | ## my $obj = $CPAN::META->instance( | |
5256 | ## 'CPAN::Distribution' => $dist | |
5257 | ## ); | |
5258 | ## $obj->{CONTAINSMODS}{$mod} = undef; # experimental | |
5259 | } else { | |
5260 | $CPAN::META->instance( | |
5261 | 'CPAN::Distribution' => $dist | |
5262 | )->set( | |
5263 | 'CPAN_USERID' => $userid, | |
5264 | 'CPAN_COMMENT' => $comment, | |
5265 | ); | |
5266 | } | |
c4d24d4c A |
5267 | if ($secondtime) { |
5268 | for my $name ($mod,$dist) { | |
7d97ad34 | 5269 | # $self->debug("exists name[$name]") if $CPAN::DEBUG; |
c4d24d4c A |
5270 | $exists{$name} = undef; |
5271 | } | |
5272 | } | |
be34b10d SP |
5273 | $i++; |
5274 | while (($painted/76) < ($i/@lines)) { | |
5275 | $CPAN::Frontend->myprint("."); | |
5276 | $painted++; | |
5277 | } | |
f04ea8d1 | 5278 | return if $CPAN::Signal; |
5f05dabc | 5279 | } |
7d97ad34 | 5280 | $CPAN::Frontend->myprint("DONE\n"); |
c4d24d4c A |
5281 | if ($secondtime) { |
5282 | for my $class (qw(CPAN::Module CPAN::Bundle CPAN::Distribution)) { | |
5283 | for my $o ($CPAN::META->all_objects($class)) { | |
5284 | next if exists $exists{$o->{ID}}; | |
5285 | $CPAN::META->delete($class,$o->{ID}); | |
7d97ad34 SP |
5286 | # CPAN->debug("deleting ID[$o->{ID}] in class[$class]") |
5287 | # if $CPAN::DEBUG; | |
c4d24d4c A |
5288 | } |
5289 | } | |
5290 | } | |
5f05dabc | 5291 | } |
5292 | ||
55e314ee A |
5293 | #-> sub CPAN::Index::rd_modlist ; |
5294 | sub rd_modlist { | |
05454584 | 5295 | my($cl,$index_target) = @_; |
c356248b | 5296 | return unless defined $index_target; |
810a0276 | 5297 | return if CPAN::_sqlite_running; |
c356248b | 5298 | $CPAN::Frontend->myprint("Going to read $index_target\n"); |
09d9d230 | 5299 | my $fh = CPAN::Tarzip->TIEHANDLE($index_target); |
e82b9348 | 5300 | local $_; |
7d97ad34 SP |
5301 | my $slurp = ""; |
5302 | my $chunk; | |
5303 | while (my $bytes = $fh->READ(\$chunk,8192)) { | |
5304 | $slurp.=$chunk; | |
5305 | } | |
5306 | my @eval2 = split /\012/, $slurp; | |
5307 | ||
5308 | while (@eval2) { | |
f04ea8d1 SP |
5309 | my $shift = shift(@eval2); |
5310 | if ($shift =~ /^Date:\s+(.*)/) { | |
5311 | if ($DATE_OF_03 eq $1) { | |
7d97ad34 SP |
5312 | $CPAN::Frontend->myprint("Unchanged.\n"); |
5313 | return; | |
5314 | } | |
f04ea8d1 SP |
5315 | ($DATE_OF_03) = $1; |
5316 | } | |
5317 | last if $shift =~ /^\s*$/; | |
05454584 | 5318 | } |
7d97ad34 | 5319 | push @eval2, q{CPAN::Modulelist->data;}; |
05454584 A |
5320 | local($^W) = 0; |
5321 | my($comp) = Safe->new("CPAN::Safe1"); | |
7d97ad34 SP |
5322 | my($eval2) = join("\n", @eval2); |
5323 | CPAN->debug(sprintf "length of eval2[%d]", length $eval2) if $CPAN::DEBUG; | |
5324 | my $ret = $comp->reval($eval2); | |
05454584 A |
5325 | Carp::confess($@) if $@; |
5326 | return if $CPAN::Signal; | |
7d97ad34 | 5327 | my $i = 0; |
be34b10d SP |
5328 | my $until = keys(%$ret); |
5329 | my $painted = 0; | |
7d97ad34 | 5330 | CPAN->debug(sprintf "until[%d]", $until) if $CPAN::DEBUG; |
05454584 | 5331 | for (keys %$ret) { |
f04ea8d1 | 5332 | my $obj = $CPAN::META->instance("CPAN::Module",$_); |
6d29edf5 | 5333 | delete $ret->{$_}{modid}; # not needed here, maybe elsewhere |
f04ea8d1 | 5334 | $obj->set(%{$ret->{$_}}); |
be34b10d SP |
5335 | $i++; |
5336 | while (($painted/76) < ($i/$until)) { | |
5337 | $CPAN::Frontend->myprint("."); | |
5338 | $painted++; | |
5339 | } | |
f04ea8d1 | 5340 | return if $CPAN::Signal; |
05454584 | 5341 | } |
7d97ad34 | 5342 | $CPAN::Frontend->myprint("DONE\n"); |
05454584 | 5343 | } |
5f05dabc | 5344 | |
5e05dca5 A |
5345 | #-> sub CPAN::Index::write_metadata_cache ; |
5346 | sub write_metadata_cache { | |
5347 | my($self) = @_; | |
5348 | return unless $CPAN::Config->{'cache_metadata'}; | |
810a0276 | 5349 | return if CPAN::_sqlite_running; |
5e05dca5 A |
5350 | return unless $CPAN::META->has_usable("Storable"); |
5351 | my $cache; | |
5352 | foreach my $k (qw(CPAN::Bundle CPAN::Author CPAN::Module | |
f04ea8d1 SP |
5353 | CPAN::Distribution)) { |
5354 | $cache->{$k} = $CPAN::META->{readonly}{$k}; # unsafe meta access, ok | |
5e05dca5 | 5355 | } |
5de3f0da | 5356 | my $metadata_file = File::Spec->catfile($CPAN::Config->{cpan_home},"Metadata"); |
c049f953 JH |
5357 | $cache->{last_time} = $LAST_TIME; |
5358 | $cache->{DATE_OF_02} = $DATE_OF_02; | |
6d29edf5 JH |
5359 | $cache->{PROTOCOL} = PROTOCOL; |
5360 | $CPAN::Frontend->myprint("Going to write $metadata_file\n"); | |
c4d24d4c | 5361 | eval { Storable::nstore($cache, $metadata_file) }; |
5fc0f0f6 | 5362 | $CPAN::Frontend->mywarn($@) if $@; # ?? missing "\n" after $@ in mywarn ?? |
5e05dca5 A |
5363 | } |
5364 | ||
5365 | #-> sub CPAN::Index::read_metadata_cache ; | |
5366 | sub read_metadata_cache { | |
5367 | my($self) = @_; | |
5368 | return unless $CPAN::Config->{'cache_metadata'}; | |
810a0276 | 5369 | return if CPAN::_sqlite_running; |
5e05dca5 | 5370 | return unless $CPAN::META->has_usable("Storable"); |
5de3f0da | 5371 | my $metadata_file = File::Spec->catfile($CPAN::Config->{cpan_home},"Metadata"); |
5e05dca5 A |
5372 | return unless -r $metadata_file and -f $metadata_file; |
5373 | $CPAN::Frontend->myprint("Going to read $metadata_file\n"); | |
5374 | my $cache; | |
5375 | eval { $cache = Storable::retrieve($metadata_file) }; | |
5fc0f0f6 | 5376 | $CPAN::Frontend->mywarn($@) if $@; # ?? missing "\n" after $@ in mywarn ?? |
f04ea8d1 | 5377 | if (!$cache || !UNIVERSAL::isa($cache, 'HASH')) { |
c049f953 | 5378 | $LAST_TIME = 0; |
6d29edf5 JH |
5379 | return; |
5380 | } | |
5381 | if (exists $cache->{PROTOCOL}) { | |
5382 | if (PROTOCOL > $cache->{PROTOCOL}) { | |
5383 | $CPAN::Frontend->mywarn(sprintf("Ignoring Metadata cache written ". | |
5fc0f0f6 | 5384 | "with protocol v%s, requiring v%s\n", |
6d29edf5 JH |
5385 | $cache->{PROTOCOL}, |
5386 | PROTOCOL) | |
5387 | ); | |
5388 | return; | |
5389 | } | |
5390 | } else { | |
5391 | $CPAN::Frontend->mywarn("Ignoring Metadata cache written ". | |
5fc0f0f6 | 5392 | "with protocol v1.0\n"); |
6d29edf5 JH |
5393 | return; |
5394 | } | |
5395 | my $clcnt = 0; | |
5396 | my $idcnt = 0; | |
5397 | while(my($class,$v) = each %$cache) { | |
f04ea8d1 SP |
5398 | next unless $class =~ /^CPAN::/; |
5399 | $CPAN::META->{readonly}{$class} = $v; # unsafe meta access, ok | |
6d29edf5 JH |
5400 | while (my($id,$ro) = each %$v) { |
5401 | $CPAN::META->{readwrite}{$class}{$id} ||= | |
5402 | $class->new(ID=>$id, RO=>$ro); | |
5403 | $idcnt++; | |
c4d24d4c | 5404 | } |
6d29edf5 | 5405 | $clcnt++; |
5e05dca5 | 5406 | } |
6d29edf5 JH |
5407 | unless ($clcnt) { # sanity check |
5408 | $CPAN::Frontend->myprint("Warning: Found no data in $metadata_file\n"); | |
5409 | return; | |
5410 | } | |
5411 | if ($idcnt < 1000) { | |
5412 | $CPAN::Frontend->myprint("Warning: Found only $idcnt objects ". | |
5413 | "in $metadata_file\n"); | |
5414 | return; | |
5415 | } | |
5416 | $CPAN::META->{PROTOCOL} ||= | |
5417 | $cache->{PROTOCOL}; # reading does not up or downgrade, but it | |
5418 | # does initialize to some protocol | |
c049f953 JH |
5419 | $LAST_TIME = $cache->{last_time}; |
5420 | $DATE_OF_02 = $cache->{DATE_OF_02}; | |
d5a05a34 | 5421 | $CPAN::Frontend->myprint(" Database was generated on $DATE_OF_02\n") |
f04ea8d1 | 5422 | if defined $DATE_OF_02; # An old cache may not contain DATE_OF_02 |
c049f953 | 5423 | return; |
5e05dca5 A |
5424 | } |
5425 | ||
05454584 | 5426 | package CPAN::InfoObj; |
e82b9348 | 5427 | use strict; |
5f05dabc | 5428 | |
0cf35e6a SP |
5429 | sub ro { |
5430 | my $self = shift; | |
5431 | exists $self->{RO} and return $self->{RO}; | |
5432 | } | |
5433 | ||
6658a91b | 5434 | #-> sub CPAN::InfoObj::cpan_userid |
35576f8c A |
5435 | sub cpan_userid { |
5436 | my $self = shift; | |
6658a91b SP |
5437 | my $ro = $self->ro; |
5438 | if ($ro) { | |
5439 | return $ro->{CPAN_USERID} || "N/A"; | |
5440 | } else { | |
5441 | $self->debug("ID[$self->{ID}]"); | |
5442 | # N/A for bundles found locally | |
5443 | return "N/A"; | |
5444 | } | |
35576f8c A |
5445 | } |
5446 | ||
c049f953 | 5447 | sub id { shift->{ID}; } |
6d29edf5 | 5448 | |
05454584 | 5449 | #-> sub CPAN::InfoObj::new ; |
6d29edf5 JH |
5450 | sub new { |
5451 | my $this = bless {}, shift; | |
5452 | %$this = @_; | |
5453 | $this | |
5454 | } | |
5455 | ||
5456 | # The set method may only be used by code that reads index data or | |
5457 | # otherwise "objective" data from the outside world. All session | |
5458 | # related material may do anything else with instance variables but | |
5459 | # must not touch the hash under the RO attribute. The reason is that | |
5460 | # the RO hash gets written to Metadata file and is thus persistent. | |
5f05dabc | 5461 | |
b96578bb SP |
5462 | #-> sub CPAN::InfoObj::safe_chdir ; |
5463 | sub safe_chdir { | |
5464 | my($self,$todir) = @_; | |
5465 | # we die if we cannot chdir and we are debuggable | |
5466 | Carp::confess("safe_chdir called without todir argument") | |
5467 | unless defined $todir and length $todir; | |
5468 | if (chdir $todir) { | |
5469 | $self->debug(sprintf "changed directory to %s", CPAN::anycwd()) | |
5470 | if $CPAN::DEBUG; | |
5471 | } else { | |
5472 | if (-e $todir) { | |
5473 | unless (-x $todir) { | |
5474 | unless (chmod 0755, $todir) { | |
5475 | my $cwd = CPAN::anycwd(); | |
5476 | $CPAN::Frontend->mywarn("I have neither the -x permission nor the ". | |
5477 | "permission to change the permission; cannot ". | |
5478 | "chdir to '$todir'\n"); | |
5479 | $CPAN::Frontend->mysleep(5); | |
5480 | $CPAN::Frontend->mydie(qq{Could not chdir from cwd[$cwd] }. | |
5481 | qq{to todir[$todir]: $!}); | |
5482 | } | |
5483 | } | |
5484 | } else { | |
5485 | $CPAN::Frontend->mydie("Directory '$todir' has gone. Cannot continue.\n"); | |
5486 | } | |
5487 | if (chdir $todir) { | |
5488 | $self->debug(sprintf "changed directory to %s", CPAN::anycwd()) | |
5489 | if $CPAN::DEBUG; | |
5490 | } else { | |
5491 | my $cwd = CPAN::anycwd(); | |
5492 | $CPAN::Frontend->mydie(qq{Could not chdir from cwd[$cwd] }. | |
5493 | qq{to todir[$todir] (a chmod has been issued): $!}); | |
5494 | } | |
5495 | } | |
5496 | } | |
5497 | ||
05454584 A |
5498 | #-> sub CPAN::InfoObj::set ; |
5499 | sub set { | |
5500 | my($self,%att) = @_; | |
6d29edf5 JH |
5501 | my $class = ref $self; |
5502 | ||
5503 | # This must be ||=, not ||, because only if we write an empty | |
5504 | # reference, only then the set method will write into the readonly | |
5505 | # area. But for Distributions that spring into existence, maybe | |
5506 | # because of a typo, we do not like it that they are written into | |
5507 | # the readonly area and made permanent (at least for a while) and | |
5508 | # that is why we do not "allow" other places to call ->set. | |
8d97e4a1 JH |
5509 | unless ($self->id) { |
5510 | CPAN->debug("Bug? Empty ID, rejecting"); | |
5511 | return; | |
5512 | } | |
6d29edf5 JH |
5513 | my $ro = $self->{RO} = |
5514 | $CPAN::META->{readonly}{$class}{$self->id} ||= {}; | |
da199366 | 5515 | |
6d29edf5 JH |
5516 | while (my($k,$v) = each %att) { |
5517 | $ro->{$k} = $v; | |
5518 | } | |
5519 | } | |
5f05dabc | 5520 | |
05454584 A |
5521 | #-> sub CPAN::InfoObj::as_glimpse ; |
5522 | sub as_glimpse { | |
5f05dabc | 5523 | my($self) = @_; |
05454584 A |
5524 | my(@m); |
5525 | my $class = ref($self); | |
5526 | $class =~ s/^CPAN:://; | |
135a59c2 A |
5527 | my $id = $self->can("pretty_id") ? $self->pretty_id : $self->{ID}; |
5528 | push @m, sprintf "%-15s %s\n", $class, $id; | |
05454584 | 5529 | join "", @m; |
5f05dabc | 5530 | } |
5531 | ||
05454584 A |
5532 | #-> sub CPAN::InfoObj::as_string ; |
5533 | sub as_string { | |
5534 | my($self) = @_; | |
5535 | my(@m); | |
5536 | my $class = ref($self); | |
5537 | $class =~ s/^CPAN:://; | |
5538 | push @m, $class, " id = $self->{ID}\n"; | |
4d1321a7 A |
5539 | my $ro; |
5540 | unless ($ro = $self->ro) { | |
8fc516fe SP |
5541 | if (substr($self->{ID},-1,1) eq ".") { # directory |
5542 | $ro = +{}; | |
5543 | } else { | |
f04ea8d1 SP |
5544 | $CPAN::Frontend->mywarn("Unknown object $self->{ID}\n"); |
5545 | $CPAN::Frontend->mysleep(5); | |
5546 | return; | |
8fc516fe | 5547 | } |
4d1321a7 | 5548 | } |
0cf35e6a | 5549 | for (sort keys %$ro) { |
f04ea8d1 SP |
5550 | # next if m/^(ID|RO)$/; |
5551 | my $extra = ""; | |
5552 | if ($_ eq "CPAN_USERID") { | |
4d1321a7 A |
5553 | $extra .= " ("; |
5554 | $extra .= $self->fullname; | |
9d61fa1d A |
5555 | my $email; # old perls! |
5556 | if ($email = $CPAN::META->instance("CPAN::Author", | |
5557 | $self->cpan_userid | |
5558 | )->email) { | |
5559 | $extra .= " <$email>"; | |
5560 | } else { | |
5561 | $extra .= " <no email>"; | |
5562 | } | |
5563 | $extra .= ")"; | |
5564 | } elsif ($_ eq "FULLNAME") { # potential UTF-8 conversion | |
5565 | push @m, sprintf " %-12s %s\n", $_, $self->fullname; | |
5566 | next; | |
5567 | } | |
0cf35e6a SP |
5568 | next unless defined $ro->{$_}; |
5569 | push @m, sprintf " %-12s %s%s\n", $_, $ro->{$_}, $extra; | |
6d29edf5 | 5570 | } |
8fc516fe | 5571 | KEY: for (sort keys %$self) { |
f04ea8d1 | 5572 | next if m/^(ID|RO)$/; |
8fc516fe SP |
5573 | unless (defined $self->{$_}) { |
5574 | delete $self->{$_}; | |
5575 | next KEY; | |
5576 | } | |
f04ea8d1 SP |
5577 | if (ref($self->{$_}) eq "ARRAY") { |
5578 | push @m, sprintf " %-12s %s\n", $_, "@{$self->{$_}}"; | |
5579 | } elsif (ref($self->{$_}) eq "HASH") { | |
8fc516fe SP |
5580 | my $value; |
5581 | if (/^CONTAINSMODS$/) { | |
5582 | $value = join(" ",sort keys %{$self->{$_}}); | |
5583 | } elsif (/^prereq_pm$/) { | |
5584 | my @value; | |
5585 | my $v = $self->{$_}; | |
5586 | for my $x (sort keys %$v) { | |
5587 | my @svalue; | |
5588 | for my $y (sort keys %{$v->{$x}}) { | |
5589 | push @svalue, "$y=>$v->{$x}{$y}"; | |
5590 | } | |
05bab18e | 5591 | push @value, "$x\:" . join ",", @svalue if @svalue; |
8fc516fe SP |
5592 | } |
5593 | $value = join ";", @value; | |
5594 | } else { | |
5595 | $value = $self->{$_}; | |
5596 | } | |
f04ea8d1 SP |
5597 | push @m, sprintf( |
5598 | " %-12s %s\n", | |
5599 | $_, | |
5600 | $value, | |
5601 | ); | |
5602 | } else { | |
5603 | push @m, sprintf " %-12s %s\n", $_, $self->{$_}; | |
5604 | } | |
5f05dabc | 5605 | } |
05454584 | 5606 | join "", @m, "\n"; |
5f05dabc | 5607 | } |
5608 | ||
4d1321a7 A |
5609 | #-> sub CPAN::InfoObj::fullname ; |
5610 | sub fullname { | |
05454584 | 5611 | my($self) = @_; |
9d61fa1d | 5612 | $CPAN::META->instance("CPAN::Author",$self->cpan_userid)->fullname; |
5f05dabc | 5613 | } |
5614 | ||
6d29edf5 | 5615 | #-> sub CPAN::InfoObj::dump ; |
36263cb3 | 5616 | sub dump { |
f04ea8d1 SP |
5617 | my($self, $what) = @_; |
5618 | unless ($CPAN::META->has_inst("Data::Dumper")) { | |
5619 | $CPAN::Frontend->mydie("dump command requires Data::Dumper installed"); | |
5620 | } | |
5621 | local $Data::Dumper::Sortkeys; | |
5622 | $Data::Dumper::Sortkeys = 1; | |
5623 | my $out = Data::Dumper::Dumper($what ? eval $what : $self); | |
5624 | if (length $out > 100000) { | |
5625 | my $fh_pager = FileHandle->new; | |
5626 | local($SIG{PIPE}) = "IGNORE"; | |
5627 | my $pager = $CPAN::Config->{'pager'} || "cat"; | |
5628 | $fh_pager->open("|$pager") | |
5629 | or die "Could not open pager $pager\: $!"; | |
5630 | $fh_pager->print($out); | |
5631 | close $fh_pager; | |
5632 | } else { | |
5633 | $CPAN::Frontend->myprint($out); | |
5634 | } | |
36263cb3 GS |
5635 | } |
5636 | ||
05454584 | 5637 | package CPAN::Author; |
e82b9348 | 5638 | use strict; |
05454584 | 5639 | |
9ddc4ed0 A |
5640 | #-> sub CPAN::Author::force |
5641 | sub force { | |
5642 | my $self = shift; | |
5643 | $self->{force}++; | |
5644 | } | |
5645 | ||
5646 | #-> sub CPAN::Author::force | |
5647 | sub unforce { | |
5648 | my $self = shift; | |
5649 | delete $self->{force}; | |
5650 | } | |
5651 | ||
c049f953 JH |
5652 | #-> sub CPAN::Author::id |
5653 | sub id { | |
5654 | my $self = shift; | |
5655 | my $id = $self->{ID}; | |
5656 | $CPAN::Frontend->mydie("Illegal author id[$id]") unless $id =~ /^[A-Z]/; | |
5657 | $id; | |
5658 | } | |
5659 | ||
05454584 A |
5660 | #-> sub CPAN::Author::as_glimpse ; |
5661 | sub as_glimpse { | |
5f05dabc | 5662 | my($self) = @_; |
05454584 A |
5663 | my(@m); |
5664 | my $class = ref($self); | |
5665 | $class =~ s/^CPAN:://; | |
c049f953 JH |
5666 | push @m, sprintf(qq{%-15s %s ("%s" <%s>)\n}, |
5667 | $class, | |
5668 | $self->{ID}, | |
5669 | $self->fullname, | |
5670 | $self->email); | |
05454584 | 5671 | join "", @m; |
5f05dabc | 5672 | } |
5673 | ||
05454584 | 5674 | #-> sub CPAN::Author::fullname ; |
9d61fa1d | 5675 | sub fullname { |
0cf35e6a | 5676 | shift->ro->{FULLNAME}; |
9d61fa1d | 5677 | } |
05454584 | 5678 | *name = \&fullname; |
36263cb3 | 5679 | |
05454584 | 5680 | #-> sub CPAN::Author::email ; |
0cf35e6a | 5681 | sub email { shift->ro->{EMAIL}; } |
8d97e4a1 | 5682 | |
d8773709 | 5683 | #-> sub CPAN::Author::ls ; |
8d97e4a1 JH |
5684 | sub ls { |
5685 | my $self = shift; | |
e82b9348 | 5686 | my $glob = shift || ""; |
554a9ef5 | 5687 | my $silent = shift || 0; |
8d97e4a1 JH |
5688 | my $id = $self->id; |
5689 | ||
e82b9348 | 5690 | # adapted from CPAN::Distribution::verifyCHECKSUM ; |
c049f953 JH |
5691 | my(@csf); # chksumfile |
5692 | @csf = $self->id =~ /(.)(.)(.*)/; | |
5693 | $csf[1] = join "", @csf[0,1]; | |
554a9ef5 | 5694 | $csf[2] = join "", @csf[1,2]; # ("A","AN","ANDK") |
c049f953 | 5695 | my(@dl); |
554a9ef5 | 5696 | @dl = $self->dir_listing([$csf[0],"CHECKSUMS"], 0, 1); |
c049f953 | 5697 | unless (grep {$_->[2] eq $csf[1]} @dl) { |
f3fe0ae6 | 5698 | $CPAN::Frontend->myprint("Directory $csf[1]/ does not exist\n") unless $silent ; |
c049f953 JH |
5699 | return; |
5700 | } | |
554a9ef5 | 5701 | @dl = $self->dir_listing([@csf[0,1],"CHECKSUMS"], 0, 1); |
c049f953 | 5702 | unless (grep {$_->[2] eq $csf[2]} @dl) { |
f3fe0ae6 | 5703 | $CPAN::Frontend->myprint("Directory $id/ does not exist\n") unless $silent; |
c049f953 JH |
5704 | return; |
5705 | } | |
554a9ef5 | 5706 | @dl = $self->dir_listing([@csf,"CHECKSUMS"], 1, 1); |
e82b9348 | 5707 | if ($glob) { |
4d1321a7 A |
5708 | if ($CPAN::META->has_inst("Text::Glob")) { |
5709 | my $rglob = Text::Glob::glob_to_regex($glob); | |
5710 | @dl = grep { $_->[2] =~ /$rglob/ } @dl; | |
5711 | } else { | |
5712 | $CPAN::Frontend->mydie("Text::Glob not installed, cannot proceed"); | |
5713 | } | |
e82b9348 | 5714 | } |
f04ea8d1 SP |
5715 | unless ($silent >= 2) { |
5716 | $CPAN::Frontend->myprint(join "", map { | |
5717 | sprintf("%8d %10s %s/%s\n", $_->[0], $_->[1], $id, $_->[2]) | |
5718 | } sort { $a->[2] cmp $b->[2] } @dl); | |
5719 | } | |
ca79d794 | 5720 | @dl; |
8d97e4a1 JH |
5721 | } |
5722 | ||
c049f953 | 5723 | # returns an array of arrays, the latter contain (size,mtime,filename) |
d8773709 | 5724 | #-> sub CPAN::Author::dir_listing ; |
8d97e4a1 JH |
5725 | sub dir_listing { |
5726 | my $self = shift; | |
5727 | my $chksumfile = shift; | |
c049f953 | 5728 | my $recursive = shift; |
554a9ef5 | 5729 | my $may_ftp = shift; |
b96578bb | 5730 | |
8d97e4a1 | 5731 | my $lc_want = |
f04ea8d1 SP |
5732 | File::Spec->catfile($CPAN::Config->{keep_source_where}, |
5733 | "authors", "id", @$chksumfile); | |
f3fe0ae6 | 5734 | |
554a9ef5 SP |
5735 | my $fh; |
5736 | ||
5737 | # Purge and refetch old (pre-PGP) CHECKSUMS; they are a security | |
5738 | # hazard. (Without GPG installed they are not that much better, | |
5739 | # though.) | |
5740 | $fh = FileHandle->new; | |
5741 | if (open($fh, $lc_want)) { | |
f04ea8d1 SP |
5742 | my $line = <$fh>; close $fh; |
5743 | unlink($lc_want) unless $line =~ /PGP/; | |
554a9ef5 | 5744 | } |
f3fe0ae6 | 5745 | |
8d97e4a1 | 5746 | local($") = "/"; |
c049f953 | 5747 | # connect "force" argument with "index_expire". |
9ddc4ed0 | 5748 | my $force = $self->{force}; |
c049f953 | 5749 | if (my @stat = stat $lc_want) { |
9ddc4ed0 | 5750 | $force ||= $stat[9] + $CPAN::Config->{index_expire}*86400 <= time; |
c049f953 | 5751 | } |
554a9ef5 SP |
5752 | my $lc_file; |
5753 | if ($may_ftp) { | |
5754 | $lc_file = CPAN::FTP->localize( | |
5755 | "authors/id/@$chksumfile", | |
5756 | $lc_want, | |
5757 | $force, | |
5758 | ); | |
5759 | unless ($lc_file) { | |
5760 | $CPAN::Frontend->myprint("Trying $lc_want.gz\n"); | |
5761 | $chksumfile->[-1] .= ".gz"; | |
5762 | $lc_file = CPAN::FTP->localize("authors/id/@$chksumfile", | |
5763 | "$lc_want.gz",1); | |
5764 | if ($lc_file) { | |
5765 | $lc_file =~ s{\.gz(?!\n)\Z}{}; #}; | |
be34b10d | 5766 | eval{CPAN::Tarzip->new("$lc_file.gz")->gunzip($lc_file)}; |
554a9ef5 SP |
5767 | } else { |
5768 | return; | |
5769 | } | |
5770 | } | |
5771 | } else { | |
5772 | $lc_file = $lc_want; | |
5773 | # we *could* second-guess and if the user has a file: URL, | |
5774 | # then we could look there. But on the other hand, if they do | |
5775 | # have a file: URL, wy did they choose to set | |
5776 | # $CPAN::Config->{show_upload_date} to false? | |
8d97e4a1 JH |
5777 | } |
5778 | ||
e82b9348 | 5779 | # adapted from CPAN::Distribution::CHECKSUM_check_file ; |
554a9ef5 | 5780 | $fh = FileHandle->new; |
8d97e4a1 | 5781 | my($cksum); |
f04ea8d1 SP |
5782 | if (open $fh, $lc_file) { |
5783 | local($/); | |
5784 | my $eval = <$fh>; | |
5785 | $eval =~ s/\015?\012/\n/g; | |
5786 | close $fh; | |
5787 | my($comp) = Safe->new(); | |
5788 | $cksum = $comp->reval($eval); | |
5789 | if ($@) { | |
5790 | rename $lc_file, "$lc_file.bad"; | |
5791 | Carp::confess($@) if $@; | |
5792 | } | |
554a9ef5 | 5793 | } elsif ($may_ftp) { |
f04ea8d1 | 5794 | Carp::carp "Could not open '$lc_file' for reading."; |
8d97e4a1 | 5795 | } else { |
554a9ef5 | 5796 | # Maybe should warn: "You may want to set show_upload_date to a true value" |
f04ea8d1 | 5797 | return; |
8d97e4a1 JH |
5798 | } |
5799 | my(@result,$f); | |
5800 | for $f (sort keys %$cksum) { | |
5801 | if (exists $cksum->{$f}{isdir}) { | |
c049f953 JH |
5802 | if ($recursive) { |
5803 | my(@dir) = @$chksumfile; | |
5804 | pop @dir; | |
5805 | push @dir, $f, "CHECKSUMS"; | |
5806 | push @result, map { | |
5807 | [$_->[0], $_->[1], "$f/$_->[2]"] | |
554a9ef5 | 5808 | } $self->dir_listing(\@dir,1,$may_ftp); |
c049f953 JH |
5809 | } else { |
5810 | push @result, [ 0, "-", $f ]; | |
5811 | } | |
8d97e4a1 JH |
5812 | } else { |
5813 | push @result, [ | |
5814 | ($cksum->{$f}{"size"}||0), | |
5815 | $cksum->{$f}{"mtime"}||"---", | |
5816 | $f | |
5817 | ]; | |
5818 | } | |
5819 | } | |
5820 | @result; | |
5821 | } | |
5f05dabc | 5822 | |
dc053c64 SP |
5823 | #-> sub CPAN::Author::reports |
5824 | sub reports { | |
5825 | $CPAN::Frontend->mywarn("reports on authors not implemented. | |
5826 | Please file a bugreport if you need this.\n"); | |
5827 | } | |
5828 | ||
05454584 | 5829 | package CPAN::Distribution; |
e82b9348 | 5830 | use strict; |
5f05dabc | 5831 | |
6d29edf5 | 5832 | # Accessors |
e8a27a4e A |
5833 | sub cpan_comment { |
5834 | my $self = shift; | |
5835 | my $ro = $self->ro or return; | |
5836 | $ro->{CPAN_COMMENT} | |
5837 | } | |
6d29edf5 | 5838 | |
dc053c64 | 5839 | #-> CPAN::Distribution::undelay |
6d29edf5 JH |
5840 | sub undelay { |
5841 | my $self = shift; | |
f04ea8d1 SP |
5842 | for my $delayer ( |
5843 | "configure_requires_later", | |
5844 | "configure_requires_later_for", | |
5845 | "later", | |
5846 | "later_for", | |
5847 | ) { | |
5848 | delete $self->{$delayer}; | |
5849 | } | |
6d29edf5 JH |
5850 | } |
5851 | ||
dc053c64 SP |
5852 | #-> CPAN::Distribution::is_dot_dist |
5853 | sub is_dot_dist { | |
5854 | my($self) = @_; | |
8ce4ea0b | 5855 | return substr($self->id,-1,1) eq "."; |
dc053c64 SP |
5856 | } |
5857 | ||
e8a27a4e | 5858 | # add the A/AN/ stuff |
dc053c64 | 5859 | #-> CPAN::Distribution::normalize |
8d97e4a1 JH |
5860 | sub normalize { |
5861 | my($self,$s) = @_; | |
d8773709 | 5862 | $s = $self->id unless defined $s; |
8fc516fe | 5863 | if (substr($s,-1,1) eq ".") { |
05bab18e SP |
5864 | # using a global because we are sometimes called as static method |
5865 | if (!$CPAN::META->{LOCK} | |
5866 | && !$CPAN::Have_warned->{"$s is unlocked"}++ | |
5867 | ) { | |
5868 | $CPAN::Frontend->mywarn("You are visiting the local directory | |
5869 | '$s' | |
5870 | without lock, take care that concurrent processes do not do likewise.\n"); | |
5871 | $CPAN::Frontend->mysleep(1); | |
5872 | } | |
8fc516fe SP |
5873 | if ($s eq ".") { |
5874 | $s = "$CPAN::iCwd/."; | |
5875 | } elsif (File::Spec->file_name_is_absolute($s)) { | |
5876 | } elsif (File::Spec->can("rel2abs")) { | |
5877 | $s = File::Spec->rel2abs($s); | |
5878 | } else { | |
5879 | $CPAN::Frontend->mydie("Your File::Spec is too old, please upgrade File::Spec"); | |
5880 | } | |
5881 | CPAN->debug("s[$s]") if $CPAN::DEBUG; | |
5882 | unless ($CPAN::META->exists("CPAN::Distribution", $s)) { | |
5883 | for ($CPAN::META->instance("CPAN::Distribution", $s)) { | |
5884 | $_->{build_dir} = $s; | |
5885 | $_->{archived} = "local_directory"; | |
6658a91b | 5886 | $_->{unwrapped} = CPAN::Distrostatus->new("YES -- local_directory"); |
8fc516fe SP |
5887 | } |
5888 | } | |
5889 | } elsif ( | |
c049f953 JH |
5890 | $s =~ tr|/|| == 1 |
5891 | or | |
5892 | $s !~ m|[A-Z]/[A-Z-]{2}/[A-Z-]{2,}/| | |
5893 | ) { | |
5894 | return $s if $s =~ m:^N/A|^Contact Author: ; | |
8d97e4a1 | 5895 | $s =~ s|^(.)(.)([^/]*/)(.+)$|$1/$1$2/$1$2$3$4| or |
5fc0f0f6 | 5896 | $CPAN::Frontend->mywarn("Strange distribution name [$s]\n"); |
8d97e4a1 JH |
5897 | CPAN->debug("s[$s]") if $CPAN::DEBUG; |
5898 | } | |
5899 | $s; | |
5900 | } | |
5901 | ||
4d1321a7 A |
5902 | #-> sub CPAN::Distribution::author ; |
5903 | sub author { | |
5904 | my($self) = @_; | |
6658a91b SP |
5905 | my($authorid); |
5906 | if (substr($self->id,-1,1) eq ".") { | |
5907 | $authorid = "LOCAL"; | |
5908 | } else { | |
5909 | ($authorid) = $self->pretty_id =~ /^([\w\-]+)/; | |
5910 | } | |
4d1321a7 A |
5911 | CPAN::Shell->expand("Author",$authorid); |
5912 | } | |
5913 | ||
5914 | # tries to get the yaml from CPAN instead of the distro itself: | |
5915 | # EXPERIMENTAL, UNDOCUMENTED AND UNTESTED, for Tels | |
5916 | sub fast_yaml { | |
5917 | my($self) = @_; | |
5918 | my $meta = $self->pretty_id; | |
5919 | $meta =~ s/\.(tar.gz|tgz|zip|tar.bz2)/.meta/; | |
5920 | my(@ls) = CPAN::Shell->globls($meta); | |
5921 | my $norm = $self->normalize($meta); | |
5922 | ||
5923 | my($local_file); | |
5924 | my($local_wanted) = | |
5925 | File::Spec->catfile( | |
f04ea8d1 SP |
5926 | $CPAN::Config->{keep_source_where}, |
5927 | "authors", | |
5928 | "id", | |
5929 | split(/\//,$norm) | |
5930 | ); | |
4d1321a7 A |
5931 | $self->debug("Doing localize") if $CPAN::DEBUG; |
5932 | unless ($local_file = | |
5933 | CPAN::FTP->localize("authors/id/$norm", | |
5934 | $local_wanted)) { | |
5935 | $CPAN::Frontend->mydie("Giving up on downloading yaml file '$local_wanted'\n"); | |
5936 | } | |
6658a91b SP |
5937 | my $yaml = CPAN->_yaml_loadfile($local_file)->[0]; |
5938 | } | |
5939 | ||
5940 | #-> sub CPAN::Distribution::cpan_userid | |
5941 | sub cpan_userid { | |
5942 | my $self = shift; | |
5943 | if ($self->{ID} =~ m{[A-Z]/[A-Z\-]{2}/([A-Z\-]+)/}) { | |
5944 | return $1; | |
5945 | } | |
5946 | return $self->SUPER::cpan_userid; | |
4d1321a7 A |
5947 | } |
5948 | ||
135a59c2 | 5949 | #-> sub CPAN::Distribution::pretty_id |
e8a27a4e A |
5950 | sub pretty_id { |
5951 | my $self = shift; | |
5952 | my $id = $self->id; | |
5953 | return $id unless $id =~ m|^./../|; | |
5954 | substr($id,5); | |
5955 | } | |
5956 | ||
f04ea8d1 SP |
5957 | #-> sub CPAN::Distribution::base_id |
5958 | sub base_id { | |
5959 | my $self = shift; | |
5960 | my $id = $self->pretty_id(); | |
5961 | my $base_id = File::Basename::basename($id); | |
5962 | $base_id =~ s{\.(?:tar\.(bz2|gz|Z)|t(?:gz|bz)|zip)$}{}i; | |
5963 | return $base_id; | |
5964 | } | |
5965 | ||
f20de9f0 SP |
5966 | # mark as dirty/clean for the sake of recursion detection. $color=1 |
5967 | # means "in use", $color=0 means "not in use anymore". $color=2 means | |
5968 | # we have determined prereqs now and thus insist on passing this | |
5969 | # through (at least) once again. | |
5970 | ||
6d29edf5 JH |
5971 | #-> sub CPAN::Distribution::color_cmd_tmps ; |
5972 | sub color_cmd_tmps { | |
5973 | my($self) = shift; | |
5974 | my($depth) = shift || 0; | |
5975 | my($color) = shift || 0; | |
35576f8c | 5976 | my($ancestors) = shift || []; |
6d29edf5 JH |
5977 | # a distribution needs to recurse into its prereq_pms |
5978 | ||
5979 | return if exists $self->{incommandcolor} | |
f20de9f0 | 5980 | && $color==1 |
6d29edf5 | 5981 | && $self->{incommandcolor}==$color; |
f04ea8d1 | 5982 | if ($depth>=$CPAN::MAX_RECURSION) { |
ade94d80 | 5983 | die(CPAN::Exception::RecursiveDependency->new($ancestors)); |
35576f8c A |
5984 | } |
5985 | # warn "color_cmd_tmps $depth $color " . $self->id; # sleep 1; | |
6d29edf5 JH |
5986 | my $prereq_pm = $self->prereq_pm; |
5987 | if (defined $prereq_pm) { | |
135a59c2 A |
5988 | PREREQ: for my $pre (keys %{$prereq_pm->{requires}||{}}, |
5989 | keys %{$prereq_pm->{build_requires}||{}}) { | |
7d97ad34 | 5990 | next PREREQ if $pre eq "perl"; |
44d21104 A |
5991 | my $premo; |
5992 | unless ($premo = CPAN::Shell->expand("Module",$pre)) { | |
5993 | $CPAN::Frontend->mywarn("prerequisite module[$pre] not known\n"); | |
5994 | $CPAN::Frontend->mysleep(2); | |
5995 | next PREREQ; | |
5996 | } | |
35576f8c | 5997 | $premo->color_cmd_tmps($depth+1,$color,[@$ancestors, $self->id]); |
6d29edf5 JH |
5998 | } |
5999 | } | |
6000 | if ($color==0) { | |
6001 | delete $self->{sponsored_mods}; | |
b72dd56f SP |
6002 | |
6003 | # as we are at the end of a command, we'll give up this | |
6004 | # reminder of a broken test. Other commands may test this guy | |
6005 | # again. Maybe 'badtestcnt' should be renamed to | |
f20de9f0 | 6006 | # 'make_test_failed_within_command'? |
6d29edf5 JH |
6007 | delete $self->{badtestcnt}; |
6008 | } | |
6009 | $self->{incommandcolor} = $color; | |
6010 | } | |
6011 | ||
911a92db GS |
6012 | #-> sub CPAN::Distribution::as_string ; |
6013 | sub as_string { | |
f04ea8d1 SP |
6014 | my $self = shift; |
6015 | $self->containsmods; | |
6016 | $self->upload_date; | |
6017 | $self->SUPER::as_string(@_); | |
911a92db GS |
6018 | } |
6019 | ||
6020 | #-> sub CPAN::Distribution::containsmods ; | |
6021 | sub containsmods { | |
f04ea8d1 SP |
6022 | my $self = shift; |
6023 | return keys %{$self->{CONTAINSMODS}} if exists $self->{CONTAINSMODS}; | |
6024 | my $dist_id = $self->{ID}; | |
6025 | for my $mod ($CPAN::META->all_objects("CPAN::Module")) { | |
6026 | my $mod_file = $mod->cpan_file or next; | |
6027 | my $mod_id = $mod->{ID} or next; | |
6028 | # warn "mod_file[$mod_file] dist_id[$dist_id] mod_id[$mod_id]"; | |
6029 | # sleep 1; | |
6030 | if ($CPAN::Signal) { | |
6031 | delete $self->{CONTAINSMODS}; | |
6032 | return; | |
6033 | } | |
6034 | $self->{CONTAINSMODS}{$mod_id} = undef if $mod_file eq $dist_id; | |
b72dd56f | 6035 | } |
b03f445c | 6036 | keys %{$self->{CONTAINSMODS}||={}}; |
911a92db GS |
6037 | } |
6038 | ||
554a9ef5 SP |
6039 | #-> sub CPAN::Distribution::upload_date ; |
6040 | sub upload_date { | |
f04ea8d1 SP |
6041 | my $self = shift; |
6042 | return $self->{UPLOAD_DATE} if exists $self->{UPLOAD_DATE}; | |
6043 | my(@local_wanted) = split(/\//,$self->id); | |
6044 | my $filename = pop @local_wanted; | |
6045 | push @local_wanted, "CHECKSUMS"; | |
6046 | my $author = CPAN::Shell->expand("Author",$self->cpan_userid); | |
6047 | return unless $author; | |
6048 | my @dl = $author->dir_listing(\@local_wanted,0,$CPAN::Config->{show_upload_date}); | |
6049 | return unless @dl; | |
6050 | my($dirent) = grep { $_->[2] eq $filename } @dl; | |
6051 | # warn sprintf "dirent[%s]id[%s]", $dirent, $self->id; | |
6052 | return unless $dirent->[1]; | |
6053 | return $self->{UPLOAD_DATE} = $dirent->[1]; | |
554a9ef5 SP |
6054 | } |
6055 | ||
d8773709 JH |
6056 | #-> sub CPAN::Distribution::uptodate ; |
6057 | sub uptodate { | |
6058 | my($self) = @_; | |
6059 | my $c; | |
6060 | foreach $c ($self->containsmods) { | |
6061 | my $obj = CPAN::Shell->expandany($c); | |
f04ea8d1 | 6062 | unless ($obj->uptodate) { |
8962fc49 SP |
6063 | my $id = $self->pretty_id; |
6064 | $self->debug("$id not uptodate due to $c") if $CPAN::DEBUG; | |
6065 | return 0; | |
6066 | } | |
d8773709 JH |
6067 | } |
6068 | return 1; | |
6069 | } | |
6070 | ||
05454584 A |
6071 | #-> sub CPAN::Distribution::called_for ; |
6072 | sub called_for { | |
6073 | my($self,$id) = @_; | |
6d29edf5 JH |
6074 | $self->{CALLED_FOR} = $id if defined $id; |
6075 | return $self->{CALLED_FOR}; | |
5f05dabc | 6076 | } |
6077 | ||
05454584 A |
6078 | #-> sub CPAN::Distribution::get ; |
6079 | sub get { | |
5f05dabc | 6080 | my($self) = @_; |
b72dd56f | 6081 | $self->debug("checking goto id[$self->{ID}]") if $CPAN::DEBUG; |
be34b10d SP |
6082 | if (my $goto = $self->prefs->{goto}) { |
6083 | $CPAN::Frontend->mywarn | |
6084 | (sprintf( | |
6085 | "delegating to '%s' as specified in prefs file '%s' doc %d\n", | |
6086 | $goto, | |
6087 | $self->{prefs_file}, | |
6088 | $self->{prefs_file_doc}, | |
6089 | )); | |
6090 | return $self->goto($goto); | |
6091 | } | |
6658a91b SP |
6092 | local $ENV{PERL5LIB} = defined($ENV{PERL5LIB}) |
6093 | ? $ENV{PERL5LIB} | |
6094 | : ($ENV{PERLLIB} || ""); | |
6095 | ||
6096 | $CPAN::META->set_perl5lib; | |
6097 | local $ENV{MAKEFLAGS}; # protect us from outer make calls | |
6098 | ||
da199366 | 6099 | EXCUSE: { |
f04ea8d1 | 6100 | my @e; |
8ce4ea0b | 6101 | my $goodbye_message; |
b72dd56f | 6102 | $self->debug("checking disabled id[$self->{ID}]") if $CPAN::DEBUG; |
05bab18e | 6103 | if ($self->prefs->{disabled}) { |
810a0276 SP |
6104 | my $why = sprintf( |
6105 | "Disabled via prefs file '%s' doc %d", | |
6106 | $self->{prefs_file}, | |
6107 | $self->{prefs_file_doc}, | |
6108 | ); | |
6109 | push @e, $why; | |
8ce4ea0b SP |
6110 | $self->{unwrapped} = CPAN::Distrostatus->new("NO $why"); |
6111 | $goodbye_message = "[disabled] -- NA $why"; | |
810a0276 SP |
6112 | # note: not intended to be persistent but at least visible |
6113 | # during this session | |
6114 | } else { | |
dc053c64 SP |
6115 | if (exists $self->{build_dir} && -d $self->{build_dir} |
6116 | && ($self->{modulebuild}||$self->{writemakefile}) | |
6117 | ) { | |
b72dd56f SP |
6118 | # this deserves print, not warn: |
6119 | $CPAN::Frontend->myprint(" Has already been unwrapped into directory ". | |
6120 | "$self->{build_dir}\n" | |
6121 | ); | |
23a216b4 | 6122 | return 1; |
b72dd56f | 6123 | } |
6658a91b | 6124 | |
b72dd56f SP |
6125 | # although we talk about 'force' we shall not test on |
6126 | # force directly. New model of force tries to refrain from | |
6127 | # direct checking of force. | |
810a0276 SP |
6128 | exists $self->{unwrapped} and ( |
6129 | UNIVERSAL::can($self->{unwrapped},"failed") ? | |
6130 | $self->{unwrapped}->failed : | |
6131 | $self->{unwrapped} =~ /^NO/ | |
6132 | ) | |
6133 | and push @e, "Unwrapping had some problem, won't try again without force"; | |
6134 | } | |
8ce4ea0b SP |
6135 | if (@e) { |
6136 | $CPAN::Frontend->mywarn(join "", map {"$_\n"} @e); | |
6137 | if ($goodbye_message) { | |
6138 | $self->goodbye($goodbye_message); | |
6139 | } | |
6140 | return; | |
6141 | } | |
da199366 | 6142 | } |
f04ea8d1 SP |
6143 | my $sub_wd = CPAN::anycwd(); # for cleaning up as good as possible |
6144 | ||
6145 | my($local_file); | |
6146 | unless ($self->{build_dir} && -d $self->{build_dir}) { | |
6147 | $self->get_file_onto_local_disk; | |
6148 | return if $CPAN::Signal; | |
6149 | $self->check_integrity; | |
6150 | return if $CPAN::Signal; | |
6151 | (my $packagedir,$local_file) = $self->run_preps_on_packagedir; | |
6152 | $packagedir ||= $self->{build_dir}; | |
6153 | $self->{build_dir} = $packagedir; | |
6154 | } | |
d8773709 | 6155 | |
f04ea8d1 | 6156 | if ($CPAN::Signal) { |
dc053c64 SP |
6157 | $self->safe_chdir($sub_wd); |
6158 | return; | |
6159 | } | |
f04ea8d1 | 6160 | return $self->run_MM_or_MB($local_file); |
dc053c64 SP |
6161 | } |
6162 | ||
6163 | #-> CPAN::Distribution::get_file_onto_local_disk | |
6164 | sub get_file_onto_local_disk { | |
6165 | my($self) = @_; | |
6166 | ||
6167 | return if $self->is_dot_dist; | |
05454584 A |
6168 | my($local_file); |
6169 | my($local_wanted) = | |
5de3f0da | 6170 | File::Spec->catfile( |
f04ea8d1 SP |
6171 | $CPAN::Config->{keep_source_where}, |
6172 | "authors", | |
6173 | "id", | |
6174 | split(/\//,$self->id) | |
6175 | ); | |
05454584 A |
6176 | |
6177 | $self->debug("Doing localize") if $CPAN::DEBUG; | |
c049f953 JH |
6178 | unless ($local_file = |
6179 | CPAN::FTP->localize("authors/id/$self->{ID}", | |
6180 | $local_wanted)) { | |
6181 | my $note = ""; | |
6182 | if ($CPAN::Index::DATE_OF_02) { | |
6183 | $note = "Note: Current database in memory was generated ". | |
6184 | "on $CPAN::Index::DATE_OF_02\n"; | |
6185 | } | |
6186 | $CPAN::Frontend->mydie("Giving up on '$local_wanted'\n$note"); | |
6187 | } | |
6658a91b SP |
6188 | |
6189 | $self->debug("local_wanted[$local_wanted]local_file[$local_file]") if $CPAN::DEBUG; | |
05454584 | 6190 | $self->{localfile} = $local_file; |
dc053c64 | 6191 | } |
05454584 | 6192 | |
dc053c64 SP |
6193 | |
6194 | #-> CPAN::Distribution::check_integrity | |
6195 | sub check_integrity { | |
6196 | my($self) = @_; | |
6197 | ||
6198 | return if $self->is_dot_dist; | |
e82b9348 | 6199 | if ($CPAN::META->has_inst("Digest::SHA")) { |
f04ea8d1 SP |
6200 | $self->debug("Digest::SHA is installed, verifying"); |
6201 | $self->verifyCHECKSUM; | |
55e314ee | 6202 | } else { |
f04ea8d1 | 6203 | $self->debug("Digest::SHA is NOT installed"); |
55e314ee | 6204 | } |
dc053c64 SP |
6205 | } |
6206 | ||
6207 | #-> CPAN::Distribution::run_preps_on_packagedir | |
6208 | sub run_preps_on_packagedir { | |
6209 | my($self) = @_; | |
6210 | return if $self->is_dot_dist; | |
d8773709 | 6211 | |
d8773709 JH |
6212 | $CPAN::META->{cachemgr} ||= CPAN::CacheMgr->new(); # unsafe meta access, ok |
6213 | my $builddir = $CPAN::META->{cachemgr}->dir; # unsafe meta access, ok | |
6214 | $self->safe_chdir($builddir); | |
05bab18e SP |
6215 | $self->debug("Removing tmp-$$") if $CPAN::DEBUG; |
6216 | File::Path::rmtree("tmp-$$"); | |
6217 | unless (mkdir "tmp-$$", 0755) { | |
c9869e1c | 6218 | $CPAN::Frontend->unrecoverable_error(<<EOF); |
05bab18e | 6219 | Couldn't mkdir '$builddir/tmp-$$': $! |
c9869e1c SP |
6220 | |
6221 | Cannot continue: Please find the reason why I cannot make the | |
6222 | directory | |
05bab18e | 6223 | $builddir/tmp-$$ |
c9869e1c SP |
6224 | and fix the problem, then retry. |
6225 | ||
6226 | EOF | |
6227 | } | |
f04ea8d1 | 6228 | if ($CPAN::Signal) { |
d8773709 JH |
6229 | return; |
6230 | } | |
05bab18e | 6231 | $self->safe_chdir("tmp-$$"); |
d8773709 JH |
6232 | |
6233 | # | |
6234 | # Unpack the goods | |
6235 | # | |
dc053c64 | 6236 | my $local_file = $self->{localfile}; |
be34b10d SP |
6237 | my $ct = eval{CPAN::Tarzip->new($local_file)}; |
6238 | unless ($ct) { | |
6239 | $self->{unwrapped} = CPAN::Distrostatus->new("NO"); | |
6240 | delete $self->{build_dir}; | |
6241 | return; | |
6242 | } | |
f04ea8d1 | 6243 | if ($local_file =~ /(\.tar\.(bz2|gz|Z)|\.tgz)(?!\n)\Z/i) { |
be34b10d | 6244 | $self->{was_uncompressed}++ unless eval{$ct->gtest()}; |
f04ea8d1 | 6245 | $self->untar_me($ct); |
05d2a450 | 6246 | } elsif ( $local_file =~ /\.zip(?!\n)\Z/i ) { |
f04ea8d1 | 6247 | $self->unzip_me($ct); |
55e314ee | 6248 | } else { |
ed84aac9 | 6249 | $self->{was_uncompressed}++ unless $ct->gtest(); |
f04ea8d1 | 6250 | $local_file = $self->handle_singlefile($local_file); |
5f05dabc | 6251 | } |
d8773709 JH |
6252 | |
6253 | # we are still in the tmp directory! | |
6254 | # Let's check if the package has its own directory. | |
6255 | my $dh = DirHandle->new(File::Spec->curdir) | |
6256 | or Carp::croak("Couldn't opendir .: $!"); | |
6257 | my @readdir = grep $_ !~ /^\.\.?(?!\n)\Z/s, $dh->read; ### MAC?? | |
6258 | $dh->close; | |
05bab18e SP |
6259 | my ($packagedir); |
6260 | # XXX here we want in each branch File::Temp to protect all build_dir directories | |
b03f445c | 6261 | if (CPAN->has_usable("File::Temp")) { |
05bab18e SP |
6262 | my $tdir_base; |
6263 | my $from_dir; | |
6264 | my @dirents; | |
6265 | if (@readdir == 1 && -d $readdir[0]) { | |
6266 | $tdir_base = $readdir[0]; | |
6267 | $from_dir = File::Spec->catdir(File::Spec->curdir,$readdir[0]); | |
6268 | my $dh2 = DirHandle->new($from_dir) | |
6269 | or Carp::croak("Couldn't opendir $from_dir: $!"); | |
6270 | @dirents = grep $_ !~ /^\.\.?(?!\n)\Z/s, $dh2->read; ### MAC?? | |
6271 | } else { | |
6272 | my $userid = $self->cpan_userid; | |
6273 | CPAN->debug("userid[$userid]"); | |
6274 | if (!$userid or $userid eq "N/A") { | |
6275 | $userid = "anon"; | |
6276 | } | |
6277 | $tdir_base = $userid; | |
6278 | $from_dir = File::Spec->curdir; | |
6279 | @dirents = @readdir; | |
6280 | } | |
6281 | $packagedir = File::Temp::tempdir( | |
6282 | "$tdir_base-XXXXXX", | |
6283 | DIR => $builddir, | |
6284 | CLEANUP => 0, | |
6285 | ); | |
6286 | my $f; | |
6287 | for $f (@dirents) { # is already without "." and ".." | |
6288 | my $from = File::Spec->catdir($from_dir,$f); | |
6289 | my $to = File::Spec->catdir($packagedir,$f); | |
810a0276 SP |
6290 | unless (File::Copy::move($from,$to)) { |
6291 | my $err = $!; | |
6292 | $from = File::Spec->rel2abs($from); | |
6293 | Carp::confess("Couldn't move $from to $to: $err"); | |
6294 | } | |
05bab18e SP |
6295 | } |
6296 | } else { # older code below, still better than nothing when there is no File::Temp | |
6297 | my($distdir); | |
6298 | if (@readdir == 1 && -d $readdir[0]) { | |
6299 | $distdir = $readdir[0]; | |
6300 | $packagedir = File::Spec->catdir($builddir,$distdir); | |
6301 | $self->debug("packagedir[$packagedir]builddir[$builddir]distdir[$distdir]") | |
6302 | if $CPAN::DEBUG; | |
6303 | -d $packagedir and $CPAN::Frontend->myprint("Removing previously used ". | |
6304 | "$packagedir\n"); | |
6305 | File::Path::rmtree($packagedir); | |
6306 | unless (File::Copy::move($distdir,$packagedir)) { | |
6307 | $CPAN::Frontend->unrecoverable_error(<<EOF); | |
c9869e1c SP |
6308 | Couldn't move '$distdir' to '$packagedir': $! |
6309 | ||
6310 | Cannot continue: Please find the reason why I cannot move | |
05bab18e | 6311 | $builddir/tmp-$$/$distdir |
c9869e1c SP |
6312 | to |
6313 | $packagedir | |
6314 | and fix the problem, then retry | |
6315 | ||
6316 | EOF | |
05bab18e SP |
6317 | } |
6318 | $self->debug(sprintf("moved distdir[%s] to packagedir[%s] -e[%s]-d[%s]", | |
6319 | $distdir, | |
6320 | $packagedir, | |
6321 | -e $packagedir, | |
6322 | -d $packagedir, | |
6323 | )) if $CPAN::DEBUG; | |
6324 | } else { | |
6325 | my $userid = $self->cpan_userid; | |
b72dd56f | 6326 | CPAN->debug("userid[$userid]") if $CPAN::DEBUG; |
05bab18e SP |
6327 | if (!$userid or $userid eq "N/A") { |
6328 | $userid = "anon"; | |
6329 | } | |
6330 | my $pragmatic_dir = $userid . '000'; | |
6331 | $pragmatic_dir =~ s/\W_//g; | |
6332 | $pragmatic_dir++ while -d "../$pragmatic_dir"; | |
6333 | $packagedir = File::Spec->catdir($builddir,$pragmatic_dir); | |
6334 | $self->debug("packagedir[$packagedir]") if $CPAN::DEBUG; | |
6335 | File::Path::mkpath($packagedir); | |
6336 | my($f); | |
6337 | for $f (@readdir) { # is already without "." and ".." | |
6338 | my $to = File::Spec->catdir($packagedir,$f); | |
6339 | File::Copy::move($f,$to) or Carp::confess("Couldn't move $f to $to: $!"); | |
6340 | } | |
9d61fa1d | 6341 | } |
d8773709 | 6342 | } |
b72dd56f | 6343 | $self->{build_dir} = $packagedir; |
6f14f089 | 6344 | $self->safe_chdir($builddir); |
05bab18e | 6345 | File::Path::rmtree("tmp-$$"); |
d8773709 | 6346 | |
554a9ef5 | 6347 | $self->safe_chdir($packagedir); |
6658a91b | 6348 | $self->_signature_business(); |
554a9ef5 | 6349 | $self->safe_chdir($builddir); |
554a9ef5 | 6350 | |
dc053c64 SP |
6351 | return($packagedir,$local_file); |
6352 | } | |
554a9ef5 | 6353 | |
f04ea8d1 SP |
6354 | #-> sub CPAN::Distribution::parse_meta_yml ; |
6355 | sub parse_meta_yml { | |
6356 | my($self) = @_; | |
6357 | my $build_dir = $self->{build_dir} or die "PANIC: cannot parse yaml without a build_dir"; | |
6358 | my $yaml = File::Spec->catfile($build_dir,"META.yml"); | |
6359 | $self->debug("yaml[$yaml]") if $CPAN::DEBUG; | |
6360 | return unless -f $yaml; | |
6361 | my $early_yaml; | |
6362 | eval { | |
6363 | require Parse::Metayaml; # hypothetical | |
6364 | $early_yaml = Parse::Metayaml::LoadFile($yaml)->[0]; | |
6365 | }; | |
6366 | unless ($early_yaml) { | |
6367 | eval { $early_yaml = CPAN->_yaml_loadfile($yaml)->[0]; }; | |
6368 | } | |
6369 | unless ($early_yaml) { | |
6370 | return; | |
6371 | } | |
6372 | return $early_yaml; | |
6373 | } | |
6374 | ||
6375 | #-> sub CPAN::Distribution::satisfy_configure_requires ; | |
6376 | sub satisfy_configure_requires { | |
6377 | my($self) = @_; | |
6378 | my $enable_configure_requires = 1; | |
6379 | if (!$enable_configure_requires) { | |
6380 | return 1; | |
6381 | # if we return 1 here, everything is as before we introduced | |
6382 | # configure_requires that means, things with | |
6383 | # configure_requires simply fail, all others succeed | |
6384 | } | |
6385 | my @prereq = $self->unsat_prereq("configure_requires_later") or return 1; | |
6386 | if ($self->{configure_requires_later}) { | |
6387 | for my $k (keys %{$self->{configure_requires_later_for}||{}}) { | |
6388 | if ($self->{configure_requires_later_for}{$k}>1) { | |
6389 | # we must not come here a second time | |
6390 | $CPAN::Frontend->mywarn("Panic: Some prerequisites is not available, please investigate..."); | |
6391 | require YAML::Syck; | |
6392 | $CPAN::Frontend->mydie | |
6393 | ( | |
6394 | YAML::Syck::Dump | |
6395 | ({self=>$self, prereq=>\@prereq}) | |
6396 | ); | |
6397 | } | |
6398 | } | |
6399 | } | |
6400 | if ($prereq[0][0] eq "perl") { | |
6401 | my $need = "requires perl '$prereq[0][1]'"; | |
6402 | my $id = $self->pretty_id; | |
6403 | $CPAN::Frontend->mywarn("$id $need; you have only $]; giving up\n"); | |
6404 | $self->{make} = CPAN::Distrostatus->new("NO $need"); | |
6405 | $self->store_persistent_state; | |
6406 | return $self->goodbye("[prereq] -- NOT OK"); | |
6407 | } else { | |
6408 | my $follow = eval { | |
6409 | $self->follow_prereqs("configure_requires_later", @prereq); | |
6410 | }; | |
6411 | if (0) { | |
6412 | } elsif ($follow) { | |
6413 | return; | |
6414 | } elsif ($@ && ref $@ && $@->isa("CPAN::Exception::RecursiveDependency")) { | |
6415 | $CPAN::Frontend->mywarn($@); | |
6416 | return $self->goodbye("[depend] -- NOT OK"); | |
6417 | } | |
6418 | } | |
6419 | die "never reached"; | |
6420 | } | |
6421 | ||
6422 | #-> sub CPAN::Distribution::run_MM_or_MB ; | |
dc053c64 | 6423 | sub run_MM_or_MB { |
f04ea8d1 SP |
6424 | my($self,$local_file) = @_; |
6425 | $self->satisfy_configure_requires() or return; | |
6426 | my($mpl) = File::Spec->catfile($self->{build_dir},"Makefile.PL"); | |
d8773709 JH |
6427 | my($mpl_exists) = -f $mpl; |
6428 | unless ($mpl_exists) { | |
c049f953 JH |
6429 | # NFS has been reported to have racing problems after the |
6430 | # renaming of a directory in some environments. | |
6431 | # This trick helps. | |
8962fc49 | 6432 | $CPAN::Frontend->mysleep(1); |
f04ea8d1 SP |
6433 | my $mpldh = DirHandle->new($self->{build_dir}) |
6434 | or Carp::croak("Couldn't opendir $self->{build_dir}: $!"); | |
c049f953 JH |
6435 | $mpl_exists = grep /^Makefile\.PL$/, $mpldh->read; |
6436 | $mpldh->close; | |
d8773709 | 6437 | } |
e82b9348 | 6438 | my $prefer_installer = "eumm"; # eumm|mb |
f04ea8d1 | 6439 | if (-f File::Spec->catfile($self->{build_dir},"Build.PL")) { |
e82b9348 | 6440 | if ($mpl_exists) { # they *can* choose |
f20de9f0 SP |
6441 | if ($CPAN::META->has_inst("Module::Build")) { |
6442 | $prefer_installer = CPAN::HandleConfig->prefs_lookup($self, | |
6443 | q{prefer_installer}); | |
6444 | } | |
e82b9348 SP |
6445 | } else { |
6446 | $prefer_installer = "mb"; | |
6447 | } | |
6448 | } | |
6658a91b | 6449 | return unless $self->patch; |
f04ea8d1 SP |
6450 | if (lc($prefer_installer) eq "rand") { |
6451 | $prefer_installer = rand()<.5 ? "eumm" : "mb"; | |
6452 | } | |
e82b9348 | 6453 | if (lc($prefer_installer) eq "mb") { |
c9869e1c | 6454 | $self->{modulebuild} = 1; |
2b3bde2a SP |
6455 | } elsif ($self->{archived} eq "patch") { |
6456 | # not an edge case, nothing to install for sure | |
6457 | my $why = "A patch file cannot be installed"; | |
6458 | $CPAN::Frontend->mywarn("Refusing to handle this file: $why\n"); | |
6459 | $self->{writemakefile} = CPAN::Distrostatus->new("NO $why"); | |
e82b9348 | 6460 | } elsif (! $mpl_exists) { |
f04ea8d1 | 6461 | $self->_edge_cases($mpl,$local_file); |
6658a91b | 6462 | } |
05bab18e SP |
6463 | if ($self->{build_dir} |
6464 | && | |
6465 | $CPAN::Config->{build_dir_reuse} | |
6466 | ) { | |
6467 | $self->store_persistent_state; | |
6468 | } | |
6658a91b SP |
6469 | return $self; |
6470 | } | |
6471 | ||
05bab18e SP |
6472 | #-> CPAN::Distribution::store_persistent_state |
6473 | sub store_persistent_state { | |
6474 | my($self) = @_; | |
be34b10d | 6475 | my $dir = $self->{build_dir}; |
810a0276 | 6476 | unless (File::Spec->canonpath(File::Basename::dirname($dir)) |
f04ea8d1 | 6477 | eq File::Spec->canonpath($CPAN::Config->{build_dir})) { |
be34b10d SP |
6478 | $CPAN::Frontend->mywarn("Directory '$dir' not below $CPAN::Config->{build_dir}, ". |
6479 | "will not store persistent state\n"); | |
6480 | return; | |
6481 | } | |
6482 | my $file = sprintf "%s.yml", $dir; | |
b72dd56f SP |
6483 | my $yaml_module = CPAN::_yaml_module; |
6484 | if ($CPAN::META->has_inst($yaml_module)) { | |
6485 | CPAN->_yaml_dumpfile( | |
6486 | $file, | |
6487 | { | |
6488 | time => time, | |
6489 | perl => CPAN::_perl_fingerprint, | |
6490 | distribution => $self, | |
6491 | } | |
6492 | ); | |
6493 | } else { | |
6494 | $CPAN::Frontend->myprint("Warning (usually harmless): '$yaml_module' not installed, ". | |
6495 | "will not store persistent state\n"); | |
6496 | } | |
05bab18e SP |
6497 | } |
6498 | ||
b03f445c | 6499 | #-> CPAN::Distribution::try_download |
6658a91b SP |
6500 | sub try_download { |
6501 | my($self,$patch) = @_; | |
6502 | my $norm = $self->normalize($patch); | |
6503 | my($local_wanted) = | |
6504 | File::Spec->catfile( | |
6505 | $CPAN::Config->{keep_source_where}, | |
6506 | "authors", | |
6507 | "id", | |
6508 | split(/\//,$norm), | |
f04ea8d1 | 6509 | ); |
6658a91b SP |
6510 | $self->debug("Doing localize") if $CPAN::DEBUG; |
6511 | return CPAN::FTP->localize("authors/id/$norm", | |
6512 | $local_wanted); | |
6513 | } | |
6514 | ||
8ce4ea0b SP |
6515 | { |
6516 | my $stdpatchargs = ""; | |
6517 | #-> CPAN::Distribution::patch | |
6518 | sub patch { | |
6519 | my($self) = @_; | |
6520 | $self->debug("checking patches id[$self->{ID}]") if $CPAN::DEBUG; | |
6521 | my $patches = $self->prefs->{patches}; | |
6522 | $patches ||= ""; | |
6523 | $self->debug("patches[$patches]") if $CPAN::DEBUG; | |
6524 | if ($patches) { | |
6525 | return unless @$patches; | |
6526 | $self->safe_chdir($self->{build_dir}); | |
6527 | CPAN->debug("patches[$patches]") if $CPAN::DEBUG; | |
6528 | my $patchbin = $CPAN::Config->{patch}; | |
6529 | unless ($patchbin && length $patchbin) { | |
6530 | $CPAN::Frontend->mydie("No external patch command configured\n\n". | |
6531 | "Please run 'o conf init /patch/'\n\n"); | |
6532 | } | |
6533 | unless (MM->maybe_command($patchbin)) { | |
6534 | $CPAN::Frontend->mydie("No external patch command available\n\n". | |
6535 | "Please run 'o conf init /patch/'\n\n"); | |
6536 | } | |
6537 | $patchbin = CPAN::HandleConfig->safe_quote($patchbin); | |
6538 | local $ENV{PATCH_GET} = 0; # formerly known as -g0 | |
6539 | unless ($stdpatchargs) { | |
6540 | my $system = "$patchbin --version |"; | |
6541 | local *FH; | |
6542 | open FH, $system or die "Could not fork '$system': $!"; | |
6543 | local $/ = "\n"; | |
6544 | my $pversion; | |
6545 | PARSEVERSION: while (<FH>) { | |
6546 | if (/^patch\s+([\d\.]+)/) { | |
6547 | $pversion = $1; | |
6548 | last PARSEVERSION; | |
6549 | } | |
6550 | } | |
6551 | if ($pversion) { | |
6552 | $stdpatchargs = "-N --fuzz=3"; | |
6553 | } else { | |
6554 | $stdpatchargs = "-N"; | |
6555 | } | |
6556 | } | |
6557 | my $countedpatches = @$patches == 1 ? "1 patch" : (scalar @$patches . " patches"); | |
6558 | $CPAN::Frontend->myprint("Going to apply $countedpatches:\n"); | |
6559 | for my $patch (@$patches) { | |
6560 | unless (-f $patch) { | |
6561 | if (my $trydl = $self->try_download($patch)) { | |
6562 | $patch = $trydl; | |
6563 | } else { | |
6564 | my $fail = "Could not find patch '$patch'"; | |
6565 | $CPAN::Frontend->mywarn("$fail; cannot continue\n"); | |
6566 | $self->{unwrapped} = CPAN::Distrostatus->new("NO -- $fail"); | |
6567 | delete $self->{build_dir}; | |
6568 | return; | |
6569 | } | |
6570 | } | |
6571 | $CPAN::Frontend->myprint(" $patch\n"); | |
6572 | my $readfh = CPAN::Tarzip->TIEHANDLE($patch); | |
6573 | ||
6574 | my $pcommand; | |
6575 | my $ppp = $self->_patch_p_parameter($readfh); | |
6576 | if ($ppp eq "applypatch") { | |
6577 | $pcommand = "$CPAN::Config->{applypatch} -verbose"; | |
6658a91b | 6578 | } else { |
8ce4ea0b SP |
6579 | my $thispatchargs = join " ", $stdpatchargs, $ppp; |
6580 | $pcommand = "$patchbin $thispatchargs"; | |
6581 | } | |
6582 | ||
6583 | $readfh = CPAN::Tarzip->TIEHANDLE($patch); # open again | |
6584 | my $writefh = FileHandle->new; | |
6585 | $CPAN::Frontend->myprint(" $pcommand\n"); | |
6586 | unless (open $writefh, "|$pcommand") { | |
6587 | my $fail = "Could not fork '$pcommand'"; | |
6588 | $CPAN::Frontend->mywarn("$fail; cannot continue\n"); | |
6589 | $self->{unwrapped} = CPAN::Distrostatus->new("NO -- $fail"); | |
6590 | delete $self->{build_dir}; | |
6591 | return; | |
6592 | } | |
6593 | while (my $x = $readfh->READLINE) { | |
6594 | print $writefh $x; | |
6595 | } | |
6596 | unless (close $writefh) { | |
6597 | my $fail = "Could not apply patch '$patch'"; | |
6658a91b SP |
6598 | $CPAN::Frontend->mywarn("$fail; cannot continue\n"); |
6599 | $self->{unwrapped} = CPAN::Distrostatus->new("NO -- $fail"); | |
6600 | delete $self->{build_dir}; | |
6601 | return; | |
6602 | } | |
6603 | } | |
8ce4ea0b | 6604 | $self->{patched}++; |
6658a91b | 6605 | } |
8ce4ea0b | 6606 | return 1; |
6658a91b | 6607 | } |
6658a91b SP |
6608 | } |
6609 | ||
05bab18e SP |
6610 | sub _patch_p_parameter { |
6611 | my($self,$fh) = @_; | |
be34b10d SP |
6612 | my $cnt_files = 0; |
6613 | my $cnt_p0files = 0; | |
05bab18e SP |
6614 | local($_); |
6615 | while ($_ = $fh->READLINE) { | |
b72dd56f SP |
6616 | if ( |
6617 | $CPAN::Config->{applypatch} | |
6618 | && | |
6619 | /\#\#\#\# ApplyPatch data follows \#\#\#\#/ | |
6620 | ) { | |
6621 | return "applypatch" | |
6622 | } | |
05bab18e SP |
6623 | next unless /^[\*\+]{3}\s(\S+)/; |
6624 | my $file = $1; | |
6625 | $cnt_files++; | |
6626 | $cnt_p0files++ if -f $file; | |
b72dd56f SP |
6627 | CPAN->debug("file[$file]cnt_files[$cnt_files]cnt_p0files[$cnt_p0files]") |
6628 | if $CPAN::DEBUG; | |
05bab18e | 6629 | } |
be34b10d | 6630 | return "-p1" unless $cnt_files; |
05bab18e SP |
6631 | return $cnt_files==$cnt_p0files ? "-p0" : "-p1"; |
6632 | } | |
6633 | ||
6658a91b SP |
6634 | #-> sub CPAN::Distribution::_edge_cases |
6635 | # with "configure" or "Makefile" or single file scripts | |
6636 | sub _edge_cases { | |
f04ea8d1 | 6637 | my($self,$mpl,$local_file) = @_; |
6658a91b SP |
6638 | $self->debug(sprintf("makefilepl[%s]anycwd[%s]", |
6639 | $mpl, | |
6640 | CPAN::anycwd(), | |
6641 | )) if $CPAN::DEBUG; | |
f04ea8d1 SP |
6642 | my $build_dir = $self->{build_dir}; |
6643 | my($configure) = File::Spec->catfile($build_dir,"Configure"); | |
6658a91b SP |
6644 | if (-f $configure) { |
6645 | # do we have anything to do? | |
6646 | $self->{configure} = $configure; | |
f04ea8d1 | 6647 | } elsif (-f File::Spec->catfile($build_dir,"Makefile")) { |
6658a91b | 6648 | $CPAN::Frontend->mywarn(qq{ |
09d9d230 A |
6649 | Package comes with a Makefile and without a Makefile.PL. |
6650 | We\'ll try to build it with that Makefile then. | |
6651 | }); | |
6658a91b SP |
6652 | $self->{writemakefile} = CPAN::Distrostatus->new("YES"); |
6653 | $CPAN::Frontend->mysleep(2); | |
6654 | } else { | |
6655 | my $cf = $self->called_for || "unknown"; | |
6656 | if ($cf =~ m|/|) { | |
6657 | $cf =~ s|.*/||; | |
6658 | $cf =~ s|\W.*||; | |
6659 | } | |
6660 | $cf =~ s|[/\\:]||g; # risk of filesystem damage | |
6661 | $cf = "unknown" unless length($cf); | |
6662 | $CPAN::Frontend->mywarn(qq{Package seems to come without Makefile.PL. | |
d8773709 JH |
6663 | (The test -f "$mpl" returned false.) |
6664 | Writing one on our own (setting NAME to $cf)\a\n}); | |
6658a91b SP |
6665 | $self->{had_no_makefile_pl}++; |
6666 | $CPAN::Frontend->mysleep(3); | |
ed84aac9 | 6667 | |
6658a91b SP |
6668 | # Writing our own Makefile.PL |
6669 | ||
6670 | my $script = ""; | |
6671 | if ($self->{archived} eq "maybe_pl") { | |
6672 | my $fh = FileHandle->new; | |
f04ea8d1 | 6673 | my $script_file = File::Spec->catfile($build_dir,$local_file); |
6658a91b | 6674 | $fh->open($script_file) |
dc053c64 | 6675 | or Carp::croak("Could not open script '$script_file': $!"); |
6658a91b SP |
6676 | local $/ = "\n"; |
6677 | # name parsen und prereq | |
6678 | my($state) = "poddir"; | |
6679 | my($name, $prereq) = ("", ""); | |
6680 | while (<$fh>) { | |
6681 | if ($state eq "poddir" && /^=head\d\s+(\S+)/) { | |
6682 | if ($1 eq 'NAME') { | |
6683 | $state = "name"; | |
6684 | } elsif ($1 eq 'PREREQUISITES') { | |
6685 | $state = "prereq"; | |
6686 | } | |
6687 | } elsif ($state =~ m{^(name|prereq)$}) { | |
6688 | if (/^=/) { | |
6689 | $state = "poddir"; | |
6690 | } elsif (/^\s*$/) { | |
6691 | # nop | |
6692 | } elsif ($state eq "name") { | |
6693 | if ($name eq "") { | |
6694 | ($name) = /^(\S+)/; | |
6695 | $state = "poddir"; | |
6696 | } | |
6697 | } elsif ($state eq "prereq") { | |
6698 | $prereq .= $_; | |
ed84aac9 | 6699 | } |
6658a91b SP |
6700 | } elsif (/^=cut\b/) { |
6701 | last; | |
6702 | } | |
6703 | } | |
6704 | $fh->close; | |
6705 | ||
6706 | for ($name) { | |
6707 | s{.*<}{}; # strip X<...> | |
6708 | s{>.*}{}; | |
6709 | } | |
6710 | chomp $prereq; | |
6711 | $prereq = join " ", split /\s+/, $prereq; | |
6712 | my($PREREQ_PM) = join("\n", map { | |
6713 | s{.*<}{}; # strip X<...> | |
6714 | s{>.*}{}; | |
6715 | if (/[\s\'\"]/) { # prose? | |
6716 | } else { | |
6717 | s/[^\w:]$//; # period? | |
6718 | " "x28 . "'$_' => 0,"; | |
6719 | } | |
6720 | } split /\s*,\s*/, $prereq); | |
ed84aac9 | 6721 | |
6658a91b | 6722 | $script = " |
ed84aac9 A |
6723 | EXE_FILES => ['$name'], |
6724 | PREREQ_PM => { | |
6725 | $PREREQ_PM | |
6726 | }, | |
6727 | "; | |
6658a91b | 6728 | if ($name) { |
f04ea8d1 | 6729 | my $to_file = File::Spec->catfile($build_dir, $name); |
6658a91b SP |
6730 | rename $script_file, $to_file |
6731 | or die "Can't rename $script_file to $to_file: $!"; | |
6732 | } | |
6733 | } | |
ed84aac9 | 6734 | |
6658a91b SP |
6735 | my $fh = FileHandle->new; |
6736 | $fh->open(">$mpl") | |
6737 | or Carp::croak("Could not open >$mpl: $!"); | |
6738 | $fh->print( | |
6739 | qq{# This Makefile.PL has been autogenerated by the module CPAN.pm | |
55e314ee | 6740 | # because there was no Makefile.PL supplied. |
05454584 | 6741 | # Autogenerated on: }.scalar localtime().qq{ |
55e314ee | 6742 | |
09d9d230 | 6743 | use ExtUtils::MakeMaker; |
ed84aac9 A |
6744 | WriteMakefile( |
6745 | NAME => q[$cf],$script | |
6746 | ); | |
05454584 | 6747 | }); |
6658a91b | 6748 | $fh->close; |
5f05dabc | 6749 | } |
6658a91b | 6750 | } |
d8773709 | 6751 | |
6658a91b SP |
6752 | #-> CPAN::Distribution::_signature_business |
6753 | sub _signature_business { | |
6754 | my($self) = @_; | |
be34b10d SP |
6755 | my $check_sigs = CPAN::HandleConfig->prefs_lookup($self, |
6756 | q{check_sigs}); | |
6757 | if ($check_sigs) { | |
6658a91b SP |
6758 | if ($CPAN::META->has_inst("Module::Signature")) { |
6759 | if (-f "SIGNATURE") { | |
6760 | $self->debug("Module::Signature is installed, verifying") if $CPAN::DEBUG; | |
6761 | my $rv = Module::Signature::verify(); | |
6762 | if ($rv != Module::Signature::SIGNATURE_OK() and | |
6763 | $rv != Module::Signature::SIGNATURE_MISSING()) { | |
05bab18e SP |
6764 | $CPAN::Frontend->mywarn( |
6765 | qq{\nSignature invalid for }. | |
6766 | qq{distribution file. }. | |
6767 | qq{Please investigate.\n\n} | |
6768 | ); | |
6658a91b SP |
6769 | |
6770 | my $wrap = | |
23a216b4 SP |
6771 | sprintf(qq{I'd recommend removing %s. Some error occured }. |
6772 | qq{while checking its signature, so it could }. | |
6773 | qq{be invalid. Maybe you have configured }. | |
6774 | qq{your 'urllist' with a bad URL. Please check this }. | |
6775 | qq{array with 'o conf urllist' and retry. Or }. | |
6776 | qq{examine the distribution in a subshell. Try | |
6658a91b | 6777 | look %s |
23a216b4 | 6778 | and run |
6658a91b SP |
6779 | cpansign -v |
6780 | }, | |
6781 | $self->{localfile}, | |
6782 | $self->pretty_id, | |
6783 | ); | |
6784 | $self->{signature_verify} = CPAN::Distrostatus->new("NO"); | |
6785 | $CPAN::Frontend->mywarn(Text::Wrap::wrap("","",$wrap)); | |
6786 | $CPAN::Frontend->mysleep(5) if $CPAN::Frontend->can("mysleep"); | |
6787 | } else { | |
6788 | $self->{signature_verify} = CPAN::Distrostatus->new("YES"); | |
6789 | $self->debug("Module::Signature has verified") if $CPAN::DEBUG; | |
6790 | } | |
6791 | } else { | |
6792 | $CPAN::Frontend->mywarn(qq{Package came without SIGNATURE\n\n}); | |
6793 | } | |
6794 | } else { | |
6795 | $self->debug("Module::Signature is NOT installed") if $CPAN::DEBUG; | |
6796 | } | |
6797 | } | |
5f05dabc | 6798 | } |
6799 | ||
6658a91b | 6800 | #-> CPAN::Distribution::untar_me ; |
55e314ee | 6801 | sub untar_me { |
e82b9348 | 6802 | my($self,$ct) = @_; |
55e314ee | 6803 | $self->{archived} = "tar"; |
e82b9348 | 6804 | if ($ct->untar()) { |
f04ea8d1 | 6805 | $self->{unwrapped} = CPAN::Distrostatus->new("YES"); |
55e314ee | 6806 | } else { |
f04ea8d1 | 6807 | $self->{unwrapped} = CPAN::Distrostatus->new("NO -- untar failed"); |
55e314ee A |
6808 | } |
6809 | } | |
6810 | ||
6d29edf5 | 6811 | # CPAN::Distribution::unzip_me ; |
55e314ee | 6812 | sub unzip_me { |
e82b9348 | 6813 | my($self,$ct) = @_; |
05d2a450 | 6814 | $self->{archived} = "zip"; |
e82b9348 | 6815 | if ($ct->unzip()) { |
f04ea8d1 | 6816 | $self->{unwrapped} = CPAN::Distrostatus->new("YES"); |
55e314ee | 6817 | } else { |
f04ea8d1 | 6818 | $self->{unwrapped} = CPAN::Distrostatus->new("NO -- unzip failed"); |
55e314ee | 6819 | } |
c4d24d4c | 6820 | return; |
55e314ee A |
6821 | } |
6822 | ||
ed84aac9 | 6823 | sub handle_singlefile { |
55e314ee | 6824 | my($self,$local_file) = @_; |
ed84aac9 | 6825 | |
f04ea8d1 SP |
6826 | if ( $local_file =~ /\.pm(\.(gz|Z))?(?!\n)\Z/ ) { |
6827 | $self->{archived} = "pm"; | |
2b3bde2a | 6828 | } elsif ( $local_file =~ /\.patch(\.(gz|bz2))?(?!\n)\Z/ ) { |
f04ea8d1 | 6829 | $self->{archived} = "patch"; |
ed84aac9 | 6830 | } else { |
f04ea8d1 | 6831 | $self->{archived} = "maybe_pl"; |
ed84aac9 A |
6832 | } |
6833 | ||
55e314ee | 6834 | my $to = File::Basename::basename($local_file); |
554a9ef5 | 6835 | if ($to =~ s/\.(gz|Z)(?!\n)\Z//) { |
be34b10d | 6836 | if (eval{CPAN::Tarzip->new($local_file)->gunzip($to)}) { |
6658a91b | 6837 | $self->{unwrapped} = CPAN::Distrostatus->new("YES"); |
554a9ef5 | 6838 | } else { |
6658a91b | 6839 | $self->{unwrapped} = CPAN::Distrostatus->new("NO -- uncompressing failed"); |
554a9ef5 | 6840 | } |
55e314ee | 6841 | } else { |
2b3bde2a SP |
6842 | if (File::Copy::cp($local_file,".")) { |
6843 | $self->{unwrapped} = CPAN::Distrostatus->new("YES"); | |
6844 | } else { | |
6845 | $self->{unwrapped} = CPAN::Distrostatus->new("NO -- copying failed"); | |
6846 | } | |
55e314ee | 6847 | } |
ed84aac9 | 6848 | return $to; |
55e314ee A |
6849 | } |
6850 | ||
05454584 A |
6851 | #-> sub CPAN::Distribution::new ; |
6852 | sub new { | |
6853 | my($class,%att) = @_; | |
5f05dabc | 6854 | |
5e05dca5 | 6855 | # $CPAN::META->{cachemgr} ||= CPAN::CacheMgr->new(); |
5f05dabc | 6856 | |
05454584 A |
6857 | my $this = { %att }; |
6858 | return bless $this, $class; | |
5f05dabc | 6859 | } |
6860 | ||
05454584 A |
6861 | #-> sub CPAN::Distribution::look ; |
6862 | sub look { | |
5f05dabc | 6863 | my($self) = @_; |
36263cb3 GS |
6864 | |
6865 | if ($^O eq 'MacOS') { | |
be708cc0 | 6866 | $self->Mac::BuildTools::look; |
36263cb3 GS |
6867 | return; |
6868 | } | |
6869 | ||
05454584 | 6870 | if ( $CPAN::Config->{'shell'} ) { |
f04ea8d1 | 6871 | $CPAN::Frontend->myprint(qq{ |
05454584 | 6872 | Trying to open a subshell in the build directory... |
c356248b | 6873 | }); |
05454584 | 6874 | } else { |
f04ea8d1 | 6875 | $CPAN::Frontend->myprint(qq{ |
05454584 A |
6876 | Your configuration does not define a value for subshells. |
6877 | Please define it with "o conf shell <your shell>" | |
c356248b | 6878 | }); |
f04ea8d1 | 6879 | return; |
5f05dabc | 6880 | } |
05454584 | 6881 | my $dist = $self->id; |
c049f953 JH |
6882 | my $dir; |
6883 | unless ($dir = $self->dir) { | |
6884 | $self->get; | |
6885 | } | |
6886 | unless ($dir ||= $self->dir) { | |
f04ea8d1 | 6887 | $CPAN::Frontend->mywarn(qq{ |
c049f953 JH |
6888 | Could not determine which directory to use for looking at $dist. |
6889 | }); | |
f04ea8d1 | 6890 | return; |
c049f953 | 6891 | } |
9d61fa1d | 6892 | my $pwd = CPAN::anycwd(); |
c049f953 | 6893 | $self->safe_chdir($dir); |
c356248b | 6894 | $CPAN::Frontend->myprint(qq{Working directory is $dir\n}); |
9ddc4ed0 | 6895 | { |
f04ea8d1 | 6896 | local $ENV{CPAN_SHELL_LEVEL} = $ENV{CPAN_SHELL_LEVEL}||0; |
9ddc4ed0 | 6897 | $ENV{CPAN_SHELL_LEVEL} += 1; |
f04ea8d1 SP |
6898 | my $shell = CPAN::HandleConfig->safe_quote($CPAN::Config->{'shell'}); |
6899 | unless (system($shell) == 0) { | |
6900 | my $code = $? >> 8; | |
6901 | $CPAN::Frontend->mywarn("Subprocess shell exit code $code\n"); | |
6902 | } | |
35576f8c | 6903 | } |
c049f953 | 6904 | $self->safe_chdir($pwd); |
5f05dabc | 6905 | } |
6906 | ||
6d29edf5 | 6907 | # CPAN::Distribution::cvs_import ; |
911a92db GS |
6908 | sub cvs_import { |
6909 | my($self) = @_; | |
6910 | $self->get; | |
6911 | my $dir = $self->dir; | |
6912 | ||
6913 | my $package = $self->called_for; | |
6914 | my $module = $CPAN::META->instance('CPAN::Module', $package); | |
6d29edf5 | 6915 | my $version = $module->cpan_version; |
911a92db | 6916 | |
6d29edf5 | 6917 | my $userid = $self->cpan_userid; |
911a92db | 6918 | |
5fc0f0f6 | 6919 | my $cvs_dir = (split /\//, $dir)[-1]; |
05d2a450 | 6920 | $cvs_dir =~ s/-\d+[^-]+(?!\n)\Z//; |
f04ea8d1 | 6921 | my $cvs_root = |
911a92db | 6922 | $CPAN::Config->{cvsroot} || $ENV{CVSROOT}; |
f04ea8d1 | 6923 | my $cvs_site_perl = |
911a92db GS |
6924 | $CPAN::Config->{cvs_site_perl} || $ENV{CVS_SITE_PERL}; |
6925 | if ($cvs_site_perl) { | |
f04ea8d1 | 6926 | $cvs_dir = "$cvs_site_perl/$cvs_dir"; |
911a92db GS |
6927 | } |
6928 | my $cvs_log = qq{"imported $package $version sources"}; | |
6929 | $version =~ s/\./_/g; | |
135a59c2 | 6930 | # XXX cvs: undocumented and unclear how it was meant to work |
911a92db | 6931 | my @cmd = ('cvs', '-d', $cvs_root, 'import', '-m', $cvs_log, |
f04ea8d1 | 6932 | "$cvs_dir", $userid, "v$version"); |
911a92db | 6933 | |
9d61fa1d | 6934 | my $pwd = CPAN::anycwd(); |
05d2a450 | 6935 | chdir($dir) or $CPAN::Frontend->mydie(qq{Could not chdir to "$dir": $!}); |
911a92db GS |
6936 | |
6937 | $CPAN::Frontend->myprint(qq{Working directory is $dir\n}); | |
6938 | ||
6939 | $CPAN::Frontend->myprint(qq{@cmd\n}); | |
de34a54b | 6940 | system(@cmd) == 0 or |
ed84aac9 | 6941 | # XXX cvs |
f04ea8d1 | 6942 | $CPAN::Frontend->mydie("cvs import failed"); |
05d2a450 | 6943 | chdir($pwd) or $CPAN::Frontend->mydie(qq{Could not chdir to "$pwd": $!}); |
911a92db GS |
6944 | } |
6945 | ||
05454584 A |
6946 | #-> sub CPAN::Distribution::readme ; |
6947 | sub readme { | |
5f05dabc | 6948 | my($self) = @_; |
05454584 A |
6949 | my($dist) = $self->id; |
6950 | my($sans,$suffix) = $dist =~ /(.+)\.(tgz|tar[\._-]gz|tar\.Z|zip)$/; | |
6951 | $self->debug("sans[$sans] suffix[$suffix]\n") if $CPAN::DEBUG; | |
6952 | my($local_file); | |
6953 | my($local_wanted) = | |
f04ea8d1 SP |
6954 | File::Spec->catfile( |
6955 | $CPAN::Config->{keep_source_where}, | |
6956 | "authors", | |
6957 | "id", | |
6958 | split(/\//,"$sans.readme"), | |
6959 | ); | |
05454584 | 6960 | $self->debug("Doing localize") if $CPAN::DEBUG; |
c356248b | 6961 | $local_file = CPAN::FTP->localize("authors/id/$sans.readme", |
f04ea8d1 SP |
6962 | $local_wanted) |
6963 | or $CPAN::Frontend->mydie(qq{No $sans.readme found});; | |
f14b5cec JH |
6964 | |
6965 | if ($^O eq 'MacOS') { | |
be708cc0 | 6966 | Mac::BuildTools::launch_file($local_file); |
f14b5cec JH |
6967 | return; |
6968 | } | |
6969 | ||
05454584 | 6970 | my $fh_pager = FileHandle->new; |
c356248b | 6971 | local($SIG{PIPE}) = "IGNORE"; |
ed84aac9 A |
6972 | my $pager = $CPAN::Config->{'pager'} || "cat"; |
6973 | $fh_pager->open("|$pager") | |
f04ea8d1 | 6974 | or die "Could not open pager $pager\: $!"; |
05454584 | 6975 | my $fh_readme = FileHandle->new; |
c356248b | 6976 | $fh_readme->open($local_file) |
f04ea8d1 | 6977 | or $CPAN::Frontend->mydie(qq{Could not open "$local_file": $!}); |
c356248b A |
6978 | $CPAN::Frontend->myprint(qq{ |
6979 | Displaying file | |
6980 | $local_file | |
ed84aac9 | 6981 | with pager "$pager" |
c356248b | 6982 | }); |
05454584 | 6983 | $fh_pager->print(<$fh_readme>); |
554a9ef5 | 6984 | $fh_pager->close; |
5f05dabc | 6985 | } |
6986 | ||
e82b9348 SP |
6987 | #-> sub CPAN::Distribution::verifyCHECKSUM ; |
6988 | sub verifyCHECKSUM { | |
5f05dabc | 6989 | my($self) = @_; |
05454584 | 6990 | EXCUSE: { |
f04ea8d1 SP |
6991 | my @e; |
6992 | $self->{CHECKSUM_STATUS} ||= ""; | |
6993 | $self->{CHECKSUM_STATUS} eq "OK" and push @e, "Checksum was ok"; | |
6994 | $CPAN::Frontend->myprint(join "", map {" $_\n"} @e) and return if @e; | |
05454584 | 6995 | } |
55e314ee | 6996 | my($lc_want,$lc_file,@local,$basename); |
5fc0f0f6 | 6997 | @local = split(/\//,$self->id); |
55e314ee | 6998 | pop @local; |
05454584 | 6999 | push @local, "CHECKSUMS"; |
55e314ee | 7000 | $lc_want = |
f04ea8d1 SP |
7001 | File::Spec->catfile($CPAN::Config->{keep_source_where}, |
7002 | "authors", "id", @local); | |
05454584 | 7003 | local($") = "/"; |
b96578bb SP |
7004 | if (my $size = -s $lc_want) { |
7005 | $self->debug("lc_want[$lc_want]size[$size]") if $CPAN::DEBUG; | |
7006 | if ($self->CHECKSUM_check_file($lc_want,1)) { | |
7007 | return $self->{CHECKSUM_STATUS} = "OK"; | |
7008 | } | |
05454584 | 7009 | } |
55e314ee | 7010 | $lc_file = CPAN::FTP->localize("authors/id/@local", |
f04ea8d1 | 7011 | $lc_want,1); |
55e314ee | 7012 | unless ($lc_file) { |
8d97e4a1 | 7013 | $CPAN::Frontend->myprint("Trying $lc_want.gz\n"); |
f04ea8d1 SP |
7014 | $local[-1] .= ".gz"; |
7015 | $lc_file = CPAN::FTP->localize("authors/id/@local", | |
7016 | "$lc_want.gz",1); | |
7017 | if ($lc_file) { | |
7018 | $lc_file =~ s/\.gz(?!\n)\Z//; | |
7019 | eval{CPAN::Tarzip->new("$lc_file.gz")->gunzip($lc_file)}; | |
7020 | } else { | |
7021 | return; | |
7022 | } | |
05454584 | 7023 | } |
b96578bb SP |
7024 | if ($self->CHECKSUM_check_file($lc_file)) { |
7025 | return $self->{CHECKSUM_STATUS} = "OK"; | |
7026 | } | |
5f05dabc | 7027 | } |
7028 | ||
4d1321a7 | 7029 | #-> sub CPAN::Distribution::SIG_check_file ; |
554a9ef5 SP |
7030 | sub SIG_check_file { |
7031 | my($self,$chk_file) = @_; | |
7032 | my $rv = eval { Module::Signature::_verify($chk_file) }; | |
7033 | ||
7034 | if ($rv == Module::Signature::SIGNATURE_OK()) { | |
f04ea8d1 SP |
7035 | $CPAN::Frontend->myprint("Signature for $chk_file ok\n"); |
7036 | return $self->{SIG_STATUS} = "OK"; | |
554a9ef5 | 7037 | } else { |
f04ea8d1 SP |
7038 | $CPAN::Frontend->myprint(qq{\nSignature invalid for }. |
7039 | qq{distribution file. }. | |
7040 | qq{Please investigate.\n\n}. | |
7041 | $self->as_string, | |
7042 | $CPAN::META->instance( | |
7043 | 'CPAN::Author', | |
7044 | $self->cpan_userid | |
7045 | )->as_string); | |
7046 | ||
7047 | my $wrap = qq{I\'d recommend removing $chk_file. Its signature | |
554a9ef5 SP |
7048 | is invalid. Maybe you have configured your 'urllist' with |
7049 | a bad URL. Please check this array with 'o conf urllist', and | |
7050 | retry.}; | |
7051 | ||
f04ea8d1 | 7052 | $CPAN::Frontend->mydie(Text::Wrap::wrap("","",$wrap)); |
554a9ef5 SP |
7053 | } |
7054 | } | |
7055 | ||
e82b9348 | 7056 | #-> sub CPAN::Distribution::CHECKSUM_check_file ; |
b96578bb SP |
7057 | |
7058 | # sloppy is 1 when we have an old checksums file that maybe is good | |
7059 | # enough | |
7060 | ||
e82b9348 | 7061 | sub CHECKSUM_check_file { |
b96578bb | 7062 | my($self,$chk_file,$sloppy) = @_; |
55e314ee | 7063 | my($cksum,$file,$basename); |
554a9ef5 | 7064 | |
b96578bb SP |
7065 | $sloppy ||= 0; |
7066 | $self->debug("chk_file[$chk_file]sloppy[$sloppy]") if $CPAN::DEBUG; | |
be34b10d SP |
7067 | my $check_sigs = CPAN::HandleConfig->prefs_lookup($self, |
7068 | q{check_sigs}); | |
7069 | if ($check_sigs) { | |
6658a91b | 7070 | if ($CPAN::META->has_inst("Module::Signature")) { |
b72dd56f | 7071 | $self->debug("Module::Signature is installed, verifying") if $CPAN::DEBUG; |
ed84aac9 A |
7072 | $self->SIG_check_file($chk_file); |
7073 | } else { | |
b72dd56f | 7074 | $self->debug("Module::Signature is NOT installed") if $CPAN::DEBUG; |
ed84aac9 | 7075 | } |
554a9ef5 SP |
7076 | } |
7077 | ||
c356248b | 7078 | $file = $self->{localfile}; |
55e314ee A |
7079 | $basename = File::Basename::basename($file); |
7080 | my $fh = FileHandle->new; | |
f04ea8d1 SP |
7081 | if (open $fh, $chk_file) { |
7082 | local($/); | |
7083 | my $eval = <$fh>; | |
7084 | $eval =~ s/\015?\012/\n/g; | |
7085 | close $fh; | |
7086 | my($comp) = Safe->new(); | |
7087 | $cksum = $comp->reval($eval); | |
7088 | if ($@) { | |
7089 | rename $chk_file, "$chk_file.bad"; | |
7090 | Carp::confess($@) if $@; | |
7091 | } | |
55e314ee | 7092 | } else { |
f04ea8d1 | 7093 | Carp::carp "Could not open $chk_file for reading"; |
55e314ee | 7094 | } |
09d9d230 | 7095 | |
44d21104 A |
7096 | if (! ref $cksum or ref $cksum ne "HASH") { |
7097 | $CPAN::Frontend->mywarn(qq{ | |
7098 | Warning: checksum file '$chk_file' broken. | |
7099 | ||
7100 | When trying to read that file I expected to get a hash reference | |
7101 | for further processing, but got garbage instead. | |
7102 | }); | |
8962fc49 | 7103 | my $answer = CPAN::Shell::colorable_makemaker_prompt("Proceed nonetheless?", "no"); |
b96578bb SP |
7104 | $answer =~ /^\s*y/i or $CPAN::Frontend->mydie("Aborted.\n"); |
7105 | $self->{CHECKSUM_STATUS} = "NIL -- CHECKSUMS file broken"; | |
44d21104 A |
7106 | return; |
7107 | } elsif (exists $cksum->{$basename}{sha256}) { | |
f04ea8d1 SP |
7108 | $self->debug("Found checksum for $basename:" . |
7109 | "$cksum->{$basename}{sha256}\n") if $CPAN::DEBUG; | |
7110 | ||
7111 | open($fh, $file); | |
7112 | binmode $fh; | |
7113 | my $eq = $self->eq_CHECKSUM($fh,$cksum->{$basename}{sha256}); | |
7114 | $fh->close; | |
7115 | $fh = CPAN::Tarzip->TIEHANDLE($file); | |
7116 | ||
7117 | unless ($eq) { | |
7118 | my $dg = Digest::SHA->new(256); | |
7119 | my($data,$ref); | |
7120 | $ref = \$data; | |
7121 | while ($fh->READ($ref, 4096) > 0) { | |
7122 | $dg->add($data); | |
7123 | } | |
7124 | my $hexdigest = $dg->hexdigest; | |
7125 | $eq += $hexdigest eq $cksum->{$basename}{'sha256-ungz'}; | |
7126 | } | |
7127 | ||
7128 | if ($eq) { | |
7129 | $CPAN::Frontend->myprint("Checksum for $file ok\n"); | |
7130 | return $self->{CHECKSUM_STATUS} = "OK"; | |
7131 | } else { | |
7132 | $CPAN::Frontend->myprint(qq{\nChecksum mismatch for }. | |
7133 | qq{distribution file. }. | |
7134 | qq{Please investigate.\n\n}. | |
7135 | $self->as_string, | |
7136 | $CPAN::META->instance( | |
7137 | 'CPAN::Author', | |
7138 | $self->cpan_userid | |
7139 | )->as_string); | |
7140 | ||
7141 | my $wrap = qq{I\'d recommend removing $file. Its | |
c4d24d4c A |
7142 | checksum is incorrect. Maybe you have configured your 'urllist' with |
7143 | a bad URL. Please check this array with 'o conf urllist', and | |
55e314ee | 7144 | retry.}; |
de34a54b | 7145 | |
c4d24d4c A |
7146 | $CPAN::Frontend->mydie(Text::Wrap::wrap("","",$wrap)); |
7147 | ||
7148 | # former versions just returned here but this seems a | |
7149 | # serious threat that deserves a die | |
7150 | ||
f04ea8d1 SP |
7151 | # $CPAN::Frontend->myprint("\n\n"); |
7152 | # sleep 3; | |
7153 | # return; | |
7154 | } | |
7155 | # close $fh if fileno($fh); | |
5f05dabc | 7156 | } else { |
b96578bb | 7157 | return if $sloppy; |
f04ea8d1 SP |
7158 | unless ($self->{CHECKSUM_STATUS}) { |
7159 | $CPAN::Frontend->mywarn(qq{ | |
e82b9348 | 7160 | Warning: No checksum for $basename in $chk_file. |
5a5fac02 JH |
7161 | |
7162 | The cause for this may be that the file is very new and the checksum | |
7163 | has not yet been calculated, but it may also be that something is | |
7164 | going awry right now. | |
c356248b | 7165 | }); |
8962fc49 | 7166 | my $answer = CPAN::Shell::colorable_makemaker_prompt("Proceed?", "yes"); |
b96578bb | 7167 | $answer =~ /^\s*y/i or $CPAN::Frontend->mydie("Aborted.\n"); |
f04ea8d1 | 7168 | } |
b96578bb | 7169 | $self->{CHECKSUM_STATUS} = "NIL -- distro not in CHECKSUMS file"; |
f04ea8d1 | 7170 | return; |
5f05dabc | 7171 | } |
7172 | } | |
7173 | ||
e82b9348 SP |
7174 | #-> sub CPAN::Distribution::eq_CHECKSUM ; |
7175 | sub eq_CHECKSUM { | |
7176 | my($self,$fh,$expect) = @_; | |
87892b73 RGS |
7177 | if ($CPAN::META->has_inst("Digest::SHA")) { |
7178 | my $dg = Digest::SHA->new(256); | |
7179 | my($data); | |
f04ea8d1 | 7180 | while (read($fh, $data, 4096)) { |
87892b73 RGS |
7181 | $dg->add($data); |
7182 | } | |
7183 | my $hexdigest = $dg->hexdigest; | |
7184 | # warn "fh[$fh] hex[$hexdigest] aexp[$expectMD5]"; | |
7185 | return $hexdigest eq $expect; | |
09d9d230 | 7186 | } |
87892b73 | 7187 | return 1; |
05454584 | 7188 | } |
5f05dabc | 7189 | |
05454584 | 7190 | #-> sub CPAN::Distribution::force ; |
c4d24d4c | 7191 | |
e82b9348 SP |
7192 | # Both CPAN::Modules and CPAN::Distributions know if "force" is in |
7193 | # effect by autoinspection, not by inspecting a global variable. One | |
7194 | # of the reason why this was chosen to work that way was the treatment | |
7195 | # of dependencies. They should not automatically inherit the force | |
c4d24d4c A |
7196 | # status. But this has the downside that ^C and die() will return to |
7197 | # the prompt but will not be able to reset the force_update | |
7198 | # attributes. We try to correct for it currently in the read_metadata | |
7199 | # routine, and immediately before we check for a Signal. I hope this | |
7200 | # works out in one of v1.57_53ff | |
7201 | ||
4d1321a7 A |
7202 | # "Force get forgets previous error conditions" |
7203 | ||
b72dd56f SP |
7204 | #-> sub CPAN::Distribution::fforce ; |
7205 | sub fforce { | |
7206 | my($self, $method) = @_; | |
7207 | $self->force($method,1); | |
7208 | } | |
7209 | ||
4d1321a7 | 7210 | #-> sub CPAN::Distribution::force ; |
5f05dabc | 7211 | sub force { |
b72dd56f | 7212 | my($self, $method,$fforce) = @_; |
810a0276 SP |
7213 | my %phase_map = ( |
7214 | get => [ | |
7215 | "unwrapped", | |
7216 | "build_dir", | |
7217 | "archived", | |
7218 | "localfile", | |
7219 | "CHECKSUM_STATUS", | |
7220 | "signature_verify", | |
7221 | "prefs", | |
7222 | "prefs_file", | |
7223 | "prefs_file_doc", | |
7224 | ], | |
7225 | make => [ | |
7226 | "writemakefile", | |
7227 | "make", | |
7228 | "modulebuild", | |
7229 | "prereq_pm", | |
7230 | "prereq_pm_detected", | |
7231 | ], | |
7232 | test => [ | |
7233 | "badtestcnt", | |
7234 | "make_test", | |
7235 | ], | |
7236 | install => [ | |
7237 | "install", | |
7238 | ], | |
7239 | unknown => [ | |
7240 | "reqtype", | |
7241 | "yaml_content", | |
7242 | ], | |
7243 | ); | |
b72dd56f SP |
7244 | my $methodmatch = 0; |
7245 | my $ldebug = 0; | |
7246 | PHASE: for my $phase (qw(unknown get make test install)) { # order matters | |
7247 | $methodmatch = 1 if $fforce || $phase eq $method; | |
7248 | next unless $methodmatch; | |
810a0276 | 7249 | ATTRIBUTE: for my $att (@{$phase_map{$phase}}) { |
b72dd56f SP |
7250 | if ($phase eq "get") { |
7251 | if (substr($self->id,-1,1) eq "." | |
7252 | && $att =~ /(unwrapped|build_dir|archived)/ ) { | |
7253 | # cannot be undone for local distros | |
7254 | next ATTRIBUTE; | |
7255 | } | |
7256 | if ($att eq "build_dir" | |
7257 | && $self->{build_dir} | |
7258 | && $CPAN::META->{is_tested} | |
7259 | ) { | |
7260 | delete $CPAN::META->{is_tested}{$self->{build_dir}}; | |
7261 | } | |
7262 | } elsif ($phase eq "test") { | |
7263 | if ($att eq "make_test" | |
7264 | && $self->{make_test} | |
7265 | && $self->{make_test}{COMMANDID} | |
7266 | && $self->{make_test}{COMMANDID} == $CPAN::CurrentCommandId | |
7267 | ) { | |
7268 | # endless loop too likely | |
7269 | next ATTRIBUTE; | |
7270 | } | |
810a0276 SP |
7271 | } |
7272 | delete $self->{$att}; | |
b72dd56f SP |
7273 | if ($ldebug || $CPAN::DEBUG) { |
7274 | # local $CPAN::DEBUG = 16; # Distribution | |
7275 | CPAN->debug(sprintf "id[%s]phase[%s]att[%s]", $self->id, $phase, $att); | |
7276 | } | |
810a0276 | 7277 | } |
f610777f | 7278 | } |
9ddc4ed0 | 7279 | if ($method && $method =~ /make|test|install/) { |
b72dd56f | 7280 | $self->{force_update} = 1; # name should probably have been force_install |
c4d24d4c A |
7281 | } |
7282 | } | |
7283 | ||
05bab18e | 7284 | #-> sub CPAN::Distribution::notest ; |
554a9ef5 | 7285 | sub notest { |
f3fe0ae6 | 7286 | my($self, $method) = @_; |
23a216b4 | 7287 | # $CPAN::Frontend->mywarn("XDEBUG: set notest for $self $method"); |
554a9ef5 SP |
7288 | $self->{"notest"}++; # name should probably have been force_install |
7289 | } | |
7290 | ||
05bab18e | 7291 | #-> sub CPAN::Distribution::unnotest ; |
554a9ef5 | 7292 | sub unnotest { |
f3fe0ae6 | 7293 | my($self) = @_; |
554a9ef5 | 7294 | # warn "XDEBUG: deleting notest"; |
23a216b4 | 7295 | delete $self->{notest}; |
554a9ef5 SP |
7296 | } |
7297 | ||
c4d24d4c A |
7298 | #-> sub CPAN::Distribution::unforce ; |
7299 | sub unforce { | |
7300 | my($self) = @_; | |
b72dd56f | 7301 | delete $self->{force_update}; |
5f05dabc | 7302 | } |
7303 | ||
de34a54b | 7304 | #-> sub CPAN::Distribution::isa_perl ; |
09d9d230 A |
7305 | sub isa_perl { |
7306 | my($self) = @_; | |
7307 | my $file = File::Basename::basename($self->id); | |
05d2a450 A |
7308 | if ($file =~ m{ ^ perl |
7309 | -? | |
f04ea8d1 SP |
7310 | (5) |
7311 | ([._-]) | |
7312 | ( | |
05d2a450 A |
7313 | \d{3}(_[0-4][0-9])? |
7314 | | | |
ed84aac9 | 7315 | \d+\.\d+ |
05d2a450 | 7316 | ) |
f04ea8d1 SP |
7317 | \.tar[._-](?:gz|bz2) |
7318 | (?!\n)\Z | |
7319 | }xs) { | |
05d2a450 | 7320 | return "$1.$3"; |
6d29edf5 JH |
7321 | } elsif ($self->cpan_comment |
7322 | && | |
f04ea8d1 | 7323 | $self->cpan_comment =~ /isa_perl\(.+?\)/) { |
05d2a450 A |
7324 | return $1; |
7325 | } | |
09d9d230 A |
7326 | } |
7327 | ||
607a774b | 7328 | |
d4fd5c69 A |
7329 | #-> sub CPAN::Distribution::perl ; |
7330 | sub perl { | |
ed84aac9 A |
7331 | my ($self) = @_; |
7332 | if (! $self) { | |
7333 | use Carp qw(carp); | |
7334 | carp __PACKAGE__ . "::perl was called without parameters."; | |
7335 | } | |
7336 | return CPAN::HandleConfig->safe_quote($CPAN::Perl); | |
d4fd5c69 A |
7337 | } |
7338 | ||
607a774b | 7339 | |
05454584 A |
7340 | #-> sub CPAN::Distribution::make ; |
7341 | sub make { | |
7342 | my($self) = @_; | |
be34b10d SP |
7343 | if (my $goto = $self->prefs->{goto}) { |
7344 | return $self->goto($goto); | |
7345 | } | |
e82b9348 | 7346 | my $make = $self->{modulebuild} ? "Build" : "make"; |
09d9d230 A |
7347 | # Emergency brake if they said install Pippi and get newest perl |
7348 | if ($self->isa_perl) { | |
f04ea8d1 SP |
7349 | if ( |
7350 | $self->called_for ne $self->id && | |
7351 | ! $self->{force_update} | |
7352 | ) { | |
7353 | # if we die here, we break bundles | |
7354 | $CPAN::Frontend | |
7355 | ->mywarn(sprintf( | |
7356 | qq{The most recent version "%s" of the module "%s" | |
6a935156 SP |
7357 | is part of the perl-%s distribution. To install that, you need to run |
7358 | force install %s --or-- | |
7359 | install %s | |
09d9d230 | 7360 | }, |
6a935156 SP |
7361 | $CPAN::META->instance( |
7362 | 'CPAN::Module', | |
7363 | $self->called_for | |
7364 | )->cpan_version, | |
7365 | $self->called_for, | |
7366 | $self->isa_perl, | |
7367 | $self->called_for, | |
7368 | $self->id, | |
7369 | )); | |
f04ea8d1 SP |
7370 | $self->{make} = CPAN::Distrostatus->new("NO isa perl"); |
7371 | $CPAN::Frontend->mysleep(1); | |
7372 | return; | |
7373 | } | |
09d9d230 | 7374 | } |
6a935156 | 7375 | $CPAN::Frontend->myprint(sprintf "Running %s for %s\n", $make, $self->id); |
05454584 | 7376 | $self->get; |
f04ea8d1 SP |
7377 | if ($self->{configure_requires_later}) { |
7378 | return; | |
7379 | } | |
6658a91b SP |
7380 | local $ENV{PERL5LIB} = defined($ENV{PERL5LIB}) |
7381 | ? $ENV{PERL5LIB} | |
7382 | : ($ENV{PERLLIB} || ""); | |
6658a91b SP |
7383 | $CPAN::META->set_perl5lib; |
7384 | local $ENV{MAKEFLAGS}; # protect us from outer make calls | |
7385 | ||
f04ea8d1 SP |
7386 | if ($CPAN::Signal) { |
7387 | delete $self->{force_update}; | |
7388 | return; | |
4d1321a7 | 7389 | } |
b72dd56f SP |
7390 | |
7391 | my $builddir; | |
05454584 | 7392 | EXCUSE: { |
0cf35e6a | 7393 | my @e; |
6658a91b SP |
7394 | if (!$self->{archived} || $self->{archived} eq "NO") { |
7395 | push @e, "Is neither a tar nor a zip archive."; | |
7396 | } | |
5f05dabc | 7397 | |
6658a91b SP |
7398 | if (!$self->{unwrapped} |
7399 | || ( | |
be34b10d | 7400 | UNIVERSAL::can($self->{unwrapped},"failed") ? |
6658a91b SP |
7401 | $self->{unwrapped}->failed : |
7402 | $self->{unwrapped} =~ /^NO/ | |
7403 | )) { | |
7404 | push @e, "Had problems unarchiving. Please build manually"; | |
7405 | } | |
9ddc4ed0 A |
7406 | |
7407 | unless ($self->{force_update}) { | |
be34b10d SP |
7408 | exists $self->{signature_verify} and |
7409 | ( | |
7410 | UNIVERSAL::can($self->{signature_verify},"failed") ? | |
7411 | $self->{signature_verify}->failed : | |
7412 | $self->{signature_verify} =~ /^NO/ | |
7413 | ) | |
9ddc4ed0 A |
7414 | and push @e, "Did not pass the signature test."; |
7415 | } | |
05454584 | 7416 | |
4d1321a7 A |
7417 | if (exists $self->{writemakefile} && |
7418 | ( | |
be34b10d | 7419 | UNIVERSAL::can($self->{writemakefile},"failed") ? |
4d1321a7 A |
7420 | $self->{writemakefile}->failed : |
7421 | $self->{writemakefile} =~ /^NO/ | |
7422 | )) { | |
7423 | # XXX maybe a retry would be in order? | |
be34b10d | 7424 | my $err = UNIVERSAL::can($self->{writemakefile},"text") ? |
4d1321a7 A |
7425 | $self->{writemakefile}->text : |
7426 | $self->{writemakefile}; | |
7427 | $err =~ s/^NO\s*//; | |
7428 | $err ||= "Had some problem writing Makefile"; | |
7429 | $err .= ", won't make"; | |
7430 | push @e, $err; | |
7431 | } | |
05454584 | 7432 | |
f04ea8d1 | 7433 | if (defined $self->{make}) { |
8ce4ea0b SP |
7434 | if (UNIVERSAL::can($self->{make},"failed") ? |
7435 | $self->{make}->failed : | |
7436 | $self->{make} =~ /^NO/) { | |
ade94d80 SP |
7437 | if ($self->{force_update}) { |
7438 | # Trying an already failed 'make' (unless somebody else blocks) | |
7439 | } else { | |
7440 | # introduced for turning recursion detection into a distrostatus | |
23a216b4 SP |
7441 | my $error = length $self->{make}>3 |
7442 | ? substr($self->{make},3) : "Unknown error"; | |
7443 | $CPAN::Frontend->mywarn("Could not make: $error\n"); | |
ade94d80 SP |
7444 | $self->store_persistent_state; |
7445 | return; | |
7446 | } | |
7447 | } else { | |
7448 | push @e, "Has already been made"; | |
7449 | } | |
7450 | } | |
6d29edf5 | 7451 | |
f04ea8d1 SP |
7452 | my $later = $self->{later} || $self->{configure_requires_later}; |
7453 | if ($later) { # see also undelay | |
7454 | if ($later) { | |
7455 | push @e, $later; | |
c9869e1c SP |
7456 | } |
7457 | } | |
05454584 | 7458 | |
f04ea8d1 | 7459 | $CPAN::Frontend->myprint(join "", map {" $_\n"} @e) and return if @e; |
b72dd56f SP |
7460 | $builddir = $self->dir or |
7461 | $CPAN::Frontend->mydie("PANIC: Cannot determine build directory\n"); | |
7462 | unless (chdir $builddir) { | |
7463 | push @e, "Couldn't chdir to '$builddir': $!"; | |
7464 | } | |
f04ea8d1 | 7465 | $CPAN::Frontend->mywarn(join "", map {" $_\n"} @e) and return if @e; |
5f05dabc | 7466 | } |
f04ea8d1 SP |
7467 | if ($CPAN::Signal) { |
7468 | delete $self->{force_update}; | |
7469 | return; | |
4d1321a7 | 7470 | } |
c356248b | 7471 | $CPAN::Frontend->myprint("\n CPAN.pm: Going to build ".$self->id."\n\n"); |
05454584 A |
7472 | $self->debug("Changed directory to $builddir") if $CPAN::DEBUG; |
7473 | ||
f14b5cec | 7474 | if ($^O eq 'MacOS') { |
be708cc0 | 7475 | Mac::BuildTools::make($self); |
f14b5cec JH |
7476 | return; |
7477 | } | |
7478 | ||
810a0276 SP |
7479 | my %env; |
7480 | while (my($k,$v) = each %ENV) { | |
7481 | next unless defined $v; | |
7482 | $env{$k} = $v; | |
7483 | } | |
7484 | local %ENV = %env; | |
05454584 | 7485 | my $system; |
810a0276 SP |
7486 | if (my $commandline = $self->prefs->{pl}{commandline}) { |
7487 | $system = $commandline; | |
7488 | $ENV{PERL} = $^X; | |
7489 | } elsif ($self->{'configure'}) { | |
e82b9348 SP |
7490 | $system = $self->{'configure'}; |
7491 | } elsif ($self->{modulebuild}) { | |
f04ea8d1 | 7492 | my($perl) = $self->perl or die "Couldn\'t find executable perl\n"; |
e82b9348 | 7493 | $system = "$perl Build.PL $CPAN::Config->{mbuildpl_arg}"; |
5f05dabc | 7494 | } else { |
f04ea8d1 SP |
7495 | my($perl) = $self->perl or die "Couldn\'t find executable perl\n"; |
7496 | my $switch = ""; | |
d4fd5c69 | 7497 | # This needs a handler that can be turned on or off: |
f04ea8d1 SP |
7498 | # $switch = "-MExtUtils::MakeMaker ". |
7499 | # "-Mops=:default,:filesys_read,:filesys_open,require,chdir" | |
7500 | # if $] > 5.00310; | |
1e8f9a0a | 7501 | my $makepl_arg = $self->make_x_arg("pl"); |
f04ea8d1 SP |
7502 | $ENV{PERL5_CPAN_IS_EXECUTING} = File::Spec->catfile($self->{build_dir}, |
7503 | "Makefile.PL"); | |
7504 | $system = sprintf("%s%s Makefile.PL%s", | |
4d1321a7 A |
7505 | $perl, |
7506 | $switch ? " $switch" : "", | |
1e8f9a0a | 7507 | $makepl_arg ? " $makepl_arg" : "", |
4d1321a7 | 7508 | ); |
d4fd5c69 | 7509 | } |
1e8f9a0a SP |
7510 | if (my $env = $self->prefs->{pl}{env}) { |
7511 | for my $e (keys %$env) { | |
7512 | $ENV{$e} = $env->{$e}; | |
7513 | } | |
7514 | } | |
7515 | if (exists $self->{writemakefile}) { | |
7516 | } else { | |
f04ea8d1 SP |
7517 | local($SIG{ALRM}) = sub { die "inactivity_timeout reached\n" }; |
7518 | my($ret,$pid,$output); | |
7519 | $@ = ""; | |
2ccf00a7 | 7520 | my $go_via_alarm; |
f04ea8d1 | 7521 | if ($CPAN::Config->{inactivity_timeout}) { |
2ccf00a7 SP |
7522 | require Config; |
7523 | if ($Config::Config{d_alarm} | |
7524 | && | |
7525 | $Config::Config{d_alarm} eq "define" | |
7526 | ) { | |
7527 | $go_via_alarm++ | |
7528 | } else { | |
7529 | $CPAN::Frontend->mywarn("Warning: you have configured the config ". | |
7530 | "variable 'inactivity_timeout' to ". | |
7531 | "'$CPAN::Config->{inactivity_timeout}'. But ". | |
7532 | "on this machine the system call 'alarm' ". | |
7533 | "isn't available. This means that we cannot ". | |
7534 | "provide the feature of intercepting long ". | |
7535 | "waiting code and will turn this feature off.\n" | |
7536 | ); | |
7537 | $CPAN::Config->{inactivity_timeout} = 0; | |
7538 | } | |
7539 | } | |
7540 | if ($go_via_alarm) { | |
f04ea8d1 SP |
7541 | if ( $self->_should_report('pl') ) { |
7542 | ($output, $ret) = CPAN::Reporter::record_command( | |
7543 | $system, | |
7544 | $CPAN::Config->{inactivity_timeout}, | |
7545 | ); | |
7546 | CPAN::Reporter::grade_PL( $self, $system, $output, $ret ); | |
7547 | } | |
7548 | else { | |
7549 | eval { | |
7550 | alarm $CPAN::Config->{inactivity_timeout}; | |
7551 | local $SIG{CHLD}; # = sub { wait }; | |
7552 | if (defined($pid = fork)) { | |
7553 | if ($pid) { #parent | |
7554 | # wait; | |
7555 | waitpid $pid, 0; | |
7556 | } else { #child | |
7557 | # note, this exec isn't necessary if | |
7558 | # inactivity_timeout is 0. On the Mac I'd | |
7559 | # suggest, we set it always to 0. | |
7560 | exec $system; | |
7561 | } | |
7562 | } else { | |
7563 | $CPAN::Frontend->myprint("Cannot fork: $!"); | |
7564 | return; | |
2ccf00a7 | 7565 | } |
f04ea8d1 SP |
7566 | }; |
7567 | alarm 0; | |
7568 | if ($@) { | |
7569 | kill 9, $pid; | |
7570 | waitpid $pid, 0; | |
7571 | my $err = "$@"; | |
7572 | $CPAN::Frontend->myprint($err); | |
7573 | $self->{writemakefile} = CPAN::Distrostatus->new("NO $err"); | |
7574 | $@ = ""; | |
7575 | $self->store_persistent_state; | |
7576 | return $self->goodbye("$system -- TIMED OUT"); | |
2ccf00a7 | 7577 | } |
2ccf00a7 | 7578 | } |
f04ea8d1 | 7579 | } else { |
05bab18e | 7580 | if (my $expect_model = $self->_prefs_with_expect("pl")) { |
f04ea8d1 SP |
7581 | # XXX probably want to check _should_report here and warn |
7582 | # about not being able to use CPAN::Reporter with expect | |
05bab18e SP |
7583 | $ret = $self->_run_via_expect($system,$expect_model); |
7584 | if (! defined $ret | |
7585 | && $self->{writemakefile} | |
7586 | && $self->{writemakefile}->failed) { | |
7587 | # timeout | |
7588 | return; | |
7589 | } | |
f04ea8d1 SP |
7590 | } |
7591 | elsif ( $self->_should_report('pl') ) { | |
7592 | ($output, $ret) = CPAN::Reporter::record_command($system); | |
7593 | CPAN::Reporter::grade_PL( $self, $system, $output, $ret ); | |
7594 | } | |
7595 | else { | |
1e8f9a0a SP |
7596 | $ret = system($system); |
7597 | } | |
7598 | if ($ret != 0) { | |
7599 | $self->{writemakefile} = CPAN::Distrostatus | |
7600 | ->new("NO '$system' returned status $ret"); | |
7601 | $CPAN::Frontend->mywarn("Warning: No success on command[$system]\n"); | |
05bab18e | 7602 | $self->store_persistent_state; |
f04ea8d1 SP |
7603 | return $self->goodbye("$system -- NOT OK"); |
7604 | } | |
7605 | } | |
7606 | if (-f "Makefile" || -f "Build") { | |
7607 | $self->{writemakefile} = CPAN::Distrostatus->new("YES"); | |
7608 | delete $self->{make_clean}; # if cleaned before, enable next | |
7609 | } else { | |
7610 | my $makefile = $self->{modulebuild} ? "Build" : "Makefile"; | |
7611 | $self->{writemakefile} = CPAN::Distrostatus | |
7612 | ->new(qq{NO -- No $makefile created}); | |
7613 | $self->store_persistent_state; | |
7614 | return $self->goodbye("$system -- NO $makefile created"); | |
7615 | } | |
7616 | } | |
7617 | if ($CPAN::Signal) { | |
7618 | delete $self->{force_update}; | |
7619 | return; | |
c4d24d4c | 7620 | } |
f04ea8d1 | 7621 | if (my @prereq = $self->unsat_prereq("later")) { |
7d97ad34 SP |
7622 | if ($prereq[0][0] eq "perl") { |
7623 | my $need = "requires perl '$prereq[0][1]'"; | |
7624 | my $id = $self->pretty_id; | |
7625 | $CPAN::Frontend->mywarn("$id $need; you have only $]; giving up\n"); | |
7626 | $self->{make} = CPAN::Distrostatus->new("NO $need"); | |
05bab18e | 7627 | $self->store_persistent_state; |
f04ea8d1 | 7628 | return $self->goodbye("[prereq] -- NOT OK"); |
7d97ad34 | 7629 | } else { |
f04ea8d1 | 7630 | my $follow = eval { $self->follow_prereqs("later",@prereq); }; |
ade94d80 | 7631 | if (0) { |
f04ea8d1 | 7632 | } elsif ($follow) { |
ade94d80 SP |
7633 | # signal success to the queuerunner |
7634 | return 1; | |
7635 | } elsif ($@ && ref $@ && $@->isa("CPAN::Exception::RecursiveDependency")) { | |
7636 | $CPAN::Frontend->mywarn($@); | |
f04ea8d1 | 7637 | return $self->goodbye("[depend] -- NOT OK"); |
ade94d80 | 7638 | } |
7d97ad34 | 7639 | } |
6d29edf5 | 7640 | } |
f04ea8d1 SP |
7641 | if ($CPAN::Signal) { |
7642 | delete $self->{force_update}; | |
7643 | return; | |
1e8f9a0a | 7644 | } |
810a0276 SP |
7645 | if (my $commandline = $self->prefs->{make}{commandline}) { |
7646 | $system = $commandline; | |
b03f445c | 7647 | $ENV{PERL} = CPAN::find_perl; |
e82b9348 | 7648 | } else { |
810a0276 SP |
7649 | if ($self->{modulebuild}) { |
7650 | unless (-f "Build") { | |
7651 | my $cwd = CPAN::anycwd(); | |
7652 | $CPAN::Frontend->mywarn("Alert: no Build file available for 'make $self->{id}'". | |
8ce4ea0b | 7653 | " in cwd[$cwd]. Danger, Will Robinson!\n"); |
810a0276 SP |
7654 | $CPAN::Frontend->mysleep(5); |
7655 | } | |
b72dd56f | 7656 | $system = join " ", $self->_build_command(), $CPAN::Config->{mbuild_arg}; |
810a0276 | 7657 | } else { |
b72dd56f | 7658 | $system = join " ", $self->_make_command(), $CPAN::Config->{make_arg}; |
810a0276 | 7659 | } |
b72dd56f | 7660 | $system =~ s/\s+$//; |
810a0276 SP |
7661 | my $make_arg = $self->make_x_arg("make"); |
7662 | $system = sprintf("%s%s", | |
7663 | $system, | |
7664 | $make_arg ? " $make_arg" : "", | |
7665 | ); | |
e82b9348 | 7666 | } |
1e8f9a0a SP |
7667 | if (my $env = $self->prefs->{make}{env}) { # overriding the local |
7668 | # ENV of PL, not the | |
7669 | # outer ENV, but | |
7670 | # unlikely to be a risk | |
7671 | for my $e (keys %$env) { | |
7672 | $ENV{$e} = $env->{$e}; | |
7673 | } | |
7674 | } | |
05bab18e SP |
7675 | my $expect_model = $self->_prefs_with_expect("make"); |
7676 | my $want_expect = 0; | |
7677 | if ( $expect_model && @{$expect_model->{talk}} ) { | |
7678 | my $can_expect = $CPAN::META->has_inst("Expect"); | |
7679 | if ($can_expect) { | |
7680 | $want_expect = 1; | |
7681 | } else { | |
7682 | $CPAN::Frontend->mywarn("Expect not installed, falling back to ". | |
be34b10d | 7683 | "system()\n"); |
05bab18e SP |
7684 | } |
7685 | } | |
7686 | my $system_ok; | |
7687 | if ($want_expect) { | |
f04ea8d1 SP |
7688 | # XXX probably want to check _should_report here and |
7689 | # warn about not being able to use CPAN::Reporter with expect | |
05bab18e | 7690 | $system_ok = $self->_run_via_expect($system,$expect_model) == 0; |
f04ea8d1 SP |
7691 | } |
7692 | elsif ( $self->_should_report('make') ) { | |
7693 | my ($output, $ret) = CPAN::Reporter::record_command($system); | |
7694 | CPAN::Reporter::grade_make( $self, $system, $output, $ret ); | |
7695 | $system_ok = ! $ret; | |
7696 | } | |
7697 | else { | |
05bab18e SP |
7698 | $system_ok = system($system) == 0; |
7699 | } | |
7700 | $self->introduce_myself; | |
7701 | if ( $system_ok ) { | |
f04ea8d1 SP |
7702 | $CPAN::Frontend->myprint(" $system -- OK\n"); |
7703 | $self->{make} = CPAN::Distrostatus->new("YES"); | |
6d29edf5 | 7704 | } else { |
f04ea8d1 SP |
7705 | $self->{writemakefile} ||= CPAN::Distrostatus->new("YES"); |
7706 | $self->{make} = CPAN::Distrostatus->new("NO"); | |
7707 | $CPAN::Frontend->mywarn(" $system -- NOT OK\n"); | |
6d29edf5 | 7708 | } |
05bab18e | 7709 | $self->store_persistent_state; |
6d29edf5 | 7710 | } |
f610777f | 7711 | |
8ce4ea0b SP |
7712 | # CPAN::Distribution::goodbye ; |
7713 | sub goodbye { | |
7714 | my($self,$goodbye) = @_; | |
7715 | my $id = $self->pretty_id; | |
f04ea8d1 | 7716 | $CPAN::Frontend->mywarn(" $id\n $goodbye\n"); |
8ce4ea0b SP |
7717 | return; |
7718 | } | |
7719 | ||
7720 | # CPAN::Distribution::_run_via_expect ; | |
6658a91b | 7721 | sub _run_via_expect { |
05bab18e SP |
7722 | my($self,$system,$expect_model) = @_; |
7723 | CPAN->debug("system[$system]expect_model[$expect_model]") if $CPAN::DEBUG; | |
1e8f9a0a | 7724 | if ($CPAN::META->has_inst("Expect")) { |
05bab18e | 7725 | my $expo = Expect->new; # expo Expect object; |
1e8f9a0a | 7726 | $expo->spawn($system); |
810a0276 SP |
7727 | $expect_model->{mode} ||= "deterministic"; |
7728 | if ($expect_model->{mode} eq "deterministic") { | |
7729 | return $self->_run_via_expect_deterministic($expo,$expect_model); | |
7730 | } elsif ($expect_model->{mode} eq "anyorder") { | |
7731 | return $self->_run_via_expect_anyorder($expo,$expect_model); | |
05bab18e SP |
7732 | } else { |
7733 | die "Panic: Illegal expect mode: $expect_model->{mode}"; | |
1e8f9a0a | 7734 | } |
1e8f9a0a SP |
7735 | } else { |
7736 | $CPAN::Frontend->mywarn("Expect not installed, falling back to system()\n"); | |
7737 | return system($system); | |
7738 | } | |
7739 | } | |
7740 | ||
05bab18e | 7741 | sub _run_via_expect_anyorder { |
810a0276 SP |
7742 | my($self,$expo,$expect_model) = @_; |
7743 | my $timeout = $expect_model->{timeout} || 5; | |
f04ea8d1 | 7744 | my $reuse = $expect_model->{reuse}; |
810a0276 | 7745 | my @expectacopy = @{$expect_model->{talk}}; # we trash it! |
05bab18e SP |
7746 | my $but = ""; |
7747 | EXPECT: while () { | |
7748 | my($eof,$ran_into_timeout); | |
7749 | my @match = $expo->expect($timeout, | |
7750 | [ eof => sub { | |
7751 | $eof++; | |
7752 | } ], | |
7753 | [ timeout => sub { | |
7754 | $ran_into_timeout++; | |
7755 | } ], | |
7756 | -re => eval"qr{.}", | |
7757 | ); | |
7758 | if ($match[2]) { | |
7759 | $but .= $match[2]; | |
7760 | } | |
7761 | $but .= $expo->clear_accum; | |
7762 | if ($eof) { | |
7763 | $expo->soft_close; | |
7764 | return $expo->exitstatus(); | |
7765 | } elsif ($ran_into_timeout) { | |
7766 | # warn "DEBUG: they are asking a question, but[$but]"; | |
7767 | for (my $i = 0; $i <= $#expectacopy; $i+=2) { | |
7768 | my($next,$send) = @expectacopy[$i,$i+1]; | |
7769 | my $regex = eval "qr{$next}"; | |
7770 | # warn "DEBUG: will compare with regex[$regex]."; | |
7771 | if ($but =~ /$regex/) { | |
7772 | # warn "DEBUG: will send send[$send]"; | |
7773 | $expo->send($send); | |
f04ea8d1 SP |
7774 | # never allow reusing an QA pair unless they told us |
7775 | splice @expectacopy, $i, 2 unless $reuse; | |
05bab18e SP |
7776 | next EXPECT; |
7777 | } | |
7778 | } | |
7779 | my $why = "could not answer a question during the dialog"; | |
7780 | $CPAN::Frontend->mywarn("Failing: $why\n"); | |
7781 | $self->{writemakefile} = | |
7782 | CPAN::Distrostatus->new("NO $why"); | |
7783 | return; | |
7784 | } | |
7785 | } | |
7786 | } | |
7787 | ||
7788 | sub _run_via_expect_deterministic { | |
810a0276 | 7789 | my($self,$expo,$expect_model) = @_; |
05bab18e | 7790 | my $ran_into_timeout; |
810a0276 SP |
7791 | my $timeout = $expect_model->{timeout} || 15; # currently unsettable |
7792 | my $expecta = $expect_model->{talk}; | |
05bab18e | 7793 | EXPECT: for (my $i = 0; $i <= $#$expecta; $i+=2) { |
810a0276 | 7794 | my($re,$send) = @$expecta[$i,$i+1]; |
05bab18e SP |
7795 | CPAN->debug("timeout[$timeout]re[$re]") if $CPAN::DEBUG; |
7796 | my $regex = eval "qr{$re}"; | |
7797 | $expo->expect($timeout, | |
7798 | [ eof => sub { | |
7799 | my $but = $expo->clear_accum; | |
7800 | $CPAN::Frontend->mywarn("EOF (maybe harmless) | |
7801 | expected[$regex]\nbut[$but]\n\n"); | |
7802 | last EXPECT; | |
7803 | } ], | |
7804 | [ timeout => sub { | |
7805 | my $but = $expo->clear_accum; | |
7806 | $CPAN::Frontend->mywarn("TIMEOUT | |
7807 | expected[$regex]\nbut[$but]\n\n"); | |
7808 | $ran_into_timeout++; | |
7809 | } ], | |
7810 | -re => $regex); | |
f04ea8d1 | 7811 | if ($ran_into_timeout) { |
05bab18e SP |
7812 | # note that the caller expects 0 for success |
7813 | $self->{writemakefile} = | |
7814 | CPAN::Distrostatus->new("NO timeout during expect dialog"); | |
7815 | return; | |
7816 | } | |
7817 | $expo->send($send); | |
7818 | } | |
7819 | $expo->soft_close; | |
7820 | return $expo->exitstatus(); | |
7821 | } | |
7822 | ||
b72dd56f | 7823 | #-> CPAN::Distribution::_validate_distropref |
810a0276 SP |
7824 | sub _validate_distropref { |
7825 | my($self,@args) = @_; | |
7826 | if ( | |
7827 | $CPAN::META->has_inst("CPAN::Kwalify") | |
7828 | && | |
7829 | $CPAN::META->has_inst("Kwalify") | |
7830 | ) { | |
7831 | eval {CPAN::Kwalify::_validate("distroprefs",@args);}; | |
7832 | if ($@) { | |
7833 | $CPAN::Frontend->mywarn($@); | |
7834 | } | |
7835 | } else { | |
7836 | CPAN->debug("not validating '@args'") if $CPAN::DEBUG; | |
7837 | } | |
7838 | } | |
7839 | ||
b72dd56f | 7840 | #-> CPAN::Distribution::_find_prefs |
1e8f9a0a | 7841 | sub _find_prefs { |
6658a91b SP |
7842 | my($self) = @_; |
7843 | my $distroid = $self->pretty_id; | |
b72dd56f | 7844 | #CPAN->debug("distroid[$distroid]") if $CPAN::DEBUG; |
1e8f9a0a | 7845 | my $prefs_dir = $CPAN::Config->{prefs_dir}; |
b03f445c | 7846 | return if $prefs_dir =~ /^\s*$/; |
1e8f9a0a SP |
7847 | eval { File::Path::mkpath($prefs_dir); }; |
7848 | if ($@) { | |
7849 | $CPAN::Frontend->mydie("Cannot create directory $prefs_dir"); | |
7850 | } | |
b72dd56f | 7851 | my $yaml_module = CPAN::_yaml_module; |
be34b10d | 7852 | my @extensions; |
1e8f9a0a | 7853 | if ($CPAN::META->has_inst($yaml_module)) { |
be34b10d SP |
7854 | push @extensions, "yml"; |
7855 | } else { | |
7856 | my @fallbacks; | |
7857 | if ($CPAN::META->has_inst("Data::Dumper")) { | |
7858 | push @extensions, "dd"; | |
7859 | push @fallbacks, "Data::Dumper"; | |
7860 | } | |
7861 | if ($CPAN::META->has_inst("Storable")) { | |
7862 | push @extensions, "st"; | |
7863 | push @fallbacks, "Storable"; | |
7864 | } | |
7865 | if (@fallbacks) { | |
7866 | local $" = " and "; | |
7867 | unless ($self->{have_complained_about_missing_yaml}++) { | |
7868 | $CPAN::Frontend->mywarn("'$yaml_module' not installed, falling back ". | |
7869 | "to @fallbacks to read prefs '$prefs_dir'\n"); | |
7870 | } | |
7871 | } else { | |
7872 | unless ($self->{have_complained_about_missing_yaml}++) { | |
7873 | $CPAN::Frontend->mywarn("'$yaml_module' not installed, cannot ". | |
7874 | "read prefs '$prefs_dir'\n"); | |
7875 | } | |
7876 | } | |
7877 | } | |
7878 | if (@extensions) { | |
1e8f9a0a SP |
7879 | my $dh = DirHandle->new($prefs_dir) |
7880 | or die Carp::croak("Couldn't open '$prefs_dir': $!"); | |
7881 | DIRENT: for (sort $dh->read) { | |
7882 | next if $_ eq "." || $_ eq ".."; | |
be34b10d SP |
7883 | my $exte = join "|", @extensions; |
7884 | next unless /\.($exte)$/; | |
7885 | my $thisexte = $1; | |
1e8f9a0a | 7886 | my $abs = File::Spec->catfile($prefs_dir, $_); |
1e8f9a0a | 7887 | if (-f $abs) { |
b72dd56f | 7888 | #CPAN->debug(sprintf "abs[%s]", $abs) if $CPAN::DEBUG; |
be34b10d SP |
7889 | my @distropref; |
7890 | if ($thisexte eq "yml") { | |
b72dd56f SP |
7891 | # need no eval because if we have no YAML we do not try to read *.yml |
7892 | #CPAN->debug(sprintf "before yaml load abs[%s]", $abs) if $CPAN::DEBUG; | |
be34b10d | 7893 | @distropref = @{CPAN->_yaml_loadfile($abs)}; |
b72dd56f | 7894 | #CPAN->debug(sprintf "after yaml load abs[%s]", $abs) if $CPAN::DEBUG; |
be34b10d SP |
7895 | } elsif ($thisexte eq "dd") { |
7896 | package CPAN::Eval; | |
7897 | no strict; | |
7898 | open FH, "<$abs" or $CPAN::Frontend->mydie("Could not open '$abs': $!"); | |
7899 | local $/; | |
7900 | my $eval = <FH>; | |
7901 | close FH; | |
7902 | eval $eval; | |
7903 | if ($@) { | |
7904 | $CPAN::Frontend->mydie("Error in distroprefs file $_\: $@"); | |
7905 | } | |
7906 | my $i = 1; | |
7907 | while (${"VAR".$i}) { | |
7908 | push @distropref, ${"VAR".$i}; | |
7909 | $i++; | |
7910 | } | |
7911 | } elsif ($thisexte eq "st") { | |
7912 | # eval because Storable is never forward compatible | |
7913 | eval { @distropref = @{scalar Storable::retrieve($abs)}; }; | |
7914 | if ($@) { | |
7915 | $CPAN::Frontend->mywarn("Error reading distroprefs file ". | |
7916 | "$_, skipping\: $@"); | |
7917 | $CPAN::Frontend->mysleep(4); | |
7918 | next DIRENT; | |
7919 | } | |
7920 | } | |
6658a91b | 7921 | # $DB::single=1; |
b72dd56f | 7922 | #CPAN->debug(sprintf "#distropref[%d]", scalar @distropref) if $CPAN::DEBUG; |
be34b10d SP |
7923 | ELEMENT: for my $y (0..$#distropref) { |
7924 | my $distropref = $distropref[$y]; | |
810a0276 | 7925 | $self->_validate_distropref($distropref,$abs,$y); |
be34b10d | 7926 | my $match = $distropref->{match}; |
6658a91b | 7927 | unless ($match) { |
b72dd56f | 7928 | #CPAN->debug("no 'match' in abs[$abs], skipping") if $CPAN::DEBUG; |
6658a91b SP |
7929 | next ELEMENT; |
7930 | } | |
7931 | my $ok = 1; | |
b72dd56f SP |
7932 | # do not take the order of C<keys %$match> because |
7933 | # "module" is by far the slowest | |
2b3bde2a SP |
7934 | my $saw_valid_subkeys = 0; |
7935 | for my $sub_attribute (qw(distribution perl perlconfig module)) { | |
b72dd56f | 7936 | next unless exists $match->{$sub_attribute}; |
2b3bde2a | 7937 | $saw_valid_subkeys++; |
be34b10d | 7938 | my $qr = eval "qr{$distropref->{match}{$sub_attribute}}"; |
6658a91b SP |
7939 | if ($sub_attribute eq "module") { |
7940 | my $okm = 0; | |
b72dd56f | 7941 | #CPAN->debug(sprintf "distropref[%d]", scalar @distropref) if $CPAN::DEBUG; |
6658a91b | 7942 | my @modules = $self->containsmods; |
b72dd56f | 7943 | #CPAN->debug(sprintf "modules[%s]", join(",",@modules)) if $CPAN::DEBUG; |
6658a91b SP |
7944 | MODULE: for my $module (@modules) { |
7945 | $okm ||= $module =~ /$qr/; | |
7946 | last MODULE if $okm; | |
7947 | } | |
7948 | $ok &&= $okm; | |
7949 | } elsif ($sub_attribute eq "distribution") { | |
7950 | my $okd = $distroid =~ /$qr/; | |
7951 | $ok &&= $okd; | |
7952 | } elsif ($sub_attribute eq "perl") { | |
b03f445c | 7953 | my $okp = CPAN::find_perl =~ /$qr/; |
6658a91b | 7954 | $ok &&= $okp; |
f04ea8d1 SP |
7955 | } elsif ($sub_attribute eq "perlconfig") { |
7956 | for my $perlconfigkey (keys %{$match->{perlconfig}}) { | |
7957 | my $perlconfigval = $match->{perlconfig}->{$perlconfigkey}; | |
7958 | # XXX should probably warn if Config does not exist | |
7959 | my $okpc = $Config::Config{$perlconfigkey} =~ /$perlconfigval/; | |
7960 | $ok &&= $okpc; | |
7961 | last if $ok == 0; | |
7962 | } | |
6658a91b | 7963 | } else { |
be34b10d | 7964 | $CPAN::Frontend->mydie("Nonconforming .$thisexte file '$abs': ". |
6658a91b SP |
7965 | "unknown sub_attribut '$sub_attribute'. ". |
7966 | "Please ". | |
7967 | "remove, cannot continue."); | |
1e8f9a0a | 7968 | } |
b72dd56f | 7969 | last if $ok == 0; # short circuit |
1e8f9a0a | 7970 | } |
2b3bde2a SP |
7971 | unless ($saw_valid_subkeys) { |
7972 | $CPAN::Frontend->mydie("Nonconforming .$thisexte file '$abs': ". | |
7973 | "missing match/* subattribute. ". | |
7974 | "Please ". | |
7975 | "remove, cannot continue."); | |
7976 | } | |
b72dd56f | 7977 | #CPAN->debug(sprintf "ok[%d]", $ok) if $CPAN::DEBUG; |
6658a91b SP |
7978 | if ($ok) { |
7979 | return { | |
be34b10d | 7980 | prefs => $distropref, |
6658a91b | 7981 | prefs_file => $abs, |
05bab18e | 7982 | prefs_file_doc => $y, |
6658a91b SP |
7983 | }; |
7984 | } | |
7985 | ||
1e8f9a0a SP |
7986 | } |
7987 | } | |
7988 | } | |
b72dd56f | 7989 | $dh->close; |
1e8f9a0a SP |
7990 | } |
7991 | return; | |
7992 | } | |
7993 | ||
7994 | # CPAN::Distribution::prefs | |
7995 | sub prefs { | |
7996 | my($self) = @_; | |
f20de9f0 SP |
7997 | if (exists $self->{negative_prefs_cache} |
7998 | && | |
7999 | $self->{negative_prefs_cache} != $CPAN::CurrentCommandId | |
8000 | ) { | |
8001 | delete $self->{negative_prefs_cache}; | |
8002 | delete $self->{prefs}; | |
8003 | } | |
1e8f9a0a SP |
8004 | if (exists $self->{prefs}) { |
8005 | return $self->{prefs}; # XXX comment out during debugging | |
8006 | } | |
8007 | if ($CPAN::Config->{prefs_dir}) { | |
8008 | CPAN->debug("prefs_dir[$CPAN::Config->{prefs_dir}]") if $CPAN::DEBUG; | |
6658a91b | 8009 | my $prefs = $self->_find_prefs(); |
b72dd56f SP |
8010 | $prefs ||= ""; # avoid warning next line |
8011 | CPAN->debug("prefs[$prefs]") if $CPAN::DEBUG; | |
1e8f9a0a | 8012 | if ($prefs) { |
05bab18e | 8013 | for my $x (qw(prefs prefs_file prefs_file_doc)) { |
1e8f9a0a SP |
8014 | $self->{$x} = $prefs->{$x}; |
8015 | } | |
6658a91b SP |
8016 | my $bs = sprintf( |
8017 | "%s[%s]", | |
8018 | File::Basename::basename($self->{prefs_file}), | |
05bab18e | 8019 | $self->{prefs_file_doc}, |
6658a91b | 8020 | ); |
1e8f9a0a | 8021 | my $filler1 = "_" x 22; |
6658a91b | 8022 | my $filler2 = int(66 - length($bs))/2; |
1e8f9a0a SP |
8023 | $filler2 = 0 if $filler2 < 0; |
8024 | $filler2 = " " x $filler2; | |
8025 | $CPAN::Frontend->myprint(" | |
8026 | $filler1 D i s t r o P r e f s $filler1 | |
6658a91b | 8027 | $filler2 $bs $filler2 |
1e8f9a0a SP |
8028 | "); |
8029 | $CPAN::Frontend->mysleep(1); | |
8030 | return $self->{prefs}; | |
8031 | } | |
8032 | } | |
f20de9f0 SP |
8033 | $self->{negative_prefs_cache} = $CPAN::CurrentCommandId; |
8034 | return $self->{prefs} = +{}; | |
1e8f9a0a SP |
8035 | } |
8036 | ||
8037 | # CPAN::Distribution::make_x_arg | |
8038 | sub make_x_arg { | |
8039 | my($self, $whixh) = @_; | |
8040 | my $make_x_arg; | |
8041 | my $prefs = $self->prefs; | |
8042 | if ( | |
8043 | $prefs | |
8044 | && exists $prefs->{$whixh} | |
8045 | && exists $prefs->{$whixh}{args} | |
8046 | && $prefs->{$whixh}{args} | |
8047 | ) { | |
8048 | $make_x_arg = join(" ", | |
8049 | map {CPAN::HandleConfig | |
8050 | ->safe_quote($_)} @{$prefs->{$whixh}{args}}, | |
8051 | ); | |
8052 | } | |
8053 | my $what = sprintf "make%s_arg", $whixh eq "make" ? "" : $whixh; | |
8054 | $make_x_arg ||= $CPAN::Config->{$what}; | |
8055 | return $make_x_arg; | |
8056 | } | |
8057 | ||
8058 | # CPAN::Distribution::_make_command | |
9ddc4ed0 | 8059 | sub _make_command { |
ed84aac9 A |
8060 | my ($self) = @_; |
8061 | if ($self) { | |
8062 | return | |
1e8f9a0a | 8063 | CPAN::HandleConfig |
ed84aac9 | 8064 | ->safe_quote( |
6658a91b SP |
8065 | CPAN::HandleConfig->prefs_lookup($self, |
8066 | q{make}) | |
1e8f9a0a SP |
8067 | || $Config::Config{make} |
8068 | || 'make' | |
ed84aac9 A |
8069 | ); |
8070 | } else { | |
8071 | # Old style call, without object. Deprecated | |
8072 | Carp::confess("CPAN::_make_command() used as function. Don't Do That."); | |
8073 | return | |
1e8f9a0a | 8074 | safe_quote(undef, |
6658a91b | 8075 | CPAN::HandleConfig->prefs_lookup($self,q{make}) |
1e8f9a0a SP |
8076 | || $CPAN::Config->{make} |
8077 | || $Config::Config{make} | |
8078 | || 'make'); | |
ed84aac9 | 8079 | } |
9ddc4ed0 A |
8080 | } |
8081 | ||
c9869e1c | 8082 | #-> sub CPAN::Distribution::follow_prereqs ; |
6d29edf5 JH |
8083 | sub follow_prereqs { |
8084 | my($self) = shift; | |
f04ea8d1 | 8085 | my($slot) = shift; |
135a59c2 A |
8086 | my(@prereq_tuples) = grep {$_->[0] ne "perl"} @_; |
8087 | return unless @prereq_tuples; | |
8088 | my @prereq = map { $_->[0] } @prereq_tuples; | |
6658a91b | 8089 | my $pretty_id = $self->pretty_id; |
135a59c2 A |
8090 | my %map = ( |
8091 | b => "build_requires", | |
8092 | r => "requires", | |
8093 | c => "commandline", | |
8094 | ); | |
6658a91b | 8095 | my($filler1,$filler2,$filler3,$filler4); |
f20de9f0 | 8096 | # $DB::single=1; |
6658a91b SP |
8097 | my $unsat = "Unsatisfied dependencies detected during"; |
8098 | my $w = length($unsat) > length($pretty_id) ? length($unsat) : length($pretty_id); | |
8099 | { | |
8100 | my $r = int(($w - length($unsat))/2); | |
8101 | my $l = $w - length($unsat) - $r; | |
8102 | $filler1 = "-"x4 . " "x$l; | |
8103 | $filler2 = " "x$r . "-"x4 . "\n"; | |
8104 | } | |
8105 | { | |
8106 | my $r = int(($w - length($pretty_id))/2); | |
8107 | my $l = $w - length($pretty_id) - $r; | |
8108 | $filler3 = "-"x4 . " "x$l; | |
8109 | $filler4 = " "x$r . "-"x4 . "\n"; | |
8110 | } | |
135a59c2 | 8111 | $CPAN::Frontend-> |
6658a91b SP |
8112 | myprint("$filler1 $unsat $filler2". |
8113 | "$filler3 $pretty_id $filler4". | |
135a59c2 A |
8114 | join("", map {" $_->[0] \[$map{$_->[1]}]\n"} @prereq_tuples), |
8115 | ); | |
6d29edf5 JH |
8116 | my $follow = 0; |
8117 | if ($CPAN::Config->{prerequisites_policy} eq "follow") { | |
f04ea8d1 | 8118 | $follow = 1; |
6d29edf5 | 8119 | } elsif ($CPAN::Config->{prerequisites_policy} eq "ask") { |
f04ea8d1 | 8120 | my $answer = CPAN::Shell::colorable_makemaker_prompt( |
f610777f A |
8121 | "Shall I follow them and prepend them to the queue |
8122 | of modules we are processing right now?", "yes"); | |
f04ea8d1 | 8123 | $follow = $answer =~ /^\s*y/i; |
6d29edf5 | 8124 | } else { |
f04ea8d1 SP |
8125 | local($") = ", "; |
8126 | $CPAN::Frontend-> | |
de34a54b | 8127 | myprint(" Ignoring dependencies on modules @prereq\n"); |
f610777f | 8128 | } |
6d29edf5 | 8129 | if ($follow) { |
6658a91b | 8130 | my $id = $self->id; |
6d29edf5 JH |
8131 | # color them as dirty |
8132 | for my $p (@prereq) { | |
35576f8c | 8133 | # warn "calling color_cmd_tmps(0,1)"; |
810a0276 | 8134 | my $any = CPAN::Shell->expandany($p); |
f04ea8d1 | 8135 | $self->{$slot . "_for"}{$any->id}++; |
810a0276 | 8136 | if ($any) { |
f20de9f0 | 8137 | $any->color_cmd_tmps(0,2); |
810a0276 SP |
8138 | } else { |
8139 | $CPAN::Frontend->mywarn("Warning (maybe a bug): Cannot expand prereq '$p'\n"); | |
8140 | $CPAN::Frontend->mysleep(2); | |
8141 | } | |
6d29edf5 | 8142 | } |
135a59c2 | 8143 | # queue them and re-queue yourself |
f04ea8d1 SP |
8144 | CPAN::Queue->jumpqueue({qmod => $id, reqtype => $self->{reqtype}}, |
8145 | map {+{qmod=>$_->[0],reqtype=>$_->[1]}} reverse @prereq_tuples); | |
8146 | $self->{$slot} = "Delayed until after prerequisites"; | |
6d29edf5 JH |
8147 | return 1; # signal success to the queuerunner |
8148 | } | |
f04ea8d1 | 8149 | return; |
6d29edf5 JH |
8150 | } |
8151 | ||
8152 | #-> sub CPAN::Distribution::unsat_prereq ; | |
7d97ad34 SP |
8153 | # return ([Foo=>1],[Bar=>1.2]) for normal modules |
8154 | # return ([perl=>5.008]) if we need a newer perl than we are running under | |
6d29edf5 | 8155 | sub unsat_prereq { |
f04ea8d1 SP |
8156 | my($self,$slot) = @_; |
8157 | my(%merged,$prereq_pm); | |
8158 | my $prefs_depends = $self->prefs->{depends}||{}; | |
8159 | if ($slot eq "configure_requires_later") { | |
8160 | my $meta_yml = $self->parse_meta_yml(); | |
8161 | %merged = (%{$meta_yml->{configure_requires}||{}}, | |
8162 | %{$prefs_depends->{configure_requires}||{}}); | |
8163 | $prereq_pm = {}; # configure_requires defined as "b" | |
8164 | } elsif ($slot eq "later") { | |
8165 | my $prereq_pm_0 = $self->prereq_pm || {}; | |
8166 | for my $reqtype (qw(requires build_requires)) { | |
8167 | $prereq_pm->{$reqtype} = {%{$prereq_pm_0->{$reqtype}||{}}}; # copy to not pollute it | |
8168 | for my $k (keys %{$prefs_depends->{$reqtype}||{}}) { | |
8169 | $prereq_pm->{$reqtype}{$k} = $prefs_depends->{$reqtype}{$k}; | |
8170 | } | |
8171 | } | |
8172 | %merged = (%{$prereq_pm->{requires}||{}},%{$prereq_pm->{build_requires}||{}}); | |
8173 | } else { | |
8174 | die "Panic: illegal slot '$slot'"; | |
8175 | } | |
6d29edf5 | 8176 | my(@need); |
f20de9f0 SP |
8177 | my @merged = %merged; |
8178 | CPAN->debug("all merged_prereqs[@merged]") if $CPAN::DEBUG; | |
135a59c2 | 8179 | NEED: while (my($need_module, $need_version) = each %merged) { |
f20de9f0 | 8180 | my($available_version,$available_file,$nmo); |
7d97ad34 | 8181 | if ($need_module eq "perl") { |
b72dd56f | 8182 | $available_version = $]; |
b03f445c | 8183 | $available_file = CPAN::find_perl; |
7d97ad34 | 8184 | } else { |
f20de9f0 | 8185 | $nmo = $CPAN::META->instance("CPAN::Module",$need_module); |
7d97ad34 | 8186 | next if $nmo->uptodate; |
b72dd56f | 8187 | $available_file = $nmo->available_file; |
7d97ad34 SP |
8188 | |
8189 | # if they have not specified a version, we accept any installed one | |
ade94d80 SP |
8190 | if (defined $available_file |
8191 | and ( # a few quick shortcurcuits | |
8192 | not defined $need_version | |
8193 | or $need_version eq '0' # "==" would trigger warning when not numeric | |
8194 | or $need_version eq "undef" | |
8195 | )) { | |
8196 | next NEED; | |
7d97ad34 SP |
8197 | } |
8198 | ||
b72dd56f | 8199 | $available_version = $nmo->available_version; |
6d29edf5 JH |
8200 | } |
8201 | ||
8202 | # We only want to install prereqs if either they're not installed | |
8203 | # or if the installed version is too old. We cannot omit this | |
8204 | # check, because if 'force' is in effect, nobody else will check. | |
b72dd56f | 8205 | if (defined $available_file) { |
e82b9348 | 8206 | my(@all_requirements) = split /\s*,\s*/, $need_version; |
6d29edf5 | 8207 | local($^W) = 0; |
e82b9348 SP |
8208 | my $ok = 0; |
8209 | RQ: for my $rq (@all_requirements) { | |
8210 | if ($rq =~ s|>=\s*||) { | |
8211 | } elsif ($rq =~ s|>\s*||) { | |
8212 | # 2005-12: one user | |
f04ea8d1 | 8213 | if (CPAN::Version->vgt($available_version,$rq)) { |
e82b9348 SP |
8214 | $ok++; |
8215 | } | |
8216 | next RQ; | |
8217 | } elsif ($rq =~ s|!=\s*||) { | |
8218 | # 2005-12: no user | |
f04ea8d1 | 8219 | if (CPAN::Version->vcmp($available_version,$rq)) { |
e82b9348 SP |
8220 | $ok++; |
8221 | next RQ; | |
8222 | } else { | |
8223 | last RQ; | |
8224 | } | |
8225 | } elsif ($rq =~ m|<=?\s*|) { | |
8226 | # 2005-12: no user | |
810a0276 | 8227 | $CPAN::Frontend->mywarn("Downgrading not supported (rq[$rq])\n"); |
e82b9348 SP |
8228 | $ok++; |
8229 | next RQ; | |
8230 | } | |
f04ea8d1 | 8231 | if (! CPAN::Version->vgt($rq, $available_version)) { |
e82b9348 SP |
8232 | $ok++; |
8233 | } | |
b72dd56f SP |
8234 | CPAN->debug(sprintf("need_module[%s]available_file[%s]". |
8235 | "available_version[%s]rq[%s]ok[%d]", | |
7d97ad34 | 8236 | $need_module, |
b72dd56f SP |
8237 | $available_file, |
8238 | $available_version, | |
7d97ad34 SP |
8239 | CPAN::Version->readable($rq), |
8240 | $ok, | |
8241 | )) if $CPAN::DEBUG; | |
6d29edf5 | 8242 | } |
e82b9348 | 8243 | next NEED if $ok == @all_requirements; |
6d29edf5 JH |
8244 | } |
8245 | ||
7d97ad34 SP |
8246 | if ($need_module eq "perl") { |
8247 | return ["perl", $need_version]; | |
8248 | } | |
f04ea8d1 SP |
8249 | $self->{sponsored_mods}{$need_module} ||= 0; |
8250 | CPAN->debug("need_module[$need_module]s/s/n[$self->{sponsored_mods}{$need_module}]") if $CPAN::DEBUG; | |
8251 | if ($self->{sponsored_mods}{$need_module}++) { | |
6d29edf5 | 8252 | # We have already sponsored it and for some reason it's still |
f20de9f0 SP |
8253 | # not available. So we do ... what?? |
8254 | ||
6d29edf5 | 8255 | # if we push it again, we have a potential infinite loop |
f20de9f0 SP |
8256 | |
8257 | # The following "next" was a very problematic construct. | |
23a216b4 SP |
8258 | # It helped a lot but broke some day and had to be |
8259 | # replaced. | |
f20de9f0 SP |
8260 | |
8261 | # We must be able to deal with modules that come again and | |
8262 | # again as a prereq and have themselves prereqs and the | |
8263 | # queue becomes long but finally we would find the correct | |
8264 | # order. The RecursiveDependency check should trigger a | |
8265 | # die when it's becoming too weird. Unfortunately removing | |
8266 | # this next breaks many other things. | |
8267 | ||
8268 | # The bug that brought this up is described in Todo under | |
8269 | # "5.8.9 cannot install Compress::Zlib" | |
8270 | ||
23a216b4 | 8271 | # next; # this is the next that had to go away |
f20de9f0 SP |
8272 | |
8273 | # The following "next NEED" are fine and the error message | |
8274 | # explains well what is going on. For example when the DBI | |
8275 | # fails and consequently DBD::SQLite fails and now we are | |
8276 | # processing CPAN::SQLite. Then we must have a "next" for | |
8277 | # DBD::SQLite. How can we get it and how can we identify | |
8278 | # all other cases we must identify? | |
8279 | ||
8280 | my $do = $nmo->distribution; | |
8281 | next NEED unless $do; # not on CPAN | |
ecc7fca0 | 8282 | if (CPAN::Version->vcmp($need_version, $nmo->ro->{CPAN_VERSION}) > 0){ |
b03f445c RGS |
8283 | $CPAN::Frontend->mywarn("Warning: Prerequisite ". |
8284 | "'$need_module => $need_version' ". | |
8285 | "for '$self->{ID}' seems ". | |
ecc7fca0 | 8286 | "not available according to the indexes\n" |
b03f445c RGS |
8287 | ); |
8288 | next NEED; | |
8289 | } | |
f20de9f0 SP |
8290 | NOSAYER: for my $nosayer ( |
8291 | "unwrapped", | |
8292 | "writemakefile", | |
8293 | "signature_verify", | |
8294 | "make", | |
8295 | "make_test", | |
8296 | "install", | |
8297 | "make_clean", | |
8298 | ) { | |
23a216b4 SP |
8299 | if ($do->{$nosayer}) { |
8300 | if (UNIVERSAL::can($do->{$nosayer},"failed") ? | |
8301 | $do->{$nosayer}->failed : | |
8302 | $do->{$nosayer} =~ /^NO/) { | |
8303 | if ($nosayer eq "make_test" | |
8304 | && | |
8305 | $do->{make_test}{COMMANDID} != $CPAN::CurrentCommandId | |
8306 | ) { | |
8307 | next NOSAYER; | |
8308 | } | |
8309 | $CPAN::Frontend->mywarn("Warning: Prerequisite ". | |
8310 | "'$need_module => $need_version' ". | |
8311 | "for '$self->{ID}' failed when ". | |
8312 | "processing '$do->{ID}' with ". | |
8313 | "'$nosayer => $do->{$nosayer}'. Continuing, ". | |
8314 | "but chances to succeed are limited.\n" | |
8315 | ); | |
8316 | next NEED; | |
8317 | } else { # the other guy succeeded | |
8318 | if ($nosayer eq "install") { | |
8319 | # we had this with | |
8320 | # DMAKI/DateTime-Calendar-Chinese-0.05.tar.gz | |
8321 | # 2007-03 | |
8322 | $CPAN::Frontend->mywarn("Warning: Prerequisite ". | |
8323 | "'$need_module => $need_version' ". | |
8324 | "for '$self->{ID}' already installed ". | |
8325 | "but installation looks suspicious. ". | |
8326 | "Skipping another installation attempt, ". | |
8327 | "to prevent looping endlessly.\n" | |
8328 | ); | |
8329 | next NEED; | |
8330 | } | |
f20de9f0 | 8331 | } |
f20de9f0 SP |
8332 | } |
8333 | } | |
6d29edf5 | 8334 | } |
135a59c2 A |
8335 | my $needed_as = exists $prereq_pm->{requires}{$need_module} ? "r" : "b"; |
8336 | push @need, [$need_module,$needed_as]; | |
5f05dabc | 8337 | } |
f20de9f0 SP |
8338 | my @unfolded = map { "[".join(",",@$_)."]" } @need; |
8339 | CPAN->debug("returning from unsat_prereq[@unfolded]") if $CPAN::DEBUG; | |
6d29edf5 | 8340 | @need; |
5f05dabc | 8341 | } |
8342 | ||
e82b9348 SP |
8343 | #-> sub CPAN::Distribution::read_yaml ; |
8344 | sub read_yaml { | |
8345 | my($self) = @_; | |
8346 | return $self->{yaml_content} if exists $self->{yaml_content}; | |
8347 | my $build_dir = $self->{build_dir}; | |
8348 | my $yaml = File::Spec->catfile($build_dir,"META.yml"); | |
44d21104 | 8349 | $self->debug("yaml[$yaml]") if $CPAN::DEBUG; |
e82b9348 | 8350 | return unless -f $yaml; |
6658a91b | 8351 | eval { $self->{yaml_content} = CPAN->_yaml_loadfile($yaml)->[0]; }; |
1e8f9a0a | 8352 | if ($@) { |
b72dd56f | 8353 | $CPAN::Frontend->mywarn("Could not read ". |
be34b10d SP |
8354 | "'$yaml'. Falling back to other ". |
8355 | "methods to determine prerequisites\n"); | |
b72dd56f SP |
8356 | return $self->{yaml_content} = undef; # if we die, then we |
8357 | # cannot read YAML's own | |
8358 | # META.yml | |
1e8f9a0a | 8359 | } |
f20de9f0 | 8360 | # not "authoritative" |
1e8f9a0a SP |
8361 | if (not exists $self->{yaml_content}{dynamic_config} |
8362 | or $self->{yaml_content}{dynamic_config} | |
8363 | ) { | |
8364 | $self->{yaml_content} = undef; | |
e82b9348 | 8365 | } |
135a59c2 A |
8366 | $self->debug(sprintf "yaml_content[%s]", $self->{yaml_content} || "UNDEF") |
8367 | if $CPAN::DEBUG; | |
e82b9348 SP |
8368 | return $self->{yaml_content}; |
8369 | } | |
8370 | ||
6d29edf5 JH |
8371 | #-> sub CPAN::Distribution::prereq_pm ; |
8372 | sub prereq_pm { | |
e82b9348 | 8373 | my($self) = @_; |
be34b10d | 8374 | $self->{prereq_pm_detected} ||= 0; |
f20de9f0 | 8375 | CPAN->debug("ID[$self->{ID}]prereq_pm_detected[$self->{prereq_pm_detected}]") if $CPAN::DEBUG; |
be34b10d | 8376 | return $self->{prereq_pm} if $self->{prereq_pm_detected}; |
e82b9348 SP |
8377 | return unless $self->{writemakefile} # no need to have succeeded |
8378 | # but we must have run it | |
c9869e1c | 8379 | || $self->{modulebuild}; |
be34b10d SP |
8380 | CPAN->debug(sprintf "writemakefile[%s]modulebuild[%s]", |
8381 | $self->{writemakefile}||"", | |
8382 | $self->{modulebuild}||"", | |
8383 | ) if $CPAN::DEBUG; | |
135a59c2 A |
8384 | my($req,$breq); |
8385 | if (my $yaml = $self->read_yaml) { # often dynamic_config prevents a result here | |
8386 | $req = $yaml->{requires} || {}; | |
8387 | $breq = $yaml->{build_requires} || {}; | |
e82b9348 SP |
8388 | undef $req unless ref $req eq "HASH" && %$req; |
8389 | if ($req) { | |
810a0276 SP |
8390 | if ($yaml->{generated_by} && |
8391 | $yaml->{generated_by} =~ /ExtUtils::MakeMaker version ([\d\._]+)/) { | |
e82b9348 SP |
8392 | my $eummv = do { local $^W = 0; $1+0; }; |
8393 | if ($eummv < 6.2501) { | |
8394 | # thanks to Slaven for digging that out: MM before | |
8395 | # that could be wrong because it could reflect a | |
8396 | # previous release | |
8397 | undef $req; | |
8398 | } | |
8399 | } | |
8400 | my $areq; | |
8401 | my $do_replace; | |
3ff97d55 | 8402 | while (my($k,$v) = each %{$req||{}}) { |
e82b9348 SP |
8403 | if ($v =~ /\d/) { |
8404 | $areq->{$k} = $v; | |
8405 | } elsif ($k =~ /[A-Za-z]/ && | |
8406 | $v =~ /[A-Za-z]/ && | |
8407 | $CPAN::META->exists("Module",$v) | |
8408 | ) { | |
8409 | $CPAN::Frontend->mywarn("Suspicious key-value pair in META.yml's ". | |
8410 | "requires hash: $k => $v; I'll take both ". | |
8411 | "key and value as a module name\n"); | |
8962fc49 | 8412 | $CPAN::Frontend->mysleep(1); |
e82b9348 SP |
8413 | $areq->{$k} = 0; |
8414 | $areq->{$v} = 0; | |
8415 | $do_replace++; | |
8416 | } | |
8417 | } | |
8418 | $req = $areq if $do_replace; | |
8419 | } | |
e82b9348 | 8420 | } |
135a59c2 | 8421 | unless ($req || $breq) { |
e82b9348 SP |
8422 | my $build_dir = $self->{build_dir} or die "Panic: no build_dir?"; |
8423 | my $makefile = File::Spec->catfile($build_dir,"Makefile"); | |
8424 | my $fh; | |
8425 | if (-f $makefile | |
8426 | and | |
8427 | $fh = FileHandle->new("<$makefile\0")) { | |
be34b10d | 8428 | CPAN->debug("Getting prereq from Makefile") if $CPAN::DEBUG; |
e82b9348 SP |
8429 | local($/) = "\n"; |
8430 | while (<$fh>) { | |
8431 | last if /MakeMaker post_initialize section/; | |
8432 | my($p) = m{^[\#] | |
8433 | \s+PREREQ_PM\s+=>\s+(.+) | |
8434 | }x; | |
8435 | next unless $p; | |
8436 | # warn "Found prereq expr[$p]"; | |
8437 | ||
8438 | # Regexp modified by A.Speer to remember actual version of file | |
8439 | # PREREQ_PM hash key wants, then add to | |
f04ea8d1 | 8440 | while ( $p =~ m/(?:\s)([\w\:]+)=>(q\[.*?\]|undef),?/g ) { |
e82b9348 SP |
8441 | # In case a prereq is mentioned twice, complain. |
8442 | if ( defined $req->{$1} ) { | |
8443 | warn "Warning: PREREQ_PM mentions $1 more than once, ". | |
8444 | "last mention wins"; | |
8445 | } | |
f20de9f0 SP |
8446 | my($m,$n) = ($1,$2); |
8447 | if ($n =~ /^q\[(.*?)\]$/) { | |
8448 | $n = $1; | |
8449 | } | |
8450 | $req->{$m} = $n; | |
e82b9348 SP |
8451 | } |
8452 | last; | |
8453 | } | |
be34b10d SP |
8454 | } |
8455 | } | |
8456 | unless ($req || $breq) { | |
8457 | my $build_dir = $self->{build_dir} or die "Panic: no build_dir?"; | |
8458 | my $buildfile = File::Spec->catfile($build_dir,"Build"); | |
8459 | if (-f $buildfile) { | |
8460 | CPAN->debug("Found '$buildfile'") if $CPAN::DEBUG; | |
8461 | my $build_prereqs = File::Spec->catfile($build_dir,"_build","prereqs"); | |
8462 | if (-f $build_prereqs) { | |
8463 | CPAN->debug("Getting prerequisites from '$build_prereqs'") if $CPAN::DEBUG; | |
8464 | my $content = do { local *FH; | |
8465 | open FH, $build_prereqs | |
8466 | or $CPAN::Frontend->mydie("Could not open ". | |
8467 | "'$build_prereqs': $!"); | |
8468 | local $/; | |
8469 | <FH>; | |
8470 | }; | |
8471 | my $bphash = eval $content; | |
6a935156 | 8472 | if ($@) { |
be34b10d SP |
8473 | } else { |
8474 | $req = $bphash->{requires} || +{}; | |
8475 | $breq = $bphash->{build_requires} || +{}; | |
6a935156 | 8476 | } |
9ddc4ed0 | 8477 | } |
e82b9348 SP |
8478 | } |
8479 | } | |
7d97ad34 SP |
8480 | if (-f "Build.PL" |
8481 | && ! -f "Makefile.PL" | |
8482 | && ! exists $req->{"Module::Build"} | |
8483 | && ! $CPAN::META->has_inst("Module::Build")) { | |
c9869e1c SP |
8484 | $CPAN::Frontend->mywarn(" Warning: CPAN.pm discovered Module::Build as ". |
8485 | "undeclared prerequisite.\n". | |
135a59c2 | 8486 | " Adding it now as such.\n" |
c9869e1c SP |
8487 | ); |
8488 | $CPAN::Frontend->mysleep(5); | |
8489 | $req->{"Module::Build"} = 0; | |
8490 | delete $self->{writemakefile}; | |
8491 | } | |
be34b10d SP |
8492 | if ($req || $breq) { |
8493 | $self->{prereq_pm_detected}++; | |
8494 | return $self->{prereq_pm} = { requires => $req, build_requires => $breq }; | |
8495 | } | |
f610777f A |
8496 | } |
8497 | ||
05454584 A |
8498 | #-> sub CPAN::Distribution::test ; |
8499 | sub test { | |
5f05dabc | 8500 | my($self) = @_; |
be34b10d SP |
8501 | if (my $goto = $self->prefs->{goto}) { |
8502 | return $self->goto($goto); | |
8503 | } | |
05454584 | 8504 | $self->make; |
f04ea8d1 | 8505 | if ($CPAN::Signal) { |
c4d24d4c A |
8506 | delete $self->{force_update}; |
8507 | return; | |
8508 | } | |
554a9ef5 SP |
8509 | # warn "XDEBUG: checking for notest: $self->{notest} $self"; |
8510 | if ($self->{notest}) { | |
e82b9348 SP |
8511 | $CPAN::Frontend->myprint("Skipping test because of notest pragma\n"); |
8512 | return 1; | |
554a9ef5 SP |
8513 | } |
8514 | ||
e82b9348 | 8515 | my $make = $self->{modulebuild} ? "Build" : "make"; |
6658a91b SP |
8516 | |
8517 | local $ENV{PERL5LIB} = defined($ENV{PERL5LIB}) | |
8518 | ? $ENV{PERL5LIB} | |
8519 | : ($ENV{PERLLIB} || ""); | |
8520 | ||
8521 | $CPAN::META->set_perl5lib; | |
8522 | local $ENV{MAKEFLAGS}; # protect us from outer make calls | |
8523 | ||
e82b9348 | 8524 | $CPAN::Frontend->myprint("Running $make test\n"); |
f20de9f0 | 8525 | |
05454584 | 8526 | EXCUSE: { |
f04ea8d1 | 8527 | my @e; |
23a216b4 SP |
8528 | if ($self->{make} or $self->{later}) { |
8529 | # go ahead | |
8530 | } else { | |
4d1321a7 A |
8531 | push @e, |
8532 | "Make had some problems, won't test"; | |
8533 | } | |
05454584 | 8534 | |
f04ea8d1 SP |
8535 | exists $self->{make} and |
8536 | ( | |
be34b10d | 8537 | UNIVERSAL::can($self->{make},"failed") ? |
44d21104 A |
8538 | $self->{make}->failed : |
8539 | $self->{make} =~ /^NO/ | |
8540 | ) and push @e, "Can't test without successful make"; | |
6d29edf5 | 8541 | $self->{badtestcnt} ||= 0; |
f20de9f0 SP |
8542 | if ($self->{badtestcnt} > 0) { |
8543 | require Data::Dumper; | |
8544 | CPAN->debug(sprintf "NOREPEAT[%s]", Data::Dumper::Dumper($self)) if $CPAN::DEBUG; | |
6d29edf5 | 8545 | push @e, "Won't repeat unsuccessful test during this command"; |
f20de9f0 | 8546 | } |
6d29edf5 | 8547 | |
23a216b4 | 8548 | push @e, $self->{later} if $self->{later}; |
f04ea8d1 | 8549 | push @e, $self->{configure_requires_later} if $self->{configure_requires_later}; |
6d29edf5 | 8550 | |
6a935156 | 8551 | if (exists $self->{build_dir}) { |
23a216b4 SP |
8552 | if (exists $self->{make_test}) { |
8553 | if ( | |
8554 | UNIVERSAL::can($self->{make_test},"failed") ? | |
8555 | $self->{make_test}->failed : | |
8556 | $self->{make_test} =~ /^NO/ | |
8557 | ) { | |
8558 | if ( | |
8559 | UNIVERSAL::can($self->{make_test},"commandid") | |
8560 | && | |
8561 | $self->{make_test}->commandid == $CPAN::CurrentCommandId | |
8562 | ) { | |
8563 | push @e, "Has already been tested within this command"; | |
8564 | } | |
8565 | } else { | |
8566 | push @e, "Has already been tested successfully"; | |
8567 | } | |
6a935156 SP |
8568 | } |
8569 | } elsif (!@e) { | |
8570 | push @e, "Has no own directory"; | |
135a59c2 | 8571 | } |
f04ea8d1 | 8572 | $CPAN::Frontend->myprint(join "", map {" $_\n"} @e) and return if @e; |
b72dd56f SP |
8573 | unless (chdir $self->{build_dir}) { |
8574 | push @e, "Couldn't chdir to '$self->{build_dir}': $!"; | |
8575 | } | |
f04ea8d1 | 8576 | $CPAN::Frontend->mywarn(join "", map {" $_\n"} @e) and return if @e; |
05454584 | 8577 | } |
b72dd56f | 8578 | $self->debug("Changed directory to $self->{build_dir}") |
f04ea8d1 | 8579 | if $CPAN::DEBUG; |
f14b5cec JH |
8580 | |
8581 | if ($^O eq 'MacOS') { | |
be708cc0 | 8582 | Mac::BuildTools::make_test($self); |
f14b5cec JH |
8583 | return; |
8584 | } | |
8585 | ||
7d97ad34 SP |
8586 | if ($self->{modulebuild}) { |
8587 | my $v = CPAN::Shell->expand("Module","Test::Harness")->inst_version; | |
8588 | if (CPAN::Version->vlt($v,2.62)) { | |
8589 | $CPAN::Frontend->mywarn(qq{The version of your Test::Harness is only | |
8590 | '$v', you need at least '2.62'. Please upgrade your Test::Harness.\n}); | |
8591 | $self->{make_test} = CPAN::Distrostatus->new("NO Test::Harness too old"); | |
8592 | return; | |
8593 | } | |
8594 | } | |
8595 | ||
e82b9348 | 8596 | my $system; |
f04ea8d1 SP |
8597 | my $prefs_test = $self->prefs->{test}; |
8598 | if (my $commandline | |
8599 | = exists $prefs_test->{commandline} ? $prefs_test->{commandline} : "") { | |
810a0276 | 8600 | $system = $commandline; |
b03f445c | 8601 | $ENV{PERL} = CPAN::find_perl; |
810a0276 | 8602 | } elsif ($self->{modulebuild}) { |
44d21104 | 8603 | $system = sprintf "%s test", $self->_build_command(); |
e82b9348 | 8604 | } else { |
ed84aac9 | 8605 | $system = join " ", $self->_make_command(), "test"; |
e82b9348 | 8606 | } |
f20de9f0 SP |
8607 | my $make_test_arg = $self->make_x_arg("test"); |
8608 | $system = sprintf("%s%s", | |
8609 | $system, | |
8610 | $make_test_arg ? " $make_test_arg" : "", | |
8611 | ); | |
1e8f9a0a | 8612 | my($tests_ok); |
6658a91b SP |
8613 | my %env; |
8614 | while (my($k,$v) = each %ENV) { | |
8615 | next unless defined $v; | |
8616 | $env{$k} = $v; | |
8617 | } | |
8618 | local %ENV = %env; | |
1e8f9a0a SP |
8619 | if (my $env = $self->prefs->{test}{env}) { |
8620 | for my $e (keys %$env) { | |
8621 | $ENV{$e} = $env->{$e}; | |
8622 | } | |
8623 | } | |
05bab18e | 8624 | my $expect_model = $self->_prefs_with_expect("test"); |
6658a91b | 8625 | my $want_expect = 0; |
05bab18e SP |
8626 | if ( $expect_model && @{$expect_model->{talk}} ) { |
8627 | my $can_expect = $CPAN::META->has_inst("Expect"); | |
6658a91b SP |
8628 | if ($can_expect) { |
8629 | $want_expect = 1; | |
8630 | } else { | |
8631 | $CPAN::Frontend->mywarn("Expect not installed, falling back to ". | |
8632 | "testing without\n"); | |
8633 | } | |
8634 | } | |
6658a91b | 8635 | if ($want_expect) { |
f04ea8d1 | 8636 | if ($self->_should_report('test')) { |
6658a91b SP |
8637 | $CPAN::Frontend->mywarn("Reporting via CPAN::Reporter is currently ". |
8638 | "not supported when distroprefs specify ". | |
8639 | "an interactive test\n"); | |
8640 | } | |
05bab18e | 8641 | $tests_ok = $self->_run_via_expect($system,$expect_model) == 0; |
f04ea8d1 | 8642 | } elsif ( $self->_should_report('test') ) { |
6a935156 | 8643 | $tests_ok = CPAN::Reporter::test($self, $system); |
8962fc49 | 8644 | } else { |
6a935156 | 8645 | $tests_ok = system($system) == 0; |
8962fc49 | 8646 | } |
05bab18e | 8647 | $self->introduce_myself; |
8962fc49 | 8648 | if ( $tests_ok ) { |
6a935156 SP |
8649 | { |
8650 | my @prereq; | |
810a0276 | 8651 | |
b72dd56f | 8652 | # local $CPAN::DEBUG = 16; # Distribution |
6a935156 | 8653 | for my $m (keys %{$self->{sponsored_mods}}) { |
f04ea8d1 | 8654 | next unless $self->{sponsored_mods}{$m} > 0; |
f20de9f0 | 8655 | my $m_obj = CPAN::Shell->expand("Module",$m) or next; |
810a0276 SP |
8656 | # XXX we need available_version which reflects |
8657 | # $ENV{PERL5LIB} so that already tested but not yet | |
8658 | # installed modules are counted. | |
8659 | my $available_version = $m_obj->available_version; | |
b72dd56f | 8660 | my $available_file = $m_obj->available_file; |
810a0276 | 8661 | if ($available_version && |
b72dd56f | 8662 | !CPAN::Version->vlt($available_version,$self->{prereq_pm}{$m}) |
810a0276 SP |
8663 | ) { |
8664 | CPAN->debug("m[$m] good enough available_version[$available_version]") | |
8665 | if $CPAN::DEBUG; | |
b72dd56f SP |
8666 | } elsif ($available_file |
8667 | && ( | |
8668 | !$self->{prereq_pm}{$m} | |
8669 | || | |
8670 | $self->{prereq_pm}{$m} == 0 | |
8671 | ) | |
8672 | ) { | |
8673 | # lex Class::Accessor::Chained::Fast which has no $VERSION | |
8674 | CPAN->debug("m[$m] have available_file[$available_file]") | |
8675 | if $CPAN::DEBUG; | |
810a0276 SP |
8676 | } else { |
8677 | push @prereq, $m; | |
6a935156 SP |
8678 | } |
8679 | } | |
f04ea8d1 | 8680 | if (@prereq) { |
6a935156 SP |
8681 | my $cnt = @prereq; |
8682 | my $which = join ",", @prereq; | |
810a0276 | 8683 | my $but = $cnt == 1 ? "one dependency not OK ($which)" : |
6a935156 | 8684 | "$cnt dependencies missing ($which)"; |
810a0276 SP |
8685 | $CPAN::Frontend->mywarn("Tests succeeded but $but\n"); |
8686 | $self->{make_test} = CPAN::Distrostatus->new("NO $but"); | |
05bab18e | 8687 | $self->store_persistent_state; |
8ce4ea0b | 8688 | return $self->goodbye("[dependencies] -- NA"); |
6a935156 SP |
8689 | } |
8690 | } | |
8691 | ||
8692 | $CPAN::Frontend->myprint(" $system -- OK\n"); | |
6a935156 | 8693 | $self->{make_test} = CPAN::Distrostatus->new("YES"); |
b72dd56f SP |
8694 | $CPAN::META->is_tested($self->{build_dir},$self->{make_test}{TIME}); |
8695 | # probably impossible to need the next line because badtestcnt | |
8696 | # has a lifespan of one command | |
8697 | delete $self->{badtestcnt}; | |
05454584 | 8698 | } else { |
6a935156 SP |
8699 | $self->{make_test} = CPAN::Distrostatus->new("NO"); |
8700 | $self->{badtestcnt}++; | |
8701 | $CPAN::Frontend->mywarn(" $system -- NOT OK\n"); | |
b03f445c RGS |
8702 | CPAN::Shell->optprint |
8703 | ("hint", | |
8704 | sprintf | |
8705 | ("//hint// to see the cpan-testers results for installing this module, try: | |
8706 | reports %s\n", | |
8707 | $self->pretty_id)); | |
5f05dabc | 8708 | } |
05bab18e SP |
8709 | $self->store_persistent_state; |
8710 | } | |
8711 | ||
8712 | sub _prefs_with_expect { | |
8713 | my($self,$where) = @_; | |
8714 | return unless my $prefs = $self->prefs; | |
8715 | return unless my $where_prefs = $prefs->{$where}; | |
8716 | if ($where_prefs->{expect}) { | |
8717 | return { | |
810a0276 SP |
8718 | mode => "deterministic", |
8719 | timeout => 15, | |
05bab18e SP |
8720 | talk => $where_prefs->{expect}, |
8721 | }; | |
810a0276 SP |
8722 | } elsif ($where_prefs->{"eexpect"}) { |
8723 | return $where_prefs->{"eexpect"}; | |
05bab18e SP |
8724 | } |
8725 | return; | |
5f05dabc | 8726 | } |
8727 | ||
05454584 A |
8728 | #-> sub CPAN::Distribution::clean ; |
8729 | sub clean { | |
5f05dabc | 8730 | my($self) = @_; |
e82b9348 SP |
8731 | my $make = $self->{modulebuild} ? "Build" : "make"; |
8732 | $CPAN::Frontend->myprint("Running $make clean\n"); | |
4d1321a7 A |
8733 | unless (exists $self->{archived}) { |
8734 | $CPAN::Frontend->mywarn("Distribution seems to have never been unzipped". | |
8735 | "/untarred, nothing done\n"); | |
8736 | return 1; | |
8737 | } | |
e82b9348 SP |
8738 | unless (exists $self->{build_dir}) { |
8739 | $CPAN::Frontend->mywarn("Distribution has no own directory, nothing to do.\n"); | |
8740 | return 1; | |
8741 | } | |
ade94d80 SP |
8742 | if (exists $self->{writemakefile} |
8743 | and $self->{writemakefile}->failed | |
8744 | ) { | |
8745 | $CPAN::Frontend->mywarn("No Makefile, don't know how to 'make clean'\n"); | |
8746 | return 1; | |
8747 | } | |
05454584 | 8748 | EXCUSE: { |
f04ea8d1 | 8749 | my @e; |
c4d24d4c A |
8750 | exists $self->{make_clean} and $self->{make_clean} eq "YES" and |
8751 | push @e, "make clean already called once"; | |
f04ea8d1 | 8752 | $CPAN::Frontend->myprint(join "", map {" $_\n"} @e) and return if @e; |
05454584 | 8753 | } |
b72dd56f | 8754 | chdir $self->{build_dir} or |
f04ea8d1 | 8755 | Carp::confess("Couldn't chdir to $self->{build_dir}: $!"); |
b72dd56f | 8756 | $self->debug("Changed directory to $self->{build_dir}") if $CPAN::DEBUG; |
f14b5cec JH |
8757 | |
8758 | if ($^O eq 'MacOS') { | |
be708cc0 | 8759 | Mac::BuildTools::make_clean($self); |
f14b5cec JH |
8760 | return; |
8761 | } | |
8762 | ||
e82b9348 SP |
8763 | my $system; |
8764 | if ($self->{modulebuild}) { | |
8962fc49 | 8765 | unless (-f "Build") { |
810a0276 | 8766 | my $cwd = CPAN::anycwd(); |
8962fc49 SP |
8767 | $CPAN::Frontend->mywarn("Alert: no Build file available for 'clean $self->{id}". |
8768 | " in cwd[$cwd]. Danger, Will Robinson!"); | |
8769 | $CPAN::Frontend->mysleep(5); | |
8770 | } | |
44d21104 | 8771 | $system = sprintf "%s clean", $self->_build_command(); |
e82b9348 | 8772 | } else { |
ed84aac9 | 8773 | $system = join " ", $self->_make_command(), "clean"; |
e82b9348 | 8774 | } |
05bab18e SP |
8775 | my $system_ok = system($system) == 0; |
8776 | $self->introduce_myself; | |
8777 | if ( $system_ok ) { | |
c4d24d4c A |
8778 | $CPAN::Frontend->myprint(" $system -- OK\n"); |
8779 | ||
8780 | # $self->force; | |
8781 | ||
8782 | # Jost Krieger pointed out that this "force" was wrong because | |
8783 | # it has the effect that the next "install" on this distribution | |
8784 | # will untar everything again. Instead we should bring the | |
8785 | # object's state back to where it is after untarring. | |
8786 | ||
e82b9348 SP |
8787 | for my $k (qw( |
8788 | force_update | |
8789 | install | |
8790 | writemakefile | |
8791 | make | |
8792 | make_test | |
8793 | )) { | |
8794 | delete $self->{$k}; | |
8795 | } | |
87892b73 | 8796 | $self->{make_clean} = CPAN::Distrostatus->new("YES"); |
c4d24d4c | 8797 | |
05454584 | 8798 | } else { |
c4d24d4c A |
8799 | # Hmmm, what to do if make clean failed? |
8800 | ||
87892b73 | 8801 | $self->{make_clean} = CPAN::Distrostatus->new("NO"); |
8962fc49 | 8802 | $CPAN::Frontend->mywarn(qq{ $system -- NOT OK\n}); |
c4d24d4c | 8803 | |
87892b73 RGS |
8804 | # 2006-02-27: seems silly to me to force a make now |
8805 | # $self->force("make"); # so that this directory won't be used again | |
c4d24d4c | 8806 | |
5f05dabc | 8807 | } |
05bab18e | 8808 | $self->store_persistent_state; |
5f05dabc | 8809 | } |
8810 | ||
810a0276 | 8811 | #-> sub CPAN::Distribution::goto ; |
be34b10d SP |
8812 | sub goto { |
8813 | my($self,$goto) = @_; | |
810a0276 | 8814 | $goto = $self->normalize($goto); |
f04ea8d1 SP |
8815 | my $why = sprintf( |
8816 | "Goto '$goto' via prefs file '%s' doc %d", | |
8817 | $self->{prefs_file}, | |
8818 | $self->{prefs_file_doc}, | |
8819 | ); | |
8820 | $self->{unwrapped} = CPAN::Distrostatus->new("NO $why"); | |
8821 | # 2007-07-16 akoenig : Better than NA would be if we could inherit | |
8822 | # the status of the $goto distro but given the exceptional nature | |
8823 | # of 'goto' I feel reluctant to implement it | |
8824 | my $goodbye_message = "[goto] -- NA $why"; | |
8825 | $self->goodbye($goodbye_message); | |
810a0276 SP |
8826 | |
8827 | # inject into the queue | |
8828 | ||
8829 | CPAN::Queue->delete($self->id); | |
f04ea8d1 | 8830 | CPAN::Queue->jumpqueue({qmod => $goto, reqtype => $self->{reqtype}}); |
810a0276 SP |
8831 | |
8832 | # and run where we left off | |
8833 | ||
be34b10d | 8834 | my($method) = (caller(1))[3]; |
8ce4ea0b | 8835 | CPAN->instance("CPAN::Distribution",$goto)->$method(); |
b72dd56f | 8836 | CPAN::Queue->delete_first($goto); |
be34b10d SP |
8837 | } |
8838 | ||
8839 | #-> sub CPAN::Distribution::install ; | |
05454584 | 8840 | sub install { |
5f05dabc | 8841 | my($self) = @_; |
be34b10d SP |
8842 | if (my $goto = $self->prefs->{goto}) { |
8843 | return $self->goto($goto); | |
8844 | } | |
23a216b4 | 8845 | # $DB::single=1; |
f20de9f0 SP |
8846 | unless ($self->{badtestcnt}) { |
8847 | $self->test; | |
8848 | } | |
f04ea8d1 | 8849 | if ($CPAN::Signal) { |
c4d24d4c A |
8850 | delete $self->{force_update}; |
8851 | return; | |
8852 | } | |
e82b9348 SP |
8853 | my $make = $self->{modulebuild} ? "Build" : "make"; |
8854 | $CPAN::Frontend->myprint("Running $make install\n"); | |
05454584 | 8855 | EXCUSE: { |
f04ea8d1 SP |
8856 | my @e; |
8857 | if ($self->{make} or $self->{later}) { | |
23a216b4 SP |
8858 | # go ahead |
8859 | } else { | |
4d1321a7 A |
8860 | push @e, |
8861 | "Make had some problems, won't install"; | |
8862 | } | |
5f05dabc | 8863 | |
f04ea8d1 SP |
8864 | exists $self->{make} and |
8865 | ( | |
be34b10d | 8866 | UNIVERSAL::can($self->{make},"failed") ? |
44d21104 A |
8867 | $self->{make}->failed : |
8868 | $self->{make} =~ /^NO/ | |
8869 | ) and | |
f04ea8d1 | 8870 | push @e, "Make had returned bad status, install seems impossible"; |
6a935156 SP |
8871 | |
8872 | if (exists $self->{build_dir}) { | |
8873 | } elsif (!@e) { | |
8874 | push @e, "Has no own directory"; | |
8875 | } | |
05454584 | 8876 | |
9ddc4ed0 | 8877 | if (exists $self->{make_test} and |
f04ea8d1 | 8878 | ( |
be34b10d | 8879 | UNIVERSAL::can($self->{make_test},"failed") ? |
44d21104 A |
8880 | $self->{make_test}->failed : |
8881 | $self->{make_test} =~ /^NO/ | |
f04ea8d1 SP |
8882 | )) { |
8883 | if ($self->{force_update}) { | |
9ddc4ed0 A |
8884 | $self->{make_test}->text("FAILED but failure ignored because ". |
8885 | "'force' in effect"); | |
8886 | } else { | |
8887 | push @e, "make test had returned bad status, ". | |
8888 | "won't install without force" | |
8889 | } | |
8890 | } | |
f04ea8d1 | 8891 | if (exists $self->{install}) { |
be34b10d SP |
8892 | if (UNIVERSAL::can($self->{install},"text") ? |
8893 | $self->{install}->text eq "YES" : | |
8894 | $self->{install} =~ /^YES/ | |
4d1321a7 | 8895 | ) { |
23a216b4 SP |
8896 | $CPAN::Frontend->myprint(" Already done\n"); |
8897 | $CPAN::META->is_installed($self->{build_dir}); | |
8898 | return 1; | |
4d1321a7 A |
8899 | } else { |
8900 | # comment in Todo on 2006-02-11; maybe retry? | |
8901 | push @e, "Already tried without success"; | |
8902 | } | |
8903 | } | |
05454584 | 8904 | |
23a216b4 | 8905 | push @e, $self->{later} if $self->{later}; |
f04ea8d1 | 8906 | push @e, $self->{configure_requires_later} if $self->{configure_requires_later}; |
6d29edf5 | 8907 | |
f04ea8d1 | 8908 | $CPAN::Frontend->myprint(join "", map {" $_\n"} @e) and return if @e; |
b72dd56f SP |
8909 | unless (chdir $self->{build_dir}) { |
8910 | push @e, "Couldn't chdir to '$self->{build_dir}': $!"; | |
8911 | } | |
f04ea8d1 | 8912 | $CPAN::Frontend->mywarn(join "", map {" $_\n"} @e) and return if @e; |
05454584 | 8913 | } |
b72dd56f | 8914 | $self->debug("Changed directory to $self->{build_dir}") |
f04ea8d1 | 8915 | if $CPAN::DEBUG; |
f14b5cec JH |
8916 | |
8917 | if ($^O eq 'MacOS') { | |
be708cc0 | 8918 | Mac::BuildTools::make_install($self); |
f14b5cec JH |
8919 | return; |
8920 | } | |
8921 | ||
e82b9348 | 8922 | my $system; |
810a0276 SP |
8923 | if (my $commandline = $self->prefs->{install}{commandline}) { |
8924 | $system = $commandline; | |
b03f445c | 8925 | $ENV{PERL} = CPAN::find_perl; |
810a0276 | 8926 | } elsif ($self->{modulebuild}) { |
44d21104 A |
8927 | my($mbuild_install_build_command) = |
8928 | exists $CPAN::HandleConfig::keys{mbuild_install_build_command} && | |
8929 | $CPAN::Config->{mbuild_install_build_command} ? | |
8930 | $CPAN::Config->{mbuild_install_build_command} : | |
8931 | $self->_build_command(); | |
8932 | $system = sprintf("%s install %s", | |
8933 | $mbuild_install_build_command, | |
8934 | $CPAN::Config->{mbuild_install_arg}, | |
8935 | ); | |
e82b9348 | 8936 | } else { |
1e8f9a0a | 8937 | my($make_install_make_command) = |
6658a91b SP |
8938 | CPAN::HandleConfig->prefs_lookup($self, |
8939 | q{make_install_make_command}) | |
8940 | || $self->_make_command(); | |
44d21104 A |
8941 | $system = sprintf("%s install %s", |
8942 | $make_install_make_command, | |
8943 | $CPAN::Config->{make_install_arg}, | |
8944 | ); | |
e82b9348 SP |
8945 | } |
8946 | ||
87892b73 | 8947 | my($stderr) = $^O eq "MSWin32" ? "" : " 2>&1 "; |
6658a91b SP |
8948 | my $brip = CPAN::HandleConfig->prefs_lookup($self, |
8949 | q{build_requires_install_policy}); | |
1e8f9a0a | 8950 | $brip ||="ask/yes"; |
135a59c2 | 8951 | my $id = $self->id; |
6a935156 | 8952 | my $reqtype = $self->{reqtype} ||= "c"; # in doubt it was a command |
135a59c2 A |
8953 | my $want_install = "yes"; |
8954 | if ($reqtype eq "b") { | |
1e8f9a0a | 8955 | if ($brip eq "no") { |
135a59c2 | 8956 | $want_install = "no"; |
1e8f9a0a | 8957 | } elsif ($brip =~ m|^ask/(.+)|) { |
135a59c2 A |
8958 | my $default = $1; |
8959 | $default = "yes" unless $default =~ /^(y|n)/i; | |
8960 | $want_install = | |
8961 | CPAN::Shell::colorable_makemaker_prompt | |
8962 | ("$id is just needed temporarily during building or testing. ". | |
8963 | "Do you want to install it permanently? (Y/n)", | |
8964 | $default); | |
8965 | } | |
8966 | } | |
8967 | unless ($want_install =~ /^y/i) { | |
8968 | my $is_only = "is only 'build_requires'"; | |
8969 | $CPAN::Frontend->mywarn("Not installing because $is_only\n"); | |
8970 | $self->{install} = CPAN::Distrostatus->new("NO -- $is_only"); | |
8971 | delete $self->{force_update}; | |
8972 | return; | |
8973 | } | |
f04ea8d1 SP |
8974 | local $ENV{PERL5LIB} = defined($ENV{PERL5LIB}) |
8975 | ? $ENV{PERL5LIB} | |
8976 | : ($ENV{PERLLIB} || ""); | |
8977 | ||
8978 | $CPAN::META->set_perl5lib; | |
f610777f | 8979 | my($pipe) = FileHandle->new("$system $stderr |"); |
05454584 | 8980 | my($makeout) = ""; |
f04ea8d1 SP |
8981 | while (<$pipe>) { |
8982 | print $_; # intentionally NOT use Frontend->myprint because it | |
8962fc49 SP |
8983 | # looks irritating when we markup in color what we |
8984 | # just pass through from an external program | |
f04ea8d1 | 8985 | $makeout .= $_; |
05454584 A |
8986 | } |
8987 | $pipe->close; | |
05bab18e SP |
8988 | my $close_ok = $? == 0; |
8989 | $self->introduce_myself; | |
8990 | if ( $close_ok ) { | |
44d21104 A |
8991 | $CPAN::Frontend->myprint(" $system -- OK\n"); |
8992 | $CPAN::META->is_installed($self->{build_dir}); | |
b72dd56f | 8993 | $self->{install} = CPAN::Distrostatus->new("YES"); |
5f05dabc | 8994 | } else { |
44d21104 | 8995 | $self->{install} = CPAN::Distrostatus->new("NO"); |
8962fc49 | 8996 | $CPAN::Frontend->mywarn(" $system -- NOT OK\n"); |
1e8f9a0a | 8997 | my $mimc = |
6658a91b SP |
8998 | CPAN::HandleConfig->prefs_lookup($self, |
8999 | q{make_install_make_command}); | |
44d21104 A |
9000 | if ( |
9001 | $makeout =~ /permission/s | |
9002 | && $> > 0 | |
9003 | && ( | |
1e8f9a0a | 9004 | ! $mimc |
6658a91b SP |
9005 | || $mimc eq (CPAN::HandleConfig->prefs_lookup($self, |
9006 | q{make})) | |
44d21104 A |
9007 | ) |
9008 | ) { | |
9009 | $CPAN::Frontend->myprint( | |
9010 | qq{----\n}. | |
9011 | qq{ You may have to su }. | |
9012 | qq{to root to install the package\n}. | |
9013 | qq{ (Or you may want to run something like\n}. | |
9014 | qq{ o conf make_install_make_command 'sudo make'\n}. | |
9015 | qq{ to raise your permissions.} | |
9016 | ); | |
9017 | } | |
5f05dabc | 9018 | } |
c4d24d4c | 9019 | delete $self->{force_update}; |
b72dd56f | 9020 | # $DB::single = 1; |
05bab18e SP |
9021 | $self->store_persistent_state; |
9022 | } | |
9023 | ||
9024 | sub introduce_myself { | |
9025 | my($self) = @_; | |
9026 | $CPAN::Frontend->myprint(sprintf(" %s\n",$self->pretty_id)); | |
5f05dabc | 9027 | } |
9028 | ||
05454584 A |
9029 | #-> sub CPAN::Distribution::dir ; |
9030 | sub dir { | |
b72dd56f | 9031 | shift->{build_dir}; |
5f05dabc | 9032 | } |
9033 | ||
554a9ef5 SP |
9034 | #-> sub CPAN::Distribution::perldoc ; |
9035 | sub perldoc { | |
f3fe0ae6 | 9036 | my($self) = @_; |
554a9ef5 SP |
9037 | |
9038 | my($dist) = $self->id; | |
9039 | my $package = $self->called_for; | |
9040 | ||
9041 | $self->_display_url( $CPAN::Defaultdocs . $package ); | |
9042 | } | |
9043 | ||
9044 | #-> sub CPAN::Distribution::_check_binary ; | |
9045 | sub _check_binary { | |
f3fe0ae6 | 9046 | my ($dist,$shell,$binary) = @_; |
4d1321a7 | 9047 | my ($pid,$out); |
554a9ef5 SP |
9048 | |
9049 | $CPAN::Frontend->myprint(qq{ + _check_binary($binary)\n}) | |
9050 | if $CPAN::DEBUG; | |
9051 | ||
05bab18e SP |
9052 | if ($CPAN::META->has_inst("File::Which")) { |
9053 | return File::Which::which($binary); | |
9054 | } else { | |
9055 | local *README; | |
9056 | $pid = open README, "which $binary|" | |
9057 | or $CPAN::Frontend->mywarn(qq{Could not fork 'which $binary': $!\n}); | |
9058 | return unless $pid; | |
9059 | while (<README>) { | |
9060 | $out .= $_; | |
9061 | } | |
9062 | close README | |
9063 | or $CPAN::Frontend->mywarn("Could not run 'which $binary': $!\n") | |
9064 | and return; | |
554a9ef5 | 9065 | } |
554a9ef5 SP |
9066 | |
9067 | $CPAN::Frontend->myprint(qq{ + $out \n}) | |
9068 | if $CPAN::DEBUG && $out; | |
9069 | ||
9070 | return $out; | |
9071 | } | |
9072 | ||
9073 | #-> sub CPAN::Distribution::_display_url ; | |
9074 | sub _display_url { | |
f3fe0ae6 | 9075 | my($self,$url) = @_; |
4d1321a7 | 9076 | my($res,$saved_file,$pid,$out); |
554a9ef5 SP |
9077 | |
9078 | $CPAN::Frontend->myprint(qq{ + _display_url($url)\n}) | |
9079 | if $CPAN::DEBUG; | |
9080 | ||
9081 | # should we define it in the config instead? | |
f04ea8d1 | 9082 | my $html_converter = "html2text.pl"; |
554a9ef5 SP |
9083 | |
9084 | my $web_browser = $CPAN::Config->{'lynx'} || undef; | |
9085 | my $web_browser_out = $web_browser | |
f04ea8d1 SP |
9086 | ? CPAN::Distribution->_check_binary($self,$web_browser) |
9087 | : undef; | |
554a9ef5 | 9088 | |
4d1321a7 A |
9089 | if ($web_browser_out) { |
9090 | # web browser found, run the action | |
f04ea8d1 | 9091 | my $browser = CPAN::HandleConfig->safe_quote($CPAN::Config->{'lynx'}); |
4d1321a7 | 9092 | $CPAN::Frontend->myprint(qq{system[$browser $url]}) |
f04ea8d1 SP |
9093 | if $CPAN::DEBUG; |
9094 | $CPAN::Frontend->myprint(qq{ | |
4d1321a7 A |
9095 | Displaying URL |
9096 | $url | |
9097 | with browser $browser | |
9098 | }); | |
f04ea8d1 | 9099 | $CPAN::Frontend->mysleep(1); |
4d1321a7 | 9100 | system("$browser $url"); |
f04ea8d1 | 9101 | if ($saved_file) { 1 while unlink($saved_file) } |
4d1321a7 | 9102 | } else { |
554a9ef5 | 9103 | # web browser not found, let's try text only |
f04ea8d1 SP |
9104 | my $html_converter_out = |
9105 | CPAN::Distribution->_check_binary($self,$html_converter); | |
ed84aac9 | 9106 | $html_converter_out = CPAN::HandleConfig->safe_quote($html_converter_out); |
554a9ef5 SP |
9107 | |
9108 | if ($html_converter_out ) { | |
9109 | # html2text found, run it | |
9110 | $saved_file = CPAN::Distribution->_getsave_url( $self, $url ); | |
4d1321a7 A |
9111 | $CPAN::Frontend->mydie(qq{ERROR: problems while getting $url\n}) |
9112 | unless defined($saved_file); | |
554a9ef5 | 9113 | |
4d1321a7 | 9114 | local *README; |
f04ea8d1 SP |
9115 | $pid = open README, "$html_converter $saved_file |" |
9116 | or $CPAN::Frontend->mydie(qq{ | |
0a78cd5d | 9117 | Could not fork '$html_converter $saved_file': $!}); |
4d1321a7 | 9118 | my($fh,$filename); |
b03f445c | 9119 | if ($CPAN::META->has_usable("File::Temp")) { |
4d1321a7 | 9120 | $fh = File::Temp->new( |
917f1700 | 9121 | dir => File::Spec->tmpdir, |
4d1321a7 A |
9122 | template => 'cpan_htmlconvert_XXXX', |
9123 | suffix => '.txt', | |
9124 | unlink => 0, | |
9125 | ); | |
9126 | $filename = $fh->filename; | |
9127 | } else { | |
9128 | $filename = "cpan_htmlconvert_$$.txt"; | |
9129 | $fh = FileHandle->new(); | |
9130 | open $fh, ">$filename" or die; | |
9131 | } | |
9132 | while (<README>) { | |
554a9ef5 SP |
9133 | $fh->print($_); |
9134 | } | |
4d1321a7 A |
9135 | close README or |
9136 | $CPAN::Frontend->mydie(qq{Could not run '$html_converter $saved_file': $!}); | |
554a9ef5 | 9137 | my $tmpin = $fh->filename; |
4d1321a7 | 9138 | $CPAN::Frontend->myprint(sprintf(qq{ |
554a9ef5 SP |
9139 | Run '%s %s' and |
9140 | saved output to %s\n}, | |
9141 | $html_converter, | |
9142 | $saved_file, | |
9143 | $tmpin, | |
9144 | )) if $CPAN::DEBUG; | |
4d1321a7 A |
9145 | close $fh; |
9146 | local *FH; | |
9147 | open FH, $tmpin | |
9148 | or $CPAN::Frontend->mydie(qq{Could not open "$tmpin": $!}); | |
554a9ef5 SP |
9149 | my $fh_pager = FileHandle->new; |
9150 | local($SIG{PIPE}) = "IGNORE"; | |
ed84aac9 | 9151 | my $pager = $CPAN::Config->{'pager'} || "cat"; |
135a59c2 | 9152 | $fh_pager->open("|$pager") |
4d1321a7 | 9153 | or $CPAN::Frontend->mydie(qq{ |
135a59c2 | 9154 | Could not open pager '$pager': $!}); |
4d1321a7 | 9155 | $CPAN::Frontend->myprint(qq{ |
554a9ef5 SP |
9156 | Displaying URL |
9157 | $url | |
ed84aac9 | 9158 | with pager "$pager" |
554a9ef5 | 9159 | }); |
8962fc49 | 9160 | $CPAN::Frontend->mysleep(1); |
4d1321a7 A |
9161 | $fh_pager->print(<FH>); |
9162 | $fh_pager->close; | |
554a9ef5 SP |
9163 | } else { |
9164 | # coldn't find the web browser or html converter | |
9165 | $CPAN::Frontend->myprint(qq{ | |
9166 | You need to install lynx or $html_converter to use this feature.}); | |
9167 | } | |
554a9ef5 SP |
9168 | } |
9169 | } | |
9170 | ||
9171 | #-> sub CPAN::Distribution::_getsave_url ; | |
9172 | sub _getsave_url { | |
f3fe0ae6 | 9173 | my($dist, $shell, $url) = @_; |
554a9ef5 SP |
9174 | |
9175 | $CPAN::Frontend->myprint(qq{ + _getsave_url($url)\n}) | |
9176 | if $CPAN::DEBUG; | |
9177 | ||
4d1321a7 | 9178 | my($fh,$filename); |
b03f445c | 9179 | if ($CPAN::META->has_usable("File::Temp")) { |
4d1321a7 | 9180 | $fh = File::Temp->new( |
917f1700 | 9181 | dir => File::Spec->tmpdir, |
554a9ef5 SP |
9182 | template => "cpan_getsave_url_XXXX", |
9183 | suffix => ".html", | |
9184 | unlink => 0, | |
9185 | ); | |
4d1321a7 A |
9186 | $filename = $fh->filename; |
9187 | } else { | |
9188 | $fh = FileHandle->new; | |
9189 | $filename = "cpan_getsave_url_$$.html"; | |
9190 | } | |
9191 | my $tmpin = $filename; | |
554a9ef5 SP |
9192 | if ($CPAN::META->has_usable('LWP')) { |
9193 | $CPAN::Frontend->myprint("Fetching with LWP: | |
9194 | $url | |
9195 | "); | |
9196 | my $Ua; | |
9197 | CPAN::LWP::UserAgent->config; | |
4d1321a7 A |
9198 | eval { $Ua = CPAN::LWP::UserAgent->new; }; |
9199 | if ($@) { | |
9200 | $CPAN::Frontend->mywarn("ERROR: CPAN::LWP::UserAgent->new dies with $@\n"); | |
9201 | return; | |
9202 | } else { | |
9203 | my($var); | |
9204 | $Ua->proxy('http', $var) | |
554a9ef5 | 9205 | if $var = $CPAN::Config->{http_proxy} || $ENV{http_proxy}; |
4d1321a7 | 9206 | $Ua->no_proxy($var) |
554a9ef5 | 9207 | if $var = $CPAN::Config->{no_proxy} || $ENV{no_proxy}; |
4d1321a7 | 9208 | } |
554a9ef5 SP |
9209 | |
9210 | my $req = HTTP::Request->new(GET => $url); | |
9211 | $req->header('Accept' => 'text/html'); | |
9212 | my $res = $Ua->request($req); | |
9213 | if ($res->is_success) { | |
9214 | $CPAN::Frontend->myprint(" + request successful.\n") | |
9215 | if $CPAN::DEBUG; | |
9216 | print $fh $res->content; | |
9217 | close $fh; | |
9218 | $CPAN::Frontend->myprint(qq{ + saved content to $tmpin \n}) | |
9219 | if $CPAN::DEBUG; | |
9220 | return $tmpin; | |
9221 | } else { | |
9222 | $CPAN::Frontend->myprint(sprintf( | |
9223 | "LWP failed with code[%s], message[%s]\n", | |
9224 | $res->code, | |
9225 | $res->message, | |
9226 | )); | |
9227 | return; | |
9228 | } | |
9229 | } else { | |
8962fc49 | 9230 | $CPAN::Frontend->mywarn(" LWP not available\n"); |
554a9ef5 SP |
9231 | return; |
9232 | } | |
9233 | } | |
9234 | ||
f04ea8d1 | 9235 | #-> sub CPAN::Distribution::_build_command |
44d21104 A |
9236 | sub _build_command { |
9237 | my($self) = @_; | |
9238 | if ($^O eq "MSWin32") { # special code needed at least up to | |
9239 | # Module::Build 0.2611 and 0.2706; a fix | |
9240 | # in M:B has been promised 2006-01-30 | |
9241 | my($perl) = $self->perl or $CPAN::Frontend->mydie("Couldn't find executable perl\n"); | |
9242 | return "$perl ./Build"; | |
9243 | } | |
9244 | return "./Build"; | |
9245 | } | |
9246 | ||
f04ea8d1 SP |
9247 | #-> sub CPAN::Distribution::_should_report |
9248 | sub _should_report { | |
9249 | my($self, $phase) = @_; | |
9250 | die "_should_report() requires a 'phase' argument" | |
9251 | if ! defined $phase; | |
9252 | ||
9253 | # configured | |
9254 | my $test_report = CPAN::HandleConfig->prefs_lookup($self, | |
9255 | q{test_report}); | |
9256 | return unless $test_report; | |
9257 | ||
9258 | # don't repeat if we cached a result | |
9259 | return $self->{should_report} | |
9260 | if exists $self->{should_report}; | |
9261 | ||
9262 | # available | |
9263 | if ( ! $CPAN::META->has_inst("CPAN::Reporter")) { | |
9264 | $CPAN::Frontend->mywarn( | |
9265 | "CPAN::Reporter not installed. No reports will be sent.\n" | |
9266 | ); | |
9267 | return $self->{should_report} = 0; | |
9268 | } | |
9269 | ||
9270 | # capable | |
9271 | my $crv = CPAN::Reporter->VERSION; | |
9272 | if ( CPAN::Version->vlt( $crv, 0.99 ) ) { | |
9273 | # don't cache $self->{should_report} -- need to check each phase | |
9274 | if ( $phase eq 'test' ) { | |
9275 | return 1; | |
9276 | } | |
9277 | else { | |
9278 | $CPAN::Frontend->mywarn( | |
9279 | "Reporting on the '$phase' phase requires CPAN::Reporter 0.99, but \n" . | |
9280 | "you only have version $crv\. Only 'test' phase reports will be sent.\n" | |
9281 | ); | |
9282 | return; | |
9283 | } | |
9284 | } | |
9285 | ||
9286 | # appropriate | |
9287 | if ($self->is_dot_dist) { | |
9288 | $CPAN::Frontend->mywarn("Reporting via CPAN::Reporter is disabled ". | |
9289 | "for local directories\n"); | |
9290 | return $self->{should_report} = 0; | |
9291 | } | |
9292 | if ($self->prefs->{patches} | |
9293 | && | |
9294 | @{$self->prefs->{patches}} | |
9295 | && | |
9296 | $self->{patched} | |
9297 | ) { | |
9298 | $CPAN::Frontend->mywarn("Reporting via CPAN::Reporter is disabled ". | |
9299 | "when the source has been patched\n"); | |
9300 | return $self->{should_report} = 0; | |
9301 | } | |
9302 | ||
9303 | # proceed and cache success | |
9304 | return $self->{should_report} = 1; | |
9305 | } | |
9306 | ||
dc053c64 SP |
9307 | #-> sub CPAN::Distribution::reports |
9308 | sub reports { | |
9309 | my($self) = @_; | |
9310 | my $pathname = $self->id; | |
9311 | $CPAN::Frontend->myprint("Distribution: $pathname\n"); | |
9312 | ||
9313 | unless ($CPAN::META->has_inst("CPAN::DistnameInfo")) { | |
9314 | $CPAN::Frontend->mydie("CPAN::DistnameInfo not installed; cannot continue"); | |
9315 | } | |
9316 | unless ($CPAN::META->has_usable("LWP")) { | |
9317 | $CPAN::Frontend->mydie("LWP not installed; cannot continue"); | |
9318 | } | |
b03f445c | 9319 | unless ($CPAN::META->has_usable("File::Temp")) { |
dc053c64 SP |
9320 | $CPAN::Frontend->mydie("File::Temp not installed; cannot continue"); |
9321 | } | |
9322 | ||
9323 | my $d = CPAN::DistnameInfo->new($pathname); | |
9324 | ||
9325 | my $dist = $d->dist; # "CPAN-DistnameInfo" | |
9326 | my $version = $d->version; # "0.02" | |
9327 | my $maturity = $d->maturity; # "released" | |
9328 | my $filename = $d->filename; # "CPAN-DistnameInfo-0.02.tar.gz" | |
9329 | my $cpanid = $d->cpanid; # "GBARR" | |
9330 | my $distvname = $d->distvname; # "CPAN-DistnameInfo-0.02" | |
9331 | ||
9332 | my $url = sprintf "http://cpantesters.perl.org/show/%s.yaml", $dist; | |
9333 | ||
9334 | CPAN::LWP::UserAgent->config; | |
9335 | my $Ua; | |
9336 | eval { $Ua = CPAN::LWP::UserAgent->new; }; | |
9337 | if ($@) { | |
9338 | $CPAN::Frontend->mydie("CPAN::LWP::UserAgent->new dies with $@\n"); | |
9339 | } | |
9340 | $CPAN::Frontend->myprint("Fetching '$url'..."); | |
9341 | my $resp = $Ua->get($url); | |
9342 | unless ($resp->is_success) { | |
9343 | $CPAN::Frontend->mydie(sprintf "Could not download '%s': %s\n", $url, $resp->code); | |
9344 | } | |
9345 | $CPAN::Frontend->myprint("DONE\n\n"); | |
9346 | my $yaml = $resp->content; | |
9347 | # was fuer ein Umweg! | |
9348 | my $fh = File::Temp->new( | |
917f1700 | 9349 | dir => File::Spec->tmpdir, |
dc053c64 SP |
9350 | template => 'cpan_reports_XXXX', |
9351 | suffix => '.yaml', | |
9352 | unlink => 0, | |
9353 | ); | |
9354 | my $tfilename = $fh->filename; | |
9355 | print $fh $yaml; | |
9356 | close $fh or $CPAN::Frontend->mydie("Could not close '$tfilename': $!"); | |
9357 | my $unserialized = CPAN->_yaml_loadfile($tfilename)->[0]; | |
9358 | unlink $tfilename or $CPAN::Frontend->mydie("Could not unlink '$tfilename': $!"); | |
9359 | my %other_versions; | |
9360 | my $this_version_seen; | |
9361 | for my $rep (@$unserialized) { | |
9362 | my $rversion = $rep->{version}; | |
f04ea8d1 | 9363 | if ($rversion eq $version) { |
dc053c64 SP |
9364 | unless ($this_version_seen++) { |
9365 | $CPAN::Frontend->myprint ("$rep->{version}:\n"); | |
9366 | } | |
9367 | $CPAN::Frontend->myprint | |
9368 | (sprintf("%1s%1s%-4s %s on %s %s (%s)\n", | |
9369 | $rep->{archname} eq $Config::Config{archname}?"*":"", | |
9370 | $rep->{action}eq"PASS"?"+":$rep->{action}eq"FAIL"?"-":"", | |
9371 | $rep->{action}, | |
9372 | $rep->{perl}, | |
9373 | ucfirst $rep->{osname}, | |
9374 | $rep->{osvers}, | |
9375 | $rep->{archname}, | |
9376 | )); | |
9377 | } else { | |
9378 | $other_versions{$rep->{version}}++; | |
9379 | } | |
9380 | } | |
9381 | unless ($this_version_seen) { | |
9382 | $CPAN::Frontend->myprint("No reports found for version '$version' | |
9383 | Reports for other versions:\n"); | |
9384 | for my $v (sort keys %other_versions) { | |
9385 | $CPAN::Frontend->myprint(" $v\: $other_versions{$v}\n"); | |
9386 | } | |
9387 | } | |
9388 | $url =~ s/\.yaml/.html/; | |
9389 | $CPAN::Frontend->myprint("See $url for details\n"); | |
9390 | } | |
9391 | ||
05454584 | 9392 | package CPAN::Bundle; |
e82b9348 | 9393 | use strict; |
5f05dabc | 9394 | |
e662ec5f A |
9395 | sub look { |
9396 | my $self = shift; | |
35576f8c | 9397 | $CPAN::Frontend->myprint($self->as_string); |
e662ec5f A |
9398 | } |
9399 | ||
23a216b4 | 9400 | #-> CPAN::Bundle::undelay |
6d29edf5 JH |
9401 | sub undelay { |
9402 | my $self = shift; | |
9403 | delete $self->{later}; | |
9404 | for my $c ( $self->contains ) { | |
9405 | my $obj = CPAN::Shell->expandany($c) or next; | |
9406 | $obj->undelay; | |
9407 | } | |
9408 | } | |
9409 | ||
e82b9348 | 9410 | # mark as dirty/clean |
6d29edf5 JH |
9411 | #-> sub CPAN::Bundle::color_cmd_tmps ; |
9412 | sub color_cmd_tmps { | |
9413 | my($self) = shift; | |
9414 | my($depth) = shift || 0; | |
9415 | my($color) = shift || 0; | |
35576f8c | 9416 | my($ancestors) = shift || []; |
6d29edf5 JH |
9417 | # a module needs to recurse to its cpan_file, a distribution needs |
9418 | # to recurse into its prereq_pms, a bundle needs to recurse into its modules | |
9419 | ||
9420 | return if exists $self->{incommandcolor} | |
f20de9f0 | 9421 | && $color==1 |
6d29edf5 | 9422 | && $self->{incommandcolor}==$color; |
f04ea8d1 | 9423 | if ($depth>=$CPAN::MAX_RECURSION) { |
ade94d80 | 9424 | die(CPAN::Exception::RecursiveDependency->new($ancestors)); |
35576f8c A |
9425 | } |
9426 | # warn "color_cmd_tmps $depth $color " . $self->id; # sleep 1; | |
6d29edf5 JH |
9427 | |
9428 | for my $c ( $self->contains ) { | |
9429 | my $obj = CPAN::Shell->expandany($c) or next; | |
9430 | CPAN->debug("c[$c]obj[$obj]") if $CPAN::DEBUG; | |
35576f8c | 9431 | $obj->color_cmd_tmps($depth+1,$color,[@$ancestors, $self->id]); |
6d29edf5 | 9432 | } |
b72dd56f SP |
9433 | # never reached code? |
9434 | #if ($color==0) { | |
9435 | #delete $self->{badtestcnt}; | |
9436 | #} | |
6d29edf5 JH |
9437 | $self->{incommandcolor} = $color; |
9438 | } | |
9439 | ||
05454584 A |
9440 | #-> sub CPAN::Bundle::as_string ; |
9441 | sub as_string { | |
9442 | my($self) = @_; | |
9443 | $self->contains; | |
5e05dca5 | 9444 | # following line must be "=", not "||=" because we have a moving target |
6d29edf5 | 9445 | $self->{INST_VERSION} = $self->inst_version; |
05454584 A |
9446 | return $self->SUPER::as_string; |
9447 | } | |
9448 | ||
9449 | #-> sub CPAN::Bundle::contains ; | |
9450 | sub contains { | |
c049f953 JH |
9451 | my($self) = @_; |
9452 | my($inst_file) = $self->inst_file || ""; | |
9453 | my($id) = $self->id; | |
9454 | $self->debug("inst_file[$inst_file]id[$id]") if $CPAN::DEBUG; | |
b96578bb SP |
9455 | if ($inst_file && CPAN::Version->vlt($self->inst_version,$self->cpan_version)) { |
9456 | undef $inst_file; | |
9457 | } | |
c049f953 JH |
9458 | unless ($inst_file) { |
9459 | # Try to get at it in the cpan directory | |
9460 | $self->debug("no inst_file") if $CPAN::DEBUG; | |
9461 | my $cpan_file; | |
9462 | $CPAN::Frontend->mydie("I don't know a bundle with ID $id\n") unless | |
9463 | $cpan_file = $self->cpan_file; | |
9464 | if ($cpan_file eq "N/A") { | |
9465 | $CPAN::Frontend->mydie("Bundle $id not found on disk and not on CPAN. | |
9466 | Maybe stale symlink? Maybe removed during session? Giving up.\n"); | |
9467 | } | |
9468 | my $dist = $CPAN::META->instance('CPAN::Distribution', | |
9469 | $self->cpan_file); | |
b72dd56f | 9470 | $self->debug("before get id[$dist->{ID}]") if $CPAN::DEBUG; |
c049f953 | 9471 | $dist->get; |
b72dd56f | 9472 | $self->debug("after get id[$dist->{ID}]") if $CPAN::DEBUG; |
c049f953 JH |
9473 | my($todir) = $CPAN::Config->{'cpan_home'}; |
9474 | my(@me,$from,$to,$me); | |
9475 | @me = split /::/, $self->id; | |
9476 | $me[-1] .= ".pm"; | |
5de3f0da | 9477 | $me = File::Spec->catfile(@me); |
b72dd56f | 9478 | $from = $self->find_bundle_file($dist->{build_dir},join('/',@me)); |
5de3f0da | 9479 | $to = File::Spec->catfile($todir,$me); |
c049f953 JH |
9480 | File::Path::mkpath(File::Basename::dirname($to)); |
9481 | File::Copy::copy($from, $to) | |
9482 | or Carp::confess("Couldn't copy $from to $to: $!"); | |
9483 | $inst_file = $to; | |
9484 | } | |
9485 | my @result; | |
9486 | my $fh = FileHandle->new; | |
9487 | local $/ = "\n"; | |
9488 | open($fh,$inst_file) or die "Could not open '$inst_file': $!"; | |
9489 | my $in_cont = 0; | |
9490 | $self->debug("inst_file[$inst_file]") if $CPAN::DEBUG; | |
9491 | while (<$fh>) { | |
9492 | $in_cont = m/^=(?!head1\s+CONTENTS)/ ? 0 : | |
9493 | m/^=head1\s+CONTENTS/ ? 1 : $in_cont; | |
9494 | next unless $in_cont; | |
9495 | next if /^=/; | |
9496 | s/\#.*//; | |
9497 | next if /^\s+$/; | |
9498 | chomp; | |
9499 | push @result, (split " ", $_, 2)[0]; | |
9500 | } | |
9501 | close $fh; | |
9502 | delete $self->{STATUS}; | |
9503 | $self->{CONTAINS} = \@result; | |
9504 | $self->debug("CONTAINS[@result]") if $CPAN::DEBUG; | |
9505 | unless (@result) { | |
9506 | $CPAN::Frontend->mywarn(qq{ | |
9507 | The bundle file "$inst_file" may be a broken | |
2e2b7522 GS |
9508 | bundlefile. It seems not to contain any bundle definition. |
9509 | Please check the file and if it is bogus, please delete it. | |
9510 | Sorry for the inconvenience. | |
9511 | }); | |
c049f953 JH |
9512 | } |
9513 | @result; | |
5f05dabc | 9514 | } |
9515 | ||
e50380aa | 9516 | #-> sub CPAN::Bundle::find_bundle_file |
b96578bb | 9517 | # $where is in local format, $what is in unix format |
e50380aa A |
9518 | sub find_bundle_file { |
9519 | my($self,$where,$what) = @_; | |
c356248b | 9520 | $self->debug("where[$where]what[$what]") if $CPAN::DEBUG; |
2e2b7522 | 9521 | ### The following two lines let CPAN.pm become Bundle/CPAN.pm :-( |
5de3f0da | 9522 | ### my $bu = File::Spec->catfile($where,$what); |
2e2b7522 | 9523 | ### return $bu if -f $bu; |
5de3f0da | 9524 | my $manifest = File::Spec->catfile($where,"MANIFEST"); |
e50380aa | 9525 | unless (-f $manifest) { |
f04ea8d1 SP |
9526 | require ExtUtils::Manifest; |
9527 | my $cwd = CPAN::anycwd(); | |
9528 | $self->safe_chdir($where); | |
9529 | ExtUtils::Manifest::mkmanifest(); | |
9530 | $self->safe_chdir($cwd); | |
e50380aa | 9531 | } |
c356248b | 9532 | my $fh = FileHandle->new($manifest) |
f04ea8d1 | 9533 | or Carp::croak("Couldn't open $manifest: $!"); |
e50380aa | 9534 | local($/) = "\n"; |
b96578bb SP |
9535 | my $bundle_filename = $what; |
9536 | $bundle_filename =~ s|Bundle.*/||; | |
9537 | my $bundle_unixpath; | |
e50380aa | 9538 | while (<$fh>) { |
f04ea8d1 SP |
9539 | next if /^\s*\#/; |
9540 | my($file) = /(\S+)/; | |
9541 | if ($file =~ m|\Q$what\E$|) { | |
9542 | $bundle_unixpath = $file; | |
9543 | # return File::Spec->catfile($where,$bundle_unixpath); # bad | |
9544 | last; | |
9545 | } | |
9546 | # retry if she managed to have no Bundle directory | |
9547 | $bundle_unixpath = $file if $file =~ m|\Q$bundle_filename\E$|; | |
e50380aa | 9548 | } |
b96578bb SP |
9549 | return File::Spec->catfile($where, split /\//, $bundle_unixpath) |
9550 | if $bundle_unixpath; | |
c356248b | 9551 | Carp::croak("Couldn't find a Bundle file in $where"); |
e50380aa A |
9552 | } |
9553 | ||
d8773709 JH |
9554 | # needs to work quite differently from Module::inst_file because of |
9555 | # cpan_home/Bundle/ directory and the possibility that we have | |
9556 | # shadowing effect. As it makes no sense to take the first in @INC for | |
9557 | # Bundles, we parse them all for $VERSION and take the newest. | |
6d29edf5 | 9558 | |
05454584 A |
9559 | #-> sub CPAN::Bundle::inst_file ; |
9560 | sub inst_file { | |
9561 | my($self) = @_; | |
6d29edf5 JH |
9562 | my($inst_file); |
9563 | my(@me); | |
9564 | @me = split /::/, $self->id; | |
9565 | $me[-1] .= ".pm"; | |
d8773709 JH |
9566 | my($incdir,$bestv); |
9567 | foreach $incdir ($CPAN::Config->{'cpan_home'},@INC) { | |
5de3f0da | 9568 | my $bfile = File::Spec->catfile($incdir, @me); |
d8773709 JH |
9569 | CPAN->debug("bfile[$bfile]") if $CPAN::DEBUG; |
9570 | next unless -f $bfile; | |
9571 | my $foundv = MM->parse_version($bfile); | |
9572 | if (!$bestv || CPAN::Version->vgt($foundv,$bestv)) { | |
9573 | $self->{INST_FILE} = $bfile; | |
9574 | $self->{INST_VERSION} = $bestv = $foundv; | |
9575 | } | |
9576 | } | |
9577 | $self->{INST_FILE}; | |
9578 | } | |
9579 | ||
9580 | #-> sub CPAN::Bundle::inst_version ; | |
9581 | sub inst_version { | |
9582 | my($self) = @_; | |
9583 | $self->inst_file; # finds INST_VERSION as side effect | |
9584 | $self->{INST_VERSION}; | |
5f05dabc | 9585 | } |
9586 | ||
05454584 A |
9587 | #-> sub CPAN::Bundle::rematein ; |
9588 | sub rematein { | |
9589 | my($self,$meth) = @_; | |
9590 | $self->debug("self[$self] meth[$meth]") if $CPAN::DEBUG; | |
c356248b A |
9591 | my($id) = $self->id; |
9592 | Carp::croak "Can't $meth $id, don't have an associated bundle file. :-(\n" | |
f04ea8d1 | 9593 | unless $self->inst_file || $self->cpan_file; |
f610777f | 9594 | my($s,%fail); |
05454584 | 9595 | for $s ($self->contains) { |
f04ea8d1 SP |
9596 | my($type) = $s =~ m|/| ? 'CPAN::Distribution' : |
9597 | $s =~ m|^Bundle::| ? 'CPAN::Bundle' : 'CPAN::Module'; | |
9598 | if ($type eq 'CPAN::Distribution') { | |
9599 | $CPAN::Frontend->mywarn(qq{ | |
05454584 | 9600 | The Bundle }.$self->id.qq{ contains |
6658a91b SP |
9601 | explicitly a file '$s'. |
9602 | Going to $meth that. | |
c356248b | 9603 | }); |
f04ea8d1 SP |
9604 | $CPAN::Frontend->mysleep(5); |
9605 | } | |
9606 | # possibly noisy action: | |
de34a54b | 9607 | $self->debug("type[$type] s[$s]") if $CPAN::DEBUG; |
f04ea8d1 | 9608 | my $obj = $CPAN::META->instance($type,$s); |
135a59c2 | 9609 | $obj->{reqtype} = $self->{reqtype}; |
f04ea8d1 | 9610 | $obj->$meth(); |
5f05dabc | 9611 | } |
5f05dabc | 9612 | } |
9613 | ||
87892b73 RGS |
9614 | # If a bundle contains another that contains an xs_file we have here, |
9615 | # we just don't bother I suppose | |
9616 | #-> sub CPAN::Bundle::xs_file | |
e50380aa | 9617 | sub xs_file { |
e50380aa A |
9618 | return 0; |
9619 | } | |
9620 | ||
05454584 | 9621 | #-> sub CPAN::Bundle::force ; |
b72dd56f SP |
9622 | sub fforce { shift->rematein('fforce',@_); } |
9623 | #-> sub CPAN::Bundle::force ; | |
05454584 | 9624 | sub force { shift->rematein('force',@_); } |
554a9ef5 SP |
9625 | #-> sub CPAN::Bundle::notest ; |
9626 | sub notest { shift->rematein('notest',@_); } | |
05454584 A |
9627 | #-> sub CPAN::Bundle::get ; |
9628 | sub get { shift->rematein('get',@_); } | |
9629 | #-> sub CPAN::Bundle::make ; | |
9630 | sub make { shift->rematein('make',@_); } | |
9631 | #-> sub CPAN::Bundle::test ; | |
6d29edf5 JH |
9632 | sub test { |
9633 | my $self = shift; | |
b72dd56f | 9634 | # $self->{badtestcnt} ||= 0; |
6d29edf5 JH |
9635 | $self->rematein('test',@_); |
9636 | } | |
05454584 | 9637 | #-> sub CPAN::Bundle::install ; |
09d9d230 A |
9638 | sub install { |
9639 | my $self = shift; | |
9640 | $self->rematein('install',@_); | |
09d9d230 | 9641 | } |
05454584 A |
9642 | #-> sub CPAN::Bundle::clean ; |
9643 | sub clean { shift->rematein('clean',@_); } | |
5f05dabc | 9644 | |
d8773709 JH |
9645 | #-> sub CPAN::Bundle::uptodate ; |
9646 | sub uptodate { | |
9647 | my($self) = @_; | |
9648 | return 0 unless $self->SUPER::uptodate; # we mut have the current Bundle def | |
9649 | my $c; | |
9650 | foreach $c ($self->contains) { | |
9651 | my $obj = CPAN::Shell->expandany($c); | |
9652 | return 0 unless $obj->uptodate; | |
9653 | } | |
9654 | return 1; | |
9655 | } | |
9656 | ||
05454584 A |
9657 | #-> sub CPAN::Bundle::readme ; |
9658 | sub readme { | |
9659 | my($self) = @_; | |
c356248b A |
9660 | my($file) = $self->cpan_file or $CPAN::Frontend->myprint(qq{ |
9661 | No File found for bundle } . $self->id . qq{\n}), return; | |
05454584 A |
9662 | $self->debug("self[$self] file[$file]") if $CPAN::DEBUG; |
9663 | $CPAN::META->instance('CPAN::Distribution',$file)->readme; | |
5f05dabc | 9664 | } |
9665 | ||
05454584 | 9666 | package CPAN::Module; |
e82b9348 | 9667 | use strict; |
5f05dabc | 9668 | |
6d29edf5 | 9669 | # Accessors |
dc053c64 | 9670 | #-> sub CPAN::Module::userid |
6d29edf5 JH |
9671 | sub userid { |
9672 | my $self = shift; | |
0cf35e6a SP |
9673 | my $ro = $self->ro; |
9674 | return unless $ro; | |
9675 | return $ro->{userid} || $ro->{CPAN_USERID}; | |
6d29edf5 | 9676 | } |
dc053c64 | 9677 | #-> sub CPAN::Module::description |
9ddc4ed0 A |
9678 | sub description { |
9679 | my $self = shift; | |
9680 | my $ro = $self->ro or return ""; | |
9681 | $ro->{description} | |
9682 | } | |
6d29edf5 | 9683 | |
dc053c64 | 9684 | #-> sub CPAN::Module::distribution |
c9869e1c SP |
9685 | sub distribution { |
9686 | my($self) = @_; | |
9687 | CPAN::Shell->expand("Distribution",$self->cpan_file); | |
9688 | } | |
9689 | ||
dc053c64 | 9690 | #-> sub CPAN::Module::undelay |
6d29edf5 JH |
9691 | sub undelay { |
9692 | my $self = shift; | |
9693 | delete $self->{later}; | |
9694 | if ( my $dist = CPAN::Shell->expand("Distribution", $self->cpan_file) ) { | |
9695 | $dist->undelay; | |
9696 | } | |
9697 | } | |
9698 | ||
e82b9348 | 9699 | # mark as dirty/clean |
6d29edf5 JH |
9700 | #-> sub CPAN::Module::color_cmd_tmps ; |
9701 | sub color_cmd_tmps { | |
9702 | my($self) = shift; | |
9703 | my($depth) = shift || 0; | |
9704 | my($color) = shift || 0; | |
35576f8c | 9705 | my($ancestors) = shift || []; |
6d29edf5 JH |
9706 | # a module needs to recurse to its cpan_file |
9707 | ||
9708 | return if exists $self->{incommandcolor} | |
f20de9f0 | 9709 | && $color==1 |
6d29edf5 | 9710 | && $self->{incommandcolor}==$color; |
f20de9f0 SP |
9711 | return if $color==0 && !$self->{incommandcolor}; |
9712 | if ($color>=1) { | |
9713 | if ( $self->uptodate ) { | |
9714 | $self->{incommandcolor} = $color; | |
9715 | return; | |
9716 | } elsif (my $have_version = $self->available_version) { | |
9717 | # maybe what we have is good enough | |
9718 | if (@$ancestors) { | |
9719 | my $who_asked_for_me = $ancestors->[-1]; | |
9720 | my $obj = CPAN::Shell->expandany($who_asked_for_me); | |
9721 | if (0) { | |
9722 | } elsif ($obj->isa("CPAN::Bundle")) { | |
9723 | # bundles cannot specify a minimum version | |
9724 | return; | |
9725 | } elsif ($obj->isa("CPAN::Distribution")) { | |
9726 | if (my $prereq_pm = $obj->prereq_pm) { | |
9727 | for my $k (keys %$prereq_pm) { | |
9728 | if (my $want_version = $prereq_pm->{$k}{$self->id}) { | |
9729 | if (CPAN::Version->vcmp($have_version,$want_version) >= 0) { | |
9730 | $self->{incommandcolor} = $color; | |
9731 | return; | |
9732 | } | |
9733 | } | |
9734 | } | |
9735 | } | |
9736 | } | |
9737 | } | |
9738 | } | |
9739 | } else { | |
9740 | $self->{incommandcolor} = $color; # set me before recursion, | |
9741 | # so we can break it | |
9742 | } | |
f04ea8d1 | 9743 | if ($depth>=$CPAN::MAX_RECURSION) { |
ade94d80 | 9744 | die(CPAN::Exception::RecursiveDependency->new($ancestors)); |
35576f8c A |
9745 | } |
9746 | # warn "color_cmd_tmps $depth $color " . $self->id; # sleep 1; | |
6d29edf5 JH |
9747 | |
9748 | if ( my $dist = CPAN::Shell->expand("Distribution", $self->cpan_file) ) { | |
35576f8c | 9749 | $dist->color_cmd_tmps($depth+1,$color,[@$ancestors, $self->id]); |
6d29edf5 | 9750 | } |
b72dd56f SP |
9751 | # unreached code? |
9752 | # if ($color==0) { | |
9753 | # delete $self->{badtestcnt}; | |
9754 | # } | |
6d29edf5 JH |
9755 | $self->{incommandcolor} = $color; |
9756 | } | |
9757 | ||
05454584 A |
9758 | #-> sub CPAN::Module::as_glimpse ; |
9759 | sub as_glimpse { | |
9760 | my($self) = @_; | |
9761 | my(@m); | |
9762 | my $class = ref($self); | |
9763 | $class =~ s/^CPAN:://; | |
9d61fa1d A |
9764 | my $color_on = ""; |
9765 | my $color_off = ""; | |
9766 | if ( | |
9767 | $CPAN::Shell::COLOR_REGISTERED | |
9768 | && | |
9769 | $CPAN::META->has_inst("Term::ANSIColor") | |
9770 | && | |
0cf35e6a | 9771 | $self->description |
9d61fa1d A |
9772 | ) { |
9773 | $color_on = Term::ANSIColor::color("green"); | |
9774 | $color_off = Term::ANSIColor::color("reset"); | |
9775 | } | |
ed84aac9 | 9776 | my $uptodateness = " "; |
ecc7fca0 A |
9777 | unless ($class eq "Bundle") { |
9778 | my $u = $self->uptodate; | |
9779 | $uptodateness = $u ? "=" : "<" if defined $u; | |
9780 | }; | |
9781 | my $id = do { | |
9782 | my $d = $self->distribution; | |
9783 | $d ? $d -> pretty_id : $self->cpan_userid; | |
9784 | }; | |
ed84aac9 | 9785 | push @m, sprintf("%-7s %1s %s%-22s%s (%s)\n", |
9d61fa1d | 9786 | $class, |
ed84aac9 | 9787 | $uptodateness, |
9d61fa1d A |
9788 | $color_on, |
9789 | $self->id, | |
9790 | $color_off, | |
ecc7fca0 | 9791 | $id, |
c9869e1c | 9792 | ); |
05454584 A |
9793 | join "", @m; |
9794 | } | |
5f05dabc | 9795 | |
87892b73 RGS |
9796 | #-> sub CPAN::Module::dslip_status |
9797 | sub dslip_status { | |
9798 | my($self) = @_; | |
9799 | my($stat); | |
f20de9f0 | 9800 | # development status |
87892b73 RGS |
9801 | @{$stat->{D}}{qw,i c a b R M S,} = qw,idea |
9802 | pre-alpha alpha beta released | |
9803 | mature standard,; | |
f20de9f0 | 9804 | # support level |
87892b73 RGS |
9805 | @{$stat->{S}}{qw,m d u n a,} = qw,mailing-list |
9806 | developer comp.lang.perl.* | |
9807 | none abandoned,; | |
f20de9f0 | 9808 | # language |
87892b73 | 9809 | @{$stat->{L}}{qw,p c + o h,} = qw,perl C C++ other hybrid,; |
f20de9f0 | 9810 | # interface |
87892b73 RGS |
9811 | @{$stat->{I}}{qw,f r O p h n,} = qw,functions |
9812 | references+ties | |
9813 | object-oriented pragma | |
9814 | hybrid none,; | |
f20de9f0 | 9815 | # public licence |
f04ea8d1 | 9816 | @{$stat->{P}}{qw,p g l b a 2 o d r n,} = qw,Standard-Perl |
87892b73 | 9817 | GPL LGPL |
f04ea8d1 | 9818 | BSD Artistic Artistic_2 |
87892b73 RGS |
9819 | open-source |
9820 | distribution_allowed | |
9821 | restricted_distribution | |
9822 | no_licence,; | |
9823 | for my $x (qw(d s l i p)) { | |
9824 | $stat->{$x}{' '} = 'unknown'; | |
9825 | $stat->{$x}{'?'} = 'unknown'; | |
9826 | } | |
9827 | my $ro = $self->ro; | |
9828 | return +{} unless $ro && $ro->{statd}; | |
9829 | return { | |
9830 | D => $ro->{statd}, | |
9831 | S => $ro->{stats}, | |
9832 | L => $ro->{statl}, | |
9833 | I => $ro->{stati}, | |
9834 | P => $ro->{statp}, | |
9835 | DV => $stat->{D}{$ro->{statd}}, | |
9836 | SV => $stat->{S}{$ro->{stats}}, | |
9837 | LV => $stat->{L}{$ro->{statl}}, | |
9838 | IV => $stat->{I}{$ro->{stati}}, | |
9839 | PV => $stat->{P}{$ro->{statp}}, | |
9840 | }; | |
9841 | } | |
9842 | ||
05454584 A |
9843 | #-> sub CPAN::Module::as_string ; |
9844 | sub as_string { | |
9845 | my($self) = @_; | |
9846 | my(@m); | |
35576f8c | 9847 | CPAN->debug("$self entering as_string") if $CPAN::DEBUG; |
05454584 A |
9848 | my $class = ref($self); |
9849 | $class =~ s/^CPAN:://; | |
9850 | local($^W) = 0; | |
9851 | push @m, $class, " id = $self->{ID}\n"; | |
9852 | my $sprintf = " %-12s %s\n"; | |
6d29edf5 | 9853 | push @m, sprintf($sprintf, 'DESCRIPTION', $self->description) |
f04ea8d1 | 9854 | if $self->description; |
05454584 A |
9855 | my $sprintf2 = " %-12s %s (%s)\n"; |
9856 | my($userid); | |
35576f8c | 9857 | $userid = $self->userid; |
f04ea8d1 SP |
9858 | if ( $userid ) { |
9859 | my $author; | |
9860 | if ($author = CPAN::Shell->expand('Author',$userid)) { | |
9861 | my $email = ""; | |
9862 | my $m; # old perls | |
9863 | if ($m = $author->email) { | |
9864 | $email = " <$m>"; | |
9865 | } | |
9866 | push @m, sprintf( | |
9867 | $sprintf2, | |
9868 | 'CPAN_USERID', | |
9869 | $userid, | |
9870 | $author->fullname . $email | |
9871 | ); | |
9872 | } | |
c356248b | 9873 | } |
6d29edf5 | 9874 | push @m, sprintf($sprintf, 'CPAN_VERSION', $self->cpan_version) |
f04ea8d1 SP |
9875 | if $self->cpan_version; |
9876 | if (my $cpan_file = $self->cpan_file) { | |
554a9ef5 SP |
9877 | push @m, sprintf($sprintf, 'CPAN_FILE', $cpan_file); |
9878 | if (my $dist = CPAN::Shell->expand("Distribution",$cpan_file)) { | |
9879 | my $upload_date = $dist->upload_date; | |
9880 | if ($upload_date) { | |
9881 | push @m, sprintf($sprintf, 'UPLOAD_DATE', $upload_date); | |
9882 | } | |
9883 | } | |
9884 | } | |
87892b73 RGS |
9885 | my $sprintf3 = " %-12s %1s%1s%1s%1s%1s (%s,%s,%s,%s,%s)\n"; |
9886 | my $dslip = $self->dslip_status; | |
05454584 | 9887 | push @m, sprintf( |
87892b73 RGS |
9888 | $sprintf3, |
9889 | 'DSLIP_STATUS', | |
9890 | @{$dslip}{qw(D S L I P DV SV LV IV PV)}, | |
ed84aac9 | 9891 | ) if $dslip->{D}; |
05454584 | 9892 | my $local_file = $self->inst_file; |
9d61fa1d | 9893 | unless ($self->{MANPAGE}) { |
ed84aac9 | 9894 | my $manpage; |
9d61fa1d | 9895 | if ($local_file) { |
ed84aac9 | 9896 | $manpage = $self->manpage_headline($local_file); |
9d61fa1d A |
9897 | } else { |
9898 | # If we have already untarred it, we should look there | |
9899 | my $dist = $CPAN::META->instance('CPAN::Distribution', | |
9900 | $self->cpan_file); | |
9901 | # warn "dist[$dist]"; | |
9902 | # mff=manifest file; mfh=manifest handle | |
9903 | my($mff,$mfh); | |
c049f953 JH |
9904 | if ( |
9905 | $dist->{build_dir} | |
9906 | and | |
5de3f0da | 9907 | (-f ($mff = File::Spec->catfile($dist->{build_dir}, "MANIFEST"))) |
c049f953 | 9908 | and |
9d61fa1d A |
9909 | $mfh = FileHandle->new($mff) |
9910 | ) { | |
8d97e4a1 | 9911 | CPAN->debug("mff[$mff]") if $CPAN::DEBUG; |
9d61fa1d A |
9912 | my $lfre = $self->id; # local file RE |
9913 | $lfre =~ s/::/./g; | |
9914 | $lfre .= "\\.pm\$"; | |
9915 | my($lfl); # local file file | |
9916 | local $/ = "\n"; | |
9917 | my(@mflines) = <$mfh>; | |
8d97e4a1 JH |
9918 | for (@mflines) { |
9919 | s/^\s+//; | |
9920 | s/\s.*//s; | |
9921 | } | |
9d61fa1d A |
9922 | while (length($lfre)>5 and !$lfl) { |
9923 | ($lfl) = grep /$lfre/, @mflines; | |
8d97e4a1 | 9924 | CPAN->debug("lfl[$lfl]lfre[$lfre]") if $CPAN::DEBUG; |
9d61fa1d | 9925 | $lfre =~ s/.+?\.//; |
9d61fa1d A |
9926 | } |
9927 | $lfl =~ s/\s.*//; # remove comments | |
9928 | $lfl =~ s/\s+//g; # chomp would maybe be too system-specific | |
5de3f0da | 9929 | my $lfl_abs = File::Spec->catfile($dist->{build_dir},$lfl); |
9d61fa1d A |
9930 | # warn "lfl_abs[$lfl_abs]"; |
9931 | if (-f $lfl_abs) { | |
ed84aac9 | 9932 | $manpage = $self->manpage_headline($lfl_abs); |
9d61fa1d A |
9933 | } |
9934 | } | |
9935 | } | |
ed84aac9 | 9936 | $self->{MANPAGE} = $manpage if $manpage; |
5f05dabc | 9937 | } |
d4fd5c69 | 9938 | my($item); |
6d29edf5 | 9939 | for $item (qw/MANPAGE/) { |
f04ea8d1 SP |
9940 | push @m, sprintf($sprintf, $item, $self->{$item}) |
9941 | if exists $self->{$item}; | |
d4fd5c69 | 9942 | } |
6d29edf5 | 9943 | for $item (qw/CONTAINS/) { |
f04ea8d1 SP |
9944 | push @m, sprintf($sprintf, $item, join(" ",@{$self->{$item}})) |
9945 | if exists $self->{$item} && @{$self->{$item}}; | |
6d29edf5 | 9946 | } |
c356248b | 9947 | push @m, sprintf($sprintf, 'INST_FILE', |
f04ea8d1 | 9948 | $local_file || "(not installed)"); |
c356248b | 9949 | push @m, sprintf($sprintf, 'INST_VERSION', |
f04ea8d1 | 9950 | $self->inst_version) if $local_file; |
05454584 | 9951 | join "", @m, "\n"; |
5f05dabc | 9952 | } |
9953 | ||
dc053c64 | 9954 | #-> sub CPAN::Module::manpage_headline |
09d9d230 | 9955 | sub manpage_headline { |
f04ea8d1 SP |
9956 | my($self,$local_file) = @_; |
9957 | my(@local_file) = $local_file; | |
9958 | $local_file =~ s/\.pm(?!\n)\Z/.pod/; | |
9959 | push @local_file, $local_file; | |
9960 | my(@result,$locf); | |
9961 | for $locf (@local_file) { | |
9962 | next unless -f $locf; | |
9963 | my $fh = FileHandle->new($locf) | |
9964 | or $Carp::Frontend->mydie("Couldn't open $locf: $!"); | |
9965 | my $inpod = 0; | |
9966 | local $/ = "\n"; | |
9967 | while (<$fh>) { | |
9968 | $inpod = m/^=(?!head1\s+NAME\s*$)/ ? 0 : | |
9969 | m/^=head1\s+NAME\s*$/ ? 1 : $inpod; | |
9970 | next unless $inpod; | |
9971 | next if /^=/; | |
9972 | next if /^\s+$/; | |
9973 | chomp; | |
9974 | push @result, $_; | |
9975 | } | |
9976 | close $fh; | |
9977 | last if @result; | |
09d9d230 | 9978 | } |
f04ea8d1 SP |
9979 | for (@result) { |
9980 | s/^\s+//; | |
9981 | s/\s+$//; | |
9982 | } | |
9983 | join " ", @result; | |
09d9d230 A |
9984 | } |
9985 | ||
05454584 | 9986 | #-> sub CPAN::Module::cpan_file ; |
c049f953 JH |
9987 | # Note: also inherited by CPAN::Bundle |
9988 | sub cpan_file { | |
05454584 | 9989 | my $self = shift; |
6658a91b | 9990 | # CPAN->debug(sprintf "id[%s]", $self->id) if $CPAN::DEBUG; |
0cf35e6a | 9991 | unless ($self->ro) { |
f04ea8d1 | 9992 | CPAN::Index->reload; |
05454584 | 9993 | } |
0cf35e6a | 9994 | my $ro = $self->ro; |
f04ea8d1 SP |
9995 | if ($ro && defined $ro->{CPAN_FILE}) { |
9996 | return $ro->{CPAN_FILE}; | |
10b2abe6 | 9997 | } else { |
8d97e4a1 JH |
9998 | my $userid = $self->userid; |
9999 | if ( $userid ) { | |
10000 | if ($CPAN::META->exists("CPAN::Author",$userid)) { | |
10001 | my $author = $CPAN::META->instance("CPAN::Author", | |
10002 | $userid); | |
10003 | my $fullname = $author->fullname; | |
10004 | my $email = $author->email; | |
10005 | unless (defined $fullname && defined $email) { | |
10006 | return sprintf("Contact Author %s", | |
10007 | $userid, | |
10008 | ); | |
10009 | } | |
10010 | return "Contact Author $fullname <$email>"; | |
10011 | } else { | |
1426a145 | 10012 | return "Contact Author $userid (Email address not available)"; |
8d97e4a1 JH |
10013 | } |
10014 | } else { | |
10015 | return "N/A"; | |
10016 | } | |
5f05dabc | 10017 | } |
10018 | } | |
10019 | ||
05454584 | 10020 | #-> sub CPAN::Module::cpan_version ; |
c356248b A |
10021 | sub cpan_version { |
10022 | my $self = shift; | |
6d29edf5 | 10023 | |
0cf35e6a SP |
10024 | my $ro = $self->ro; |
10025 | unless ($ro) { | |
10026 | # Can happen with modules that are not on CPAN | |
10027 | $ro = {}; | |
10028 | } | |
10029 | $ro->{CPAN_VERSION} = 'undef' | |
f04ea8d1 | 10030 | unless defined $ro->{CPAN_VERSION}; |
0cf35e6a | 10031 | $ro->{CPAN_VERSION}; |
c356248b | 10032 | } |
5f05dabc | 10033 | |
05454584 A |
10034 | #-> sub CPAN::Module::force ; |
10035 | sub force { | |
10036 | my($self) = @_; | |
b72dd56f SP |
10037 | $self->{force_update} = 1; |
10038 | } | |
10039 | ||
10040 | #-> sub CPAN::Module::fforce ; | |
10041 | sub fforce { | |
10042 | my($self) = @_; | |
10043 | $self->{force_update} = 2; | |
5f05dabc | 10044 | } |
10045 | ||
23a216b4 | 10046 | #-> sub CPAN::Module::notest ; |
554a9ef5 | 10047 | sub notest { |
f3fe0ae6 | 10048 | my($self) = @_; |
23a216b4 SP |
10049 | # $CPAN::Frontend->mywarn("XDEBUG: set notest for Module"); |
10050 | $self->{notest}++; | |
554a9ef5 SP |
10051 | } |
10052 | ||
05454584 A |
10053 | #-> sub CPAN::Module::rematein ; |
10054 | sub rematein { | |
10055 | my($self,$meth) = @_; | |
6a935156 | 10056 | $CPAN::Frontend->myprint(sprintf("Running %s for module '%s'\n", |
6d29edf5 JH |
10057 | $meth, |
10058 | $self->id)); | |
05454584 | 10059 | my $cpan_file = $self->cpan_file; |
f04ea8d1 SP |
10060 | if ($cpan_file eq "N/A" || $cpan_file =~ /^Contact Author/) { |
10061 | $CPAN::Frontend->mywarn(sprintf qq{ | |
09d9d230 A |
10062 | The module %s isn\'t available on CPAN. |
10063 | ||
10064 | Either the module has not yet been uploaded to CPAN, or it is | |
10065 | temporary unavailable. Please contact the author to find out | |
c4d24d4c | 10066 | more about the status. Try 'i %s'. |
09d9d230 | 10067 | }, |
f04ea8d1 SP |
10068 | $self->id, |
10069 | $self->id, | |
10070 | ); | |
10071 | return; | |
09d9d230 | 10072 | } |
05454584 A |
10073 | my $pack = $CPAN::META->instance('CPAN::Distribution',$cpan_file); |
10074 | $pack->called_for($self->id); | |
f04ea8d1 | 10075 | if (exists $self->{force_update}) { |
b72dd56f SP |
10076 | if ($self->{force_update} == 2) { |
10077 | $pack->fforce($meth); | |
10078 | } else { | |
10079 | $pack->force($meth); | |
10080 | } | |
10081 | } | |
23a216b4 | 10082 | $pack->notest($meth) if exists $self->{notest} && $self->{notest}; |
135a59c2 A |
10083 | |
10084 | $pack->{reqtype} ||= ""; | |
10085 | CPAN->debug("dist-reqtype[$pack->{reqtype}]". | |
10086 | "self-reqtype[$self->{reqtype}]") if $CPAN::DEBUG; | |
10087 | if ($pack->{reqtype}) { | |
10088 | if ($pack->{reqtype} eq "b" && $self->{reqtype} =~ /^[rc]$/) { | |
10089 | $pack->{reqtype} = $self->{reqtype}; | |
10090 | if ( | |
10091 | exists $pack->{install} | |
10092 | && | |
10093 | ( | |
be34b10d | 10094 | UNIVERSAL::can($pack->{install},"failed") ? |
135a59c2 A |
10095 | $pack->{install}->failed : |
10096 | $pack->{install} =~ /^NO/ | |
10097 | ) | |
10098 | ) { | |
10099 | delete $pack->{install}; | |
10100 | $CPAN::Frontend->mywarn | |
10101 | ("Promoting $pack->{ID} from 'build_requires' to 'requires'"); | |
10102 | } | |
10103 | } | |
10104 | } else { | |
10105 | $pack->{reqtype} = $self->{reqtype}; | |
10106 | } | |
10107 | ||
23a216b4 | 10108 | my $success = eval { |
f04ea8d1 | 10109 | $pack->$meth(); |
554a9ef5 SP |
10110 | }; |
10111 | my $err = $@; | |
b72dd56f | 10112 | $pack->unforce if $pack->can("unforce") && exists $self->{force_update}; |
23a216b4 | 10113 | $pack->unnotest if $pack->can("unnotest") && exists $self->{notest}; |
b72dd56f | 10114 | delete $self->{force_update}; |
23a216b4 | 10115 | delete $self->{notest}; |
554a9ef5 | 10116 | if ($err) { |
f04ea8d1 | 10117 | die $err; |
554a9ef5 | 10118 | } |
23a216b4 | 10119 | return $success; |
5f05dabc | 10120 | } |
10121 | ||
554a9ef5 SP |
10122 | #-> sub CPAN::Module::perldoc ; |
10123 | sub perldoc { shift->rematein('perldoc') } | |
05454584 | 10124 | #-> sub CPAN::Module::readme ; |
554a9ef5 | 10125 | sub readme { shift->rematein('readme') } |
05454584 | 10126 | #-> sub CPAN::Module::look ; |
554a9ef5 | 10127 | sub look { shift->rematein('look') } |
911a92db GS |
10128 | #-> sub CPAN::Module::cvs_import ; |
10129 | sub cvs_import { shift->rematein('cvs_import') } | |
05454584 | 10130 | #-> sub CPAN::Module::get ; |
554a9ef5 | 10131 | sub get { shift->rematein('get',@_) } |
05454584 | 10132 | #-> sub CPAN::Module::make ; |
554a9ef5 | 10133 | sub make { shift->rematein('make') } |
05454584 | 10134 | #-> sub CPAN::Module::test ; |
6d29edf5 JH |
10135 | sub test { |
10136 | my $self = shift; | |
b72dd56f | 10137 | # $self->{badtestcnt} ||= 0; |
6d29edf5 JH |
10138 | $self->rematein('test',@_); |
10139 | } | |
ecc7fca0 | 10140 | |
f610777f A |
10141 | #-> sub CPAN::Module::uptodate ; |
10142 | sub uptodate { | |
ecc7fca0 A |
10143 | my ($self) = @_; |
10144 | local ($_); | |
10145 | my $inst = $self->inst_version or return undef; | |
10146 | my $cpan = $self->cpan_version; | |
10147 | local ($^W) = 0; | |
10148 | CPAN::Version->vgt($cpan,$inst) and return 0; | |
b03f445c | 10149 | CPAN->debug(join("", |
ecc7fca0 A |
10150 | "returning uptodate. inst_file[", |
10151 | $self->inst_file, | |
10152 | "cpan[$cpan] inst[$inst]")) if $CPAN::DEBUG; | |
10153 | return 1; | |
f610777f | 10154 | } |
ecc7fca0 | 10155 | |
f610777f A |
10156 | #-> sub CPAN::Module::install ; |
10157 | sub install { | |
10158 | my($self) = @_; | |
10159 | my($doit) = 0; | |
10160 | if ($self->uptodate | |
f04ea8d1 SP |
10161 | && |
10162 | not exists $self->{force_update} | |
f610777f | 10163 | ) { |
f04ea8d1 | 10164 | $CPAN::Frontend->myprint(sprintf("%s is up to date (%s).\n", |
0cf35e6a SP |
10165 | $self->id, |
10166 | $self->inst_version, | |
10167 | )); | |
f610777f | 10168 | } else { |
f04ea8d1 | 10169 | $doit = 1; |
f610777f | 10170 | } |
0cf35e6a SP |
10171 | my $ro = $self->ro; |
10172 | if ($ro && $ro->{stats} && $ro->{stats} eq "a") { | |
35576f8c A |
10173 | $CPAN::Frontend->mywarn(qq{ |
10174 | \n\n\n ***WARNING*** | |
10175 | The module $self->{ID} has no active maintainer.\n\n\n | |
10176 | }); | |
8962fc49 | 10177 | $CPAN::Frontend->mysleep(5); |
35576f8c | 10178 | } |
05454584 | 10179 | $self->rematein('install') if $doit; |
5f05dabc | 10180 | } |
05454584 A |
10181 | #-> sub CPAN::Module::clean ; |
10182 | sub clean { shift->rematein('clean') } | |
5f05dabc | 10183 | |
05454584 A |
10184 | #-> sub CPAN::Module::inst_file ; |
10185 | sub inst_file { | |
10186 | my($self) = @_; | |
810a0276 SP |
10187 | $self->_file_in_path([@INC]); |
10188 | } | |
10189 | ||
10190 | #-> sub CPAN::Module::available_file ; | |
10191 | sub available_file { | |
10192 | my($self) = @_; | |
10193 | my $sep = $Config::Config{path_sep}; | |
10194 | my $perllib = $ENV{PERL5LIB}; | |
10195 | $perllib = $ENV{PERLLIB} unless defined $perllib; | |
10196 | my @perllib = split(/$sep/,$perllib) if defined $perllib; | |
10197 | $self->_file_in_path([@perllib,@INC]); | |
10198 | } | |
10199 | ||
10200 | #-> sub CPAN::Module::file_in_path ; | |
10201 | sub _file_in_path { | |
10202 | my($self,$path) = @_; | |
05454584 A |
10203 | my($dir,@packpath); |
10204 | @packpath = split /::/, $self->{ID}; | |
10205 | $packpath[-1] .= ".pm"; | |
8962fc49 SP |
10206 | if (@packpath == 1 && $packpath[0] eq "readline.pm") { |
10207 | unshift @packpath, "Term", "ReadLine"; # historical reasons | |
10208 | } | |
810a0276 | 10209 | foreach $dir (@$path) { |
f04ea8d1 SP |
10210 | my $pmfile = File::Spec->catfile($dir,@packpath); |
10211 | if (-f $pmfile) { | |
10212 | return $pmfile; | |
10213 | } | |
5f05dabc | 10214 | } |
d4fd5c69 | 10215 | return; |
5f05dabc | 10216 | } |
10217 | ||
05454584 A |
10218 | #-> sub CPAN::Module::xs_file ; |
10219 | sub xs_file { | |
10220 | my($self) = @_; | |
10221 | my($dir,@packpath); | |
10222 | @packpath = split /::/, $self->{ID}; | |
10223 | push @packpath, $packpath[-1]; | |
10224 | $packpath[-1] .= "." . $Config::Config{'dlext'}; | |
10225 | foreach $dir (@INC) { | |
f04ea8d1 SP |
10226 | my $xsfile = File::Spec->catfile($dir,'auto',@packpath); |
10227 | if (-f $xsfile) { | |
10228 | return $xsfile; | |
10229 | } | |
05454584 | 10230 | } |
d4fd5c69 | 10231 | return; |
5f05dabc | 10232 | } |
10233 | ||
05454584 A |
10234 | #-> sub CPAN::Module::inst_version ; |
10235 | sub inst_version { | |
10236 | my($self) = @_; | |
c356248b | 10237 | my $parsefile = $self->inst_file or return; |
810a0276 SP |
10238 | my $have = $self->parse_version($parsefile); |
10239 | $have; | |
10240 | } | |
10241 | ||
10242 | #-> sub CPAN::Module::inst_version ; | |
10243 | sub available_version { | |
10244 | my($self) = @_; | |
10245 | my $parsefile = $self->available_file or return; | |
10246 | my $have = $self->parse_version($parsefile); | |
10247 | $have; | |
10248 | } | |
de34a54b | 10249 | |
810a0276 SP |
10250 | #-> sub CPAN::Module::parse_version ; |
10251 | sub parse_version { | |
10252 | my($self,$parsefile) = @_; | |
10253 | my $have = MM->parse_version($parsefile); | |
be34b10d | 10254 | $have = "undef" unless defined $have && length $have; |
05d2a450 A |
10255 | $have =~ s/^ //; # since the %vd hack these two lines here are needed |
10256 | $have =~ s/ $//; # trailing whitespace happens all the time | |
10257 | ||
5e05dca5 | 10258 | $have = CPAN::Version->readable($have); |
c4d24d4c | 10259 | |
911a92db | 10260 | $have =~ s/\s*//g; # stringify to float around floating point issues |
de34a54b | 10261 | $have; # no stringify needed, \s* above matches always |
5f05dabc | 10262 | } |
10263 | ||
dc053c64 SP |
10264 | #-> sub CPAN::Module::reports |
10265 | sub reports { | |
10266 | my($self) = @_; | |
10267 | $self->distribution->reports; | |
10268 | } | |
10269 | ||
55e314ee | 10270 | package CPAN; |
e82b9348 | 10271 | use strict; |
d4fd5c69 | 10272 | |
5f05dabc | 10273 | 1; |
55e314ee | 10274 | |
ed84aac9 | 10275 | |
e50380aa | 10276 | __END__ |
5f05dabc | 10277 | |
10278 | =head1 NAME | |
10279 | ||
10280 | CPAN - query, download and build perl modules from CPAN sites | |
10281 | ||
10282 | =head1 SYNOPSIS | |
10283 | ||
10284 | Interactive mode: | |
10285 | ||
f20de9f0 | 10286 | perl -MCPAN -e shell |
5f05dabc | 10287 | |
f20de9f0 | 10288 | --or-- |
5f05dabc | 10289 | |
f20de9f0 SP |
10290 | cpan |
10291 | ||
10292 | Basic commands: | |
5f05dabc | 10293 | |
1e8f9a0a SP |
10294 | # Modules: |
10295 | ||
10296 | cpan> install Acme::Meta # in the shell | |
10297 | ||
10298 | CPAN::Shell->install("Acme::Meta"); # in perl | |
10299 | ||
10300 | # Distributions: | |
10301 | ||
10302 | cpan> install NWCLARK/Acme-Meta-0.02.tar.gz # in the shell | |
10303 | ||
10304 | CPAN::Shell-> | |
10305 | install("NWCLARK/Acme-Meta-0.02.tar.gz"); # in perl | |
10306 | ||
10307 | # module objects: | |
c9869e1c | 10308 | |
1e8f9a0a SP |
10309 | $mo = CPAN::Shell->expandany($mod); |
10310 | $mo = CPAN::Shell->expand("Module",$mod); # same thing | |
c9869e1c | 10311 | |
1e8f9a0a | 10312 | # distribution objects: |
c9869e1c | 10313 | |
1e8f9a0a SP |
10314 | $do = CPAN::Shell->expand("Module",$mod)->distribution; |
10315 | $do = CPAN::Shell->expandany($distro); # same thing | |
10316 | $do = CPAN::Shell->expand("Distribution", | |
10317 | $distro); # same thing | |
5f05dabc | 10318 | |
10319 | =head1 DESCRIPTION | |
10320 | ||
f20de9f0 SP |
10321 | The CPAN module automates or at least simplifies the make and install |
10322 | of perl modules and extensions. It includes some primitive searching | |
10323 | capabilities and knows how to use Net::FTP or LWP or some external | |
10324 | download clients to fetch the distributions from the net. | |
5f05dabc | 10325 | |
f20de9f0 SP |
10326 | These are fetched from one or more of the mirrored CPAN (Comprehensive |
10327 | Perl Archive Network) sites and unpacked in a dedicated directory. | |
5f05dabc | 10328 | |
10329 | The CPAN module also supports the concept of named and versioned | |
911a92db GS |
10330 | I<bundles> of modules. Bundles simplify the handling of sets of |
10331 | related modules. See Bundles below. | |
5f05dabc | 10332 | |
b72dd56f SP |
10333 | The package contains a session manager and a cache manager. The |
10334 | session manager keeps track of what has been fetched, built and | |
10335 | installed in the current session. The cache manager keeps track of the | |
10336 | disk space occupied by the make processes and deletes excess space | |
10337 | according to a simple FIFO mechanism. | |
5f05dabc | 10338 | |
c9869e1c | 10339 | All methods provided are accessible in a programmer style and in an |
10b2abe6 CS |
10340 | interactive shell style. |
10341 | ||
2ccf00a7 | 10342 | =head2 CPAN::shell([$prompt, $command]) Starting Interactive Mode |
5f05dabc | 10343 | |
10344 | The interactive mode is entered by running | |
10345 | ||
10346 | perl -MCPAN -e shell | |
10347 | ||
f20de9f0 SP |
10348 | or |
10349 | ||
10350 | cpan | |
10351 | ||
10352 | which puts you into a readline interface. If C<Term::ReadKey> and | |
10353 | either C<Term::ReadLine::Perl> or C<Term::ReadLine::Gnu> are installed | |
10354 | it supports both history and command completion. | |
5f05dabc | 10355 | |
f20de9f0 | 10356 | Once you are on the command line, type C<h> to get a one page help |
b72dd56f | 10357 | screen and the rest should be self-explanatory. |
5f05dabc | 10358 | |
9d61fa1d A |
10359 | The function call C<shell> takes two optional arguments, one is the |
10360 | prompt, the second is the default initial command line (the latter | |
10361 | only works if a real ReadLine interface module is installed). | |
10362 | ||
10b2abe6 CS |
10363 | The most common uses of the interactive modes are |
10364 | ||
10365 | =over 2 | |
10366 | ||
10367 | =item Searching for authors, bundles, distribution files and modules | |
10368 | ||
10369 | There are corresponding one-letter commands C<a>, C<b>, C<d>, and C<m> | |
42d3b621 A |
10370 | for each of the four categories and another, C<i> for any of the |
10371 | mentioned four. Each of the four entities is implemented as a class | |
10372 | with slightly differing methods for displaying an object. | |
10b2abe6 | 10373 | |
09d9d230 | 10374 | Arguments you pass to these commands are either strings exactly matching |
10b2abe6 CS |
10375 | the identification string of an object or regular expressions that are |
10376 | then matched case-insensitively against various attributes of the | |
09d9d230 | 10377 | objects. The parser recognizes a regular expression only if you |
10b2abe6 CS |
10378 | enclose it between two slashes. |
10379 | ||
10380 | The principle is that the number of found objects influences how an | |
911a92db GS |
10381 | item is displayed. If the search finds one item, the result is |
10382 | displayed with the rather verbose method C<as_string>, but if we find | |
10383 | more than one, we display each object with the terse method | |
c9869e1c | 10384 | C<as_glimpse>. |
10b2abe6 | 10385 | |
f20de9f0 | 10386 | =item C<get>, C<make>, C<test>, C<install>, C<clean> modules or distributions |
10b2abe6 | 10387 | |
911a92db | 10388 | These commands take any number of arguments and investigate what is |
09d9d230 | 10389 | necessary to perform the action. If the argument is a distribution |
f14b5cec JH |
10390 | file name (recognized by embedded slashes), it is processed. If it is |
10391 | a module, CPAN determines the distribution file in which this module | |
10392 | is included and processes that, following any dependencies named in | |
e82b9348 | 10393 | the module's META.yml or Makefile.PL (this behavior is controlled by |
c9869e1c | 10394 | the configuration parameter C<prerequisites_policy>.) |
10b2abe6 | 10395 | |
b72dd56f SP |
10396 | C<get> downloads a distribution file and untars or unzips it, C<make> |
10397 | builds it, C<test> runs the test suite, and C<install> installs it. | |
10398 | ||
09d9d230 | 10399 | Any C<make> or C<test> are run unconditionally. An |
42d3b621 | 10400 | |
05454584 | 10401 | install <distribution_file> |
42d3b621 | 10402 | |
09d9d230 | 10403 | also is run unconditionally. But for |
42d3b621 | 10404 | |
05454584 | 10405 | install <module> |
42d3b621 A |
10406 | |
10407 | CPAN checks if an install is actually needed for it and prints | |
09d9d230 | 10408 | I<module up to date> in the case that the distribution file containing |
de34a54b | 10409 | the module doesn't need to be updated. |
10b2abe6 CS |
10410 | |
10411 | CPAN also keeps track of what it has done within the current session | |
de34a54b | 10412 | and doesn't try to build a package a second time regardless if it |
b72dd56f SP |
10413 | succeeded or not. It does not repeat a test run if the test |
10414 | has been run successfully before. Same for install runs. | |
10b2abe6 | 10415 | |
b72dd56f SP |
10416 | The C<force> pragma may precede another command (currently: C<get>, |
10417 | C<make>, C<test>, or C<install>) and executes the command from scratch | |
10418 | and tries to continue in case of some errors. See the section below on | |
f20de9f0 | 10419 | the C<force> and the C<fforce> pragma. |
10b2abe6 | 10420 | |
b72dd56f | 10421 | The C<notest> pragma may be used to skip the test part in the build |
554a9ef5 SP |
10422 | process. |
10423 | ||
10424 | Example: | |
10425 | ||
10426 | cpan> notest install Tk | |
10427 | ||
f610777f | 10428 | A C<clean> command results in a |
09d9d230 A |
10429 | |
10430 | make clean | |
10431 | ||
10432 | being executed within the distribution file's working directory. | |
10433 | ||
f20de9f0 | 10434 | =item C<readme>, C<perldoc>, C<look> module or distribution |
da199366 | 10435 | |
b72dd56f SP |
10436 | C<readme> displays the README file of the associated distribution. |
10437 | C<Look> gets and untars (if not yet done) the distribution file, | |
10438 | changes to the appropriate directory and opens a subshell process in | |
10439 | that directory. C<perldoc> displays the pod documentation of the | |
10440 | module in html or plain text format. | |
09d9d230 | 10441 | |
f20de9f0 | 10442 | =item C<ls> author |
c049f953 | 10443 | |
f20de9f0 | 10444 | =item C<ls> globbing_expression |
e82b9348 SP |
10445 | |
10446 | The first form lists all distribution files in and below an author's | |
ca79d794 SP |
10447 | CPAN directory as they are stored in the CHECKUMS files distributed on |
10448 | CPAN. The listing goes recursive into all subdirectories. | |
e82b9348 SP |
10449 | |
10450 | The second form allows to limit or expand the output with shell | |
10451 | globbing as in the following examples: | |
10452 | ||
f04ea8d1 SP |
10453 | ls JV/make* |
10454 | ls GSAR/*make* | |
10455 | ls */*make* | |
e82b9348 SP |
10456 | |
10457 | The last example is very slow and outputs extra progress indicators | |
10458 | that break the alignment of the result. | |
c049f953 | 10459 | |
ca79d794 SP |
10460 | Note that globbing only lists directories explicitly asked for, for |
10461 | example FOO/* will not list FOO/bar/Acme-Sthg-n.nn.tar.gz. This may be | |
10462 | regarded as a bug and may be changed in future versions. | |
10463 | ||
f20de9f0 | 10464 | =item C<failed> |
9ddc4ed0 A |
10465 | |
10466 | The C<failed> command reports all distributions that failed on one of | |
10467 | C<make>, C<test> or C<install> for some reason in the currently | |
10468 | running shell session. | |
10469 | ||
b72dd56f SP |
10470 | =item Persistence between sessions |
10471 | ||
b03f445c | 10472 | If the C<YAML> or the C<YAML::Syck> module is installed a record of |
b72dd56f SP |
10473 | the internal state of all modules is written to disk after each step. |
10474 | The files contain a signature of the currently running perl version | |
10475 | for later perusal. | |
10476 | ||
10477 | If the configurations variable C<build_dir_reuse> is set to a true | |
10478 | value, then CPAN.pm reads the collected YAML files. If the stored | |
10479 | signature matches the currently running perl the stored state is | |
10480 | loaded into memory such that effectively persistence between sessions | |
10481 | is established. | |
10482 | ||
10483 | =item The C<force> and the C<fforce> pragma | |
10484 | ||
10485 | To speed things up in complex installation scenarios, CPAN.pm keeps | |
10486 | track of what it has already done and refuses to do some things a | |
10487 | second time. A C<get>, a C<make>, and an C<install> are not repeated. | |
10488 | A C<test> is only repeated if the previous test was unsuccessful. The | |
10489 | diagnostic message when CPAN.pm refuses to do something a second time | |
10490 | is one of I<Has already been >C<unwrapped|made|tested successfully> or | |
10491 | something similar. Another situation where CPAN refuses to act is an | |
10492 | C<install> if the according C<test> was not successful. | |
10493 | ||
10494 | In all these cases, the user can override the goatish behaviour by | |
10495 | prepending the command with the word force, for example: | |
10496 | ||
10497 | cpan> force get Foo | |
10498 | cpan> force make AUTHOR/Bar-3.14.tar.gz | |
10499 | cpan> force test Baz | |
10500 | cpan> force install Acme::Meta | |
10501 | ||
10502 | Each I<forced> command is executed with the according part of its | |
10503 | memory erased. | |
10504 | ||
10505 | The C<fforce> pragma is a variant that emulates a C<force get> which | |
10506 | erases the entire memory followed by the action specified, effectively | |
10507 | restarting the whole get/make/test/install procedure from scratch. | |
10508 | ||
c9869e1c SP |
10509 | =item Lockfile |
10510 | ||
be34b10d SP |
10511 | Interactive sessions maintain a lockfile, per default C<~/.cpan/.lock>. |
10512 | Batch jobs can run without a lockfile and do not disturb each other. | |
c9869e1c | 10513 | |
be34b10d SP |
10514 | The shell offers to run in I<degraded mode> when another process is |
10515 | holding the lockfile. This is an experimental feature that is not yet | |
10516 | tested very well. This second shell then does not write the history | |
10517 | file, does not use the metadata file and has a different prompt. | |
c9869e1c | 10518 | |
09d9d230 A |
10519 | =item Signals |
10520 | ||
10521 | CPAN.pm installs signal handlers for SIGINT and SIGTERM. While you are | |
10522 | in the cpan-shell it is intended that you can press C<^C> anytime and | |
10523 | return to the cpan-shell prompt. A SIGTERM will cause the cpan-shell | |
10524 | to clean up and leave the shell loop. You can emulate the effect of a | |
10525 | SIGTERM by sending two consecutive SIGINTs, which usually means by | |
10526 | pressing C<^C> twice. | |
10527 | ||
b03f445c | 10528 | CPAN.pm ignores a SIGPIPE. If the user sets C<inactivity_timeout>, a |
e82b9348 SP |
10529 | SIGALRM is used during the run of the C<perl Makefile.PL> or C<perl |
10530 | Build.PL> subprocess. | |
da199366 | 10531 | |
10b2abe6 CS |
10532 | =back |
10533 | ||
5f05dabc | 10534 | =head2 CPAN::Shell |
10535 | ||
10536 | The commands that are available in the shell interface are methods in | |
10537 | the package CPAN::Shell. If you enter the shell command, all your | |
10b2abe6 CS |
10538 | input is split by the Text::ParseWords::shellwords() routine which |
10539 | acts like most shells do. The first word is being interpreted as the | |
10540 | method to be called and the rest of the words are treated as arguments | |
c356248b A |
10541 | to this method. Continuation lines are supported if a line ends with a |
10542 | literal backslash. | |
10b2abe6 | 10543 | |
da199366 A |
10544 | =head2 autobundle |
10545 | ||
10546 | C<autobundle> writes a bundle file into the | |
10547 | C<$CPAN::Config-E<gt>{cpan_home}/Bundle> directory. The file contains | |
10548 | a list of all modules that are both available from CPAN and currently | |
10549 | installed within @INC. The name of the bundle file is based on the | |
10550 | current date and a counter. | |
10551 | ||
05bab18e SP |
10552 | =head2 hosts |
10553 | ||
ed756621 SP |
10554 | Note: this feature is still in alpha state and may change in future |
10555 | versions of CPAN.pm | |
10556 | ||
05bab18e SP |
10557 | This commands provides a statistical overview over recent download |
10558 | activities. The data for this is collected in the YAML file | |
10559 | C<FTPstats.yml> in your C<cpan_home> directory. If no YAML module is | |
10560 | configured or YAML not installed, then no stats are provided. | |
10561 | ||
10562 | =head2 mkmyconfig | |
10563 | ||
10564 | mkmyconfig() writes your own CPAN::MyConfig file into your ~/.cpan/ | |
10565 | directory so that you can save your own preferences instead of the | |
10566 | system wide ones. | |
10567 | ||
f04ea8d1 SP |
10568 | =head2 recent ***EXPERIMENTAL COMMAND*** |
10569 | ||
10570 | The C<recent> command downloads a list of recent uploads to CPAN and | |
10571 | displays them I<slowly>. While the command is running $SIG{INT} is | |
10572 | defined to mean that the loop shall be left after having displayed the | |
10573 | current item. | |
10574 | ||
10575 | B<Note>: This command requires XML::LibXML installed. | |
10576 | ||
10577 | B<Note>: This whole command currently is a bit klunky and will | |
10578 | probably change in future versions of CPAN.pm but the general | |
10579 | approach will likely stay. | |
10580 | ||
10581 | B<Note>: See also L<smoke> | |
10582 | ||
da199366 A |
10583 | =head2 recompile |
10584 | ||
10585 | recompile() is a very special command in that it takes no argument and | |
10586 | runs the make/test/install cycle with brute force over all installed | |
10587 | dynamically loadable extensions (aka XS modules) with 'force' in | |
09d9d230 | 10588 | effect. The primary purpose of this command is to finish a network |
da199366 A |
10589 | installation. Imagine, you have a common source tree for two different |
10590 | architectures. You decide to do a completely independent fresh | |
10591 | installation. You start on one architecture with the help of a Bundle | |
10592 | file produced earlier. CPAN installs the whole Bundle for you, but | |
10593 | when you try to repeat the job on the second architecture, CPAN | |
10594 | responds with a C<"Foo up to date"> message for all modules. So you | |
de34a54b | 10595 | invoke CPAN's recompile on the second architecture and you're done. |
da199366 A |
10596 | |
10597 | Another popular use for C<recompile> is to act as a rescue in case your | |
10598 | perl breaks binary compatibility. If one of the modules that CPAN uses | |
10599 | is in turn depending on binary compatibility (so you cannot run CPAN | |
10600 | commands), then you should try the CPAN::Nox module for recovery. | |
10601 | ||
8fc516fe SP |
10602 | =head2 report Bundle|Distribution|Module |
10603 | ||
10604 | The C<report> command temporarily turns on the C<test_report> config | |
6658a91b SP |
10605 | variable, then runs the C<force test> command with the given |
10606 | arguments. The C<force> pragma is used to re-run the tests and repeat | |
10607 | every step that might have failed before. | |
8fc516fe | 10608 | |
f04ea8d1 SP |
10609 | =head2 smoke ***EXPERIMENTAL COMMAND*** |
10610 | ||
10611 | B<*** WARNING: this command downloads and executes software from CPAN to | |
b03f445c RGS |
10612 | your computer of completely unknown status. You should never do |
10613 | this with your normal account and better have a dedicated well | |
10614 | separated and secured machine to do this. ***> | |
f04ea8d1 SP |
10615 | |
10616 | The C<smoke> command takes the list of recent uploads to CPAN as | |
10617 | provided by the C<recent> command and tests them all. While the | |
10618 | command is running $SIG{INT} is defined to mean that the current item | |
10619 | shall be skipped. | |
10620 | ||
10621 | B<Note>: This whole command currently is a bit klunky and will | |
10622 | probably change in future versions of CPAN.pm but the general | |
10623 | approach will likely stay. | |
10624 | ||
10625 | B<Note>: See also L<recent> | |
10626 | ||
135a59c2 | 10627 | =head2 upgrade [Module|/Regex/]... |
ed84aac9 | 10628 | |
135a59c2 A |
10629 | The C<upgrade> command first runs an C<r> command with the given |
10630 | arguments and then installs the newest versions of all modules that | |
10631 | were listed by that. | |
ed84aac9 | 10632 | |
c356248b | 10633 | =head2 The four C<CPAN::*> Classes: Author, Bundle, Module, Distribution |
e50380aa | 10634 | |
09d9d230 A |
10635 | Although it may be considered internal, the class hierarchy does matter |
10636 | for both users and programmer. CPAN.pm deals with above mentioned four | |
10637 | classes, and all those classes share a set of methods. A classical | |
10638 | single polymorphism is in effect. A metaclass object registers all | |
10639 | objects of all kinds and indexes them with a string. The strings | |
10640 | referencing objects have a separated namespace (well, not completely | |
10641 | separated): | |
e50380aa A |
10642 | |
10643 | Namespace Class | |
10644 | ||
10645 | words containing a "/" (slash) Distribution | |
10646 | words starting with Bundle:: Bundle | |
10647 | everything else Module or Author | |
10648 | ||
10649 | Modules know their associated Distribution objects. They always refer | |
09d9d230 A |
10650 | to the most recent official release. Developers may mark their releases |
10651 | as unstable development versions (by inserting an underbar into the | |
16703a00 | 10652 | module version number which will also be reflected in the distribution |
6658a91b SP |
10653 | name when you run 'make dist'), so the really hottest and newest |
10654 | distribution is not always the default. If a module Foo circulates | |
10655 | on CPAN in both version 1.23 and 1.23_90, CPAN.pm offers a convenient | |
16703a00 | 10656 | way to install version 1.23 by saying |
e50380aa A |
10657 | |
10658 | install Foo | |
10659 | ||
10660 | This would install the complete distribution file (say | |
09d9d230 A |
10661 | BAR/Foo-1.23.tar.gz) with all accompanying material. But if you would |
10662 | like to install version 1.23_90, you need to know where the | |
e50380aa | 10663 | distribution file resides on CPAN relative to the authors/id/ |
09d9d230 | 10664 | directory. If the author is BAR, this might be BAR/Foo-1.23_90.tar.gz; |
c356248b | 10665 | so you would have to say |
e50380aa A |
10666 | |
10667 | install BAR/Foo-1.23_90.tar.gz | |
10668 | ||
10669 | The first example will be driven by an object of the class | |
c356248b | 10670 | CPAN::Module, the second by an object of class CPAN::Distribution. |
e50380aa | 10671 | |
6658a91b SP |
10672 | =head2 Integrating local directories |
10673 | ||
ed756621 SP |
10674 | Note: this feature is still in alpha state and may change in future |
10675 | versions of CPAN.pm | |
10676 | ||
6658a91b | 10677 | Distribution objects are normally distributions from the CPAN, but |
b72dd56f SP |
10678 | there is a slightly degenerate case for Distribution objects, too, of |
10679 | projects held on the local disk. These distribution objects have the | |
10680 | same name as the local directory and end with a dot. A dot by itself | |
10681 | is also allowed for the current directory at the time CPAN.pm was | |
10682 | used. All actions such as C<make>, C<test>, and C<install> are applied | |
6658a91b SP |
10683 | directly to that directory. This gives the command C<cpan .> an |
10684 | interesting touch: while the normal mantra of installing a CPAN module | |
10685 | without CPAN.pm is one of | |
10686 | ||
10687 | perl Makefile.PL perl Build.PL | |
10688 | ( go and get prerequisites ) | |
10689 | make ./Build | |
10690 | make test ./Build test | |
10691 | make install ./Build install | |
10692 | ||
10693 | the command C<cpan .> does all of this at once. It figures out which | |
10694 | of the two mantras is appropriate, fetches and installs all | |
10695 | prerequisites, cares for them recursively and finally finishes the | |
10696 | installation of the module in the current directory, be it a CPAN | |
10697 | module or not. | |
10698 | ||
b72dd56f SP |
10699 | The typical usage case is for private modules or working copies of |
10700 | projects from remote repositories on the local disk. | |
10701 | ||
f20de9f0 | 10702 | =head1 CONFIGURATION |
55e314ee | 10703 | |
f20de9f0 SP |
10704 | When the CPAN module is used for the first time, a configuration |
10705 | dialog tries to determine a couple of site specific options. The | |
10706 | result of the dialog is stored in a hash reference C< $CPAN::Config > | |
10707 | in a file CPAN/Config.pm. | |
de34a54b | 10708 | |
f20de9f0 SP |
10709 | The default values defined in the CPAN/Config.pm file can be |
10710 | overridden in a user specific file: CPAN/MyConfig.pm. Such a file is | |
10711 | best placed in $HOME/.cpan/CPAN/MyConfig.pm, because $HOME/.cpan is | |
10712 | added to the search path of the CPAN module before the use() or | |
10713 | require() statements. The mkmyconfig command writes this file for you. | |
36263cb3 | 10714 | |
f20de9f0 | 10715 | The C<o conf> command has various bells and whistles: |
36263cb3 | 10716 | |
f20de9f0 | 10717 | =over |
36263cb3 | 10718 | |
f20de9f0 | 10719 | =item completion support |
36263cb3 | 10720 | |
f20de9f0 SP |
10721 | If you have a ReadLine module installed, you can hit TAB at any point |
10722 | of the commandline and C<o conf> will offer you completion for the | |
10723 | built-in subcommands and/or config variable names. | |
36263cb3 | 10724 | |
f20de9f0 | 10725 | =item displaying some help: o conf help |
36263cb3 | 10726 | |
f20de9f0 | 10727 | Displays a short help |
36263cb3 | 10728 | |
f20de9f0 | 10729 | =item displaying current values: o conf [KEY] |
36263cb3 | 10730 | |
f20de9f0 SP |
10731 | Displays the current value(s) for this config variable. Without KEY |
10732 | displays all subcommands and config variables. | |
36263cb3 | 10733 | |
f20de9f0 | 10734 | Example: |
5f05dabc | 10735 | |
f20de9f0 | 10736 | o conf shell |
d8773709 | 10737 | |
f04ea8d1 SP |
10738 | If KEY starts and ends with a slash the string in between is |
10739 | interpreted as a regular expression and only keys matching this regex | |
10740 | are displayed | |
10741 | ||
10742 | Example: | |
10743 | ||
10744 | o conf /color/ | |
10745 | ||
f20de9f0 | 10746 | =item changing of scalar values: o conf KEY VALUE |
d8773709 | 10747 | |
f20de9f0 SP |
10748 | Sets the config variable KEY to VALUE. The empty string can be |
10749 | specified as usual in shells, with C<''> or C<""> | |
d8773709 | 10750 | |
f20de9f0 | 10751 | Example: |
d8773709 | 10752 | |
f20de9f0 | 10753 | o conf wget /usr/bin/wget |
d8773709 | 10754 | |
f20de9f0 | 10755 | =item changing of list values: o conf KEY SHIFT|UNSHIFT|PUSH|POP|SPLICE|LIST |
d8773709 | 10756 | |
f20de9f0 SP |
10757 | If a config variable name ends with C<list>, it is a list. C<o conf |
10758 | KEY shift> removes the first element of the list, C<o conf KEY pop> | |
10759 | removes the last element of the list. C<o conf KEYS unshift LIST> | |
10760 | prepends a list of values to the list, C<o conf KEYS push LIST> | |
10761 | appends a list of valued to the list. | |
d8773709 | 10762 | |
f20de9f0 SP |
10763 | Likewise, C<o conf KEY splice LIST> passes the LIST to the according |
10764 | splice command. | |
d8773709 | 10765 | |
f20de9f0 SP |
10766 | Finally, any other list of arguments is taken as a new list value for |
10767 | the KEY variable discarding the previous value. | |
d8773709 | 10768 | |
f20de9f0 | 10769 | Examples: |
d8773709 | 10770 | |
f20de9f0 SP |
10771 | o conf urllist unshift http://cpan.dev.local/CPAN |
10772 | o conf urllist splice 3 1 | |
10773 | o conf urllist http://cpan1.local http://cpan2.local ftp://ftp.perl.org | |
d8773709 | 10774 | |
f20de9f0 | 10775 | =item reverting to saved: o conf defaults |
d8773709 | 10776 | |
f20de9f0 | 10777 | Reverts all config variables to the state in the saved config file. |
d8773709 | 10778 | |
f20de9f0 | 10779 | =item saving the config: o conf commit |
d8773709 | 10780 | |
f20de9f0 SP |
10781 | Saves all config variables to the current config file (CPAN/Config.pm |
10782 | or CPAN/MyConfig.pm that was loaded at start). | |
d8773709 | 10783 | |
f20de9f0 | 10784 | =back |
d8773709 | 10785 | |
f20de9f0 SP |
10786 | The configuration dialog can be started any time later again by |
10787 | issuing the command C< o conf init > in the CPAN shell. A subset of | |
10788 | the configuration dialog can be run by issuing C<o conf init WORD> | |
10789 | where WORD is any valid config variable or a regular expression. | |
d8773709 | 10790 | |
f20de9f0 | 10791 | =head2 Config Variables |
d8773709 | 10792 | |
f20de9f0 SP |
10793 | Currently the following keys in the hash reference $CPAN::Config are |
10794 | defined: | |
d8773709 | 10795 | |
f20de9f0 SP |
10796 | applypatch path to external prg |
10797 | auto_commit commit all changes to config variables to disk | |
10798 | build_cache size of cache for directories to build modules | |
10799 | build_dir locally accessible directory to build modules | |
10800 | build_dir_reuse boolean if distros in build_dir are persistent | |
10801 | build_requires_install_policy | |
10802 | to install or not to install when a module is | |
10803 | only needed for building. yes|no|ask/yes|ask/no | |
10804 | bzip2 path to external prg | |
10805 | cache_metadata use serializer to cache metadata | |
10806 | commands_quote prefered character to use for quoting external | |
10807 | commands when running them. Defaults to double | |
10808 | quote on Windows, single tick everywhere else; | |
10809 | can be set to space to disable quoting | |
10810 | check_sigs if signatures should be verified | |
10811 | colorize_debug Term::ANSIColor attributes for debugging output | |
10812 | colorize_output boolean if Term::ANSIColor should colorize output | |
10813 | colorize_print Term::ANSIColor attributes for normal output | |
10814 | colorize_warn Term::ANSIColor attributes for warnings | |
10815 | commandnumber_in_prompt | |
10816 | boolean if you want to see current command number | |
10817 | cpan_home local directory reserved for this package | |
10818 | curl path to external prg | |
10819 | dontload_hash DEPRECATED | |
10820 | dontload_list arrayref: modules in the list will not be | |
10821 | loaded by the CPAN::has_inst() routine | |
10822 | ftp path to external prg | |
10823 | ftp_passive if set, the envariable FTP_PASSIVE is set for downloads | |
10824 | ftp_proxy proxy host for ftp requests | |
10825 | getcwd see below | |
10826 | gpg path to external prg | |
f04ea8d1 | 10827 | gzip location of external program gzip |
f20de9f0 SP |
10828 | histfile file to maintain history between sessions |
10829 | histsize maximum number of lines to keep in histfile | |
10830 | http_proxy proxy host for http requests | |
10831 | inactivity_timeout breaks interactive Makefile.PLs or Build.PLs | |
10832 | after this many seconds inactivity. Set to 0 to | |
10833 | never break. | |
10834 | index_expire after this many days refetch index files | |
10835 | inhibit_startup_message | |
10836 | if true, does not print the startup message | |
10837 | keep_source_where directory in which to keep the source (if we do) | |
f04ea8d1 SP |
10838 | load_module_verbosity |
10839 | report loading of optional modules used by CPAN.pm | |
f20de9f0 SP |
10840 | lynx path to external prg |
10841 | make location of external make program | |
f04ea8d1 | 10842 | make_arg arguments that should always be passed to 'make' |
f20de9f0 SP |
10843 | make_install_make_command |
10844 | the make command for running 'make install', for | |
10845 | example 'sudo make' | |
10846 | make_install_arg same as make_arg for 'make install' | |
f04ea8d1 SP |
10847 | makepl_arg arguments passed to 'perl Makefile.PL' |
10848 | mbuild_arg arguments passed to './Build' | |
f20de9f0 SP |
10849 | mbuild_install_arg arguments passed to './Build install' |
10850 | mbuild_install_build_command | |
10851 | command to use instead of './Build' when we are | |
10852 | in the install stage, for example 'sudo ./Build' | |
10853 | mbuildpl_arg arguments passed to 'perl Build.PL' | |
10854 | ncftp path to external prg | |
10855 | ncftpget path to external prg | |
10856 | no_proxy don't proxy to these hosts/domains (comma separated list) | |
10857 | pager location of external program more (or any pager) | |
10858 | password your password if you CPAN server wants one | |
10859 | patch path to external prg | |
10860 | prefer_installer legal values are MB and EUMM: if a module comes | |
10861 | with both a Makefile.PL and a Build.PL, use the | |
10862 | former (EUMM) or the latter (MB); if the module | |
10863 | comes with only one of the two, that one will be | |
10864 | used in any case | |
10865 | prerequisites_policy | |
10866 | what to do if you are missing module prerequisites | |
10867 | ('follow' automatically, 'ask' me, or 'ignore') | |
10868 | prefs_dir local directory to store per-distro build options | |
10869 | proxy_user username for accessing an authenticating proxy | |
10870 | proxy_pass password for accessing an authenticating proxy | |
10871 | randomize_urllist add some randomness to the sequence of the urllist | |
f04ea8d1 | 10872 | scan_cache controls scanning of cache ('atstart' or 'never') |
f20de9f0 | 10873 | shell your favorite shell |
f04ea8d1 SP |
10874 | show_unparsable_versions |
10875 | boolean if r command tells which modules are versionless | |
f20de9f0 | 10876 | show_upload_date boolean if commands should try to determine upload date |
f04ea8d1 | 10877 | show_zero_versions boolean if r command tells for which modules $version==0 |
f20de9f0 | 10878 | tar location of external program tar |
f04ea8d1 SP |
10879 | tar_verbosity verbosity level for the tar command |
10880 | term_is_latin deprecated: if true Unicode is translated to ISO-8859-1 | |
f20de9f0 SP |
10881 | (and nonsense for characters outside latin range) |
10882 | term_ornaments boolean to turn ReadLine ornamenting on/off | |
10883 | test_report email test reports (if CPAN::Reporter is installed) | |
10884 | unzip location of external program unzip | |
f04ea8d1 | 10885 | urllist arrayref to nearby CPAN sites (or equivalent locations) |
f20de9f0 SP |
10886 | use_sqlite use CPAN::SQLite for metadata storage (fast and lean) |
10887 | username your username if you CPAN server wants one | |
10888 | wait_list arrayref to a wait server to try (See CPAN::WAIT) | |
10889 | wget path to external prg | |
f04ea8d1 | 10890 | yaml_load_code enable YAML code deserialisation |
f20de9f0 | 10891 | yaml_module which module to use to read/write YAML files |
d8773709 | 10892 | |
f20de9f0 SP |
10893 | You can set and query each of these options interactively in the cpan |
10894 | shell with the C<o conf> or the C<o conf init> command as specified below. | |
d8773709 | 10895 | |
f20de9f0 | 10896 | =over 2 |
d8773709 | 10897 | |
f20de9f0 | 10898 | =item C<o conf E<lt>scalar optionE<gt>> |
d8773709 | 10899 | |
f20de9f0 | 10900 | prints the current value of the I<scalar option> |
d8773709 | 10901 | |
f20de9f0 | 10902 | =item C<o conf E<lt>scalar optionE<gt> E<lt>valueE<gt>> |
d8773709 | 10903 | |
f20de9f0 | 10904 | Sets the value of the I<scalar option> to I<value> |
d8773709 | 10905 | |
f20de9f0 | 10906 | =item C<o conf E<lt>list optionE<gt>> |
d8773709 | 10907 | |
f20de9f0 SP |
10908 | prints the current value of the I<list option> in MakeMaker's |
10909 | neatvalue format. | |
d8773709 | 10910 | |
f20de9f0 | 10911 | =item C<o conf E<lt>list optionE<gt> [shift|pop]> |
d8773709 | 10912 | |
f20de9f0 | 10913 | shifts or pops the array in the I<list option> variable |
d8773709 | 10914 | |
f20de9f0 | 10915 | =item C<o conf E<lt>list optionE<gt> [unshift|push|splice] E<lt>listE<gt>> |
d8773709 | 10916 | |
f20de9f0 | 10917 | works like the corresponding perl commands. |
d8773709 | 10918 | |
f20de9f0 | 10919 | =item interactive editing: o conf init [MATCH|LIST] |
d8773709 | 10920 | |
f20de9f0 SP |
10921 | Runs an interactive configuration dialog for matching variables. |
10922 | Without argument runs the dialog over all supported config variables. | |
10923 | To specify a MATCH the argument must be enclosed by slashes. | |
d8773709 | 10924 | |
f20de9f0 | 10925 | Examples: |
d8773709 | 10926 | |
f20de9f0 SP |
10927 | o conf init ftp_passive ftp_proxy |
10928 | o conf init /color/ | |
d8773709 | 10929 | |
f20de9f0 SP |
10930 | Note: this method of setting config variables often provides more |
10931 | explanation about the functioning of a variable than the manpage. | |
d8773709 | 10932 | |
f20de9f0 | 10933 | =back |
d8773709 | 10934 | |
f20de9f0 | 10935 | =head2 CPAN::anycwd($path): Note on config variable getcwd |
d8773709 | 10936 | |
f20de9f0 SP |
10937 | CPAN.pm changes the current working directory often and needs to |
10938 | determine its own current working directory. Per default it uses | |
10939 | Cwd::cwd but if this doesn't work on your system for some reason, | |
10940 | alternatives can be configured according to the following table: | |
d8773709 | 10941 | |
f20de9f0 | 10942 | =over 4 |
d8773709 | 10943 | |
f20de9f0 | 10944 | =item cwd |
d8773709 | 10945 | |
f20de9f0 | 10946 | Calls Cwd::cwd |
4d1321a7 | 10947 | |
f20de9f0 | 10948 | =item getcwd |
4d1321a7 | 10949 | |
f20de9f0 | 10950 | Calls Cwd::getcwd |
d8773709 | 10951 | |
f20de9f0 | 10952 | =item fastcwd |
d8773709 | 10953 | |
f20de9f0 | 10954 | Calls Cwd::fastcwd |
d8773709 | 10955 | |
f20de9f0 | 10956 | =item backtickcwd |
d8773709 | 10957 | |
f20de9f0 | 10958 | Calls the external command cwd. |
d8773709 | 10959 | |
f20de9f0 | 10960 | =back |
d8773709 | 10961 | |
f20de9f0 | 10962 | =head2 Note on the format of the urllist parameter |
d8773709 | 10963 | |
f20de9f0 SP |
10964 | urllist parameters are URLs according to RFC 1738. We do a little |
10965 | guessing if your URL is not compliant, but if you have problems with | |
10966 | C<file> URLs, please try the correct format. Either: | |
d8773709 | 10967 | |
f20de9f0 | 10968 | file://localhost/whatever/ftp/pub/CPAN/ |
d8773709 | 10969 | |
f20de9f0 | 10970 | or |
d8773709 | 10971 | |
f20de9f0 | 10972 | file:///home/ftp/pub/CPAN/ |
d8773709 | 10973 | |
f20de9f0 | 10974 | =head2 The urllist parameter has CD-ROM support |
d8773709 | 10975 | |
f20de9f0 SP |
10976 | The C<urllist> parameter of the configuration table contains a list of |
10977 | URLs that are to be used for downloading. If the list contains any | |
10978 | C<file> URLs, CPAN always tries to get files from there first. This | |
10979 | feature is disabled for index files. So the recommendation for the | |
10980 | owner of a CD-ROM with CPAN contents is: include your local, possibly | |
10981 | outdated CD-ROM as a C<file> URL at the end of urllist, e.g. | |
d8773709 | 10982 | |
f20de9f0 | 10983 | o conf urllist push file://localhost/CDROM/CPAN |
d8773709 | 10984 | |
f20de9f0 SP |
10985 | CPAN.pm will then fetch the index files from one of the CPAN sites |
10986 | that come at the beginning of urllist. It will later check for each | |
10987 | module if there is a local copy of the most recent version. | |
d8773709 | 10988 | |
f20de9f0 SP |
10989 | Another peculiarity of urllist is that the site that we could |
10990 | successfully fetch the last file from automatically gets a preference | |
10991 | token and is tried as the first site for the next request. So if you | |
10992 | add a new site at runtime it may happen that the previously preferred | |
10993 | site will be tried another time. This means that if you want to disallow | |
10994 | a site for the next transfer, it must be explicitly removed from | |
10995 | urllist. | |
d8773709 | 10996 | |
f20de9f0 | 10997 | =head2 Maintaining the urllist parameter |
1e8f9a0a | 10998 | |
f20de9f0 SP |
10999 | If you have YAML.pm (or some other YAML module configured in |
11000 | C<yaml_module>) installed, CPAN.pm collects a few statistical data | |
11001 | about recent downloads. You can view the statistics with the C<hosts> | |
11002 | command or inspect them directly by looking into the C<FTPstats.yml> | |
11003 | file in your C<cpan_home> directory. | |
8962fc49 | 11004 | |
f20de9f0 SP |
11005 | To get some interesting statistics it is recommended to set the |
11006 | C<randomize_urllist> parameter that introduces some amount of | |
11007 | randomness into the URL selection. | |
d8773709 | 11008 | |
f20de9f0 | 11009 | =head2 The C<requires> and C<build_requires> dependency declarations |
d8773709 | 11010 | |
f20de9f0 SP |
11011 | Since CPAN.pm version 1.88_51 modules declared as C<build_requires> by |
11012 | a distribution are treated differently depending on the config | |
11013 | variable C<build_requires_install_policy>. By setting | |
11014 | C<build_requires_install_policy> to C<no> such a module is not being | |
11015 | installed. It is only built and tested and then kept in the list of | |
11016 | tested but uninstalled modules. As such it is available during the | |
11017 | build of the dependent module by integrating the path to the | |
11018 | C<blib/arch> and C<blib/lib> directories in the environment variable | |
11019 | PERL5LIB. If C<build_requires_install_policy> is set ti C<yes>, then | |
11020 | both modules declared as C<requires> and those declared as | |
11021 | C<build_requires> are treated alike. By setting to C<ask/yes> or | |
11022 | C<ask/no>, CPAN.pm asks the user and sets the default accordingly. | |
d8773709 | 11023 | |
f20de9f0 | 11024 | =head2 Configuration for individual distributions (I<Distroprefs>) |
d8773709 | 11025 | |
f20de9f0 SP |
11026 | (B<Note:> This feature has been introduced in CPAN.pm 1.8854 and is |
11027 | still considered beta quality) | |
d8773709 | 11028 | |
f20de9f0 SP |
11029 | Distributions on the CPAN usually behave according to what we call the |
11030 | CPAN mantra. Or since the event of Module::Build we should talk about | |
11031 | two mantras: | |
d8773709 | 11032 | |
f20de9f0 SP |
11033 | perl Makefile.PL perl Build.PL |
11034 | make ./Build | |
11035 | make test ./Build test | |
11036 | make install ./Build install | |
4d1321a7 | 11037 | |
f20de9f0 SP |
11038 | But some modules cannot be built with this mantra. They try to get |
11039 | some extra data from the user via the environment, extra arguments or | |
11040 | interactively thus disturbing the installation of large bundles like | |
11041 | Phalanx100 or modules with many dependencies like Plagger. | |
4d1321a7 | 11042 | |
f20de9f0 SP |
11043 | The distroprefs system of C<CPAN.pm> addresses this problem by |
11044 | allowing the user to specify extra informations and recipes in YAML | |
11045 | files to either | |
1e8f9a0a | 11046 | |
f20de9f0 | 11047 | =over |
d8773709 | 11048 | |
f20de9f0 | 11049 | =item |
d8773709 | 11050 | |
f20de9f0 | 11051 | pass additional arguments to one of the four commands, |
d8773709 | 11052 | |
f20de9f0 | 11053 | =item |
554a9ef5 | 11054 | |
f20de9f0 | 11055 | set environment variables |
554a9ef5 | 11056 | |
f20de9f0 | 11057 | =item |
d8773709 | 11058 | |
f20de9f0 SP |
11059 | instantiate an Expect object that reads from the console, waits for |
11060 | some regular expressions and enters some answers | |
d8773709 | 11061 | |
f20de9f0 | 11062 | =item |
d8773709 | 11063 | |
f20de9f0 | 11064 | temporarily override assorted C<CPAN.pm> configuration variables |
d8773709 | 11065 | |
f20de9f0 | 11066 | =item |
d8773709 | 11067 | |
f04ea8d1 SP |
11068 | specify dependencies that the original maintainer forgot to specify |
11069 | ||
11070 | =item | |
11071 | ||
f20de9f0 | 11072 | disable the installation of an object altogether |
d8773709 | 11073 | |
f20de9f0 | 11074 | =back |
d8773709 | 11075 | |
f20de9f0 SP |
11076 | See the YAML and Data::Dumper files that come with the C<CPAN.pm> |
11077 | distribution in the C<distroprefs/> directory for examples. | |
d8773709 | 11078 | |
f20de9f0 | 11079 | =head2 Filenames |
d8773709 | 11080 | |
f20de9f0 SP |
11081 | The YAML files themselves must have the C<.yml> extension, all other |
11082 | files are ignored (for two exceptions see I<Fallback Data::Dumper and | |
11083 | Storable> below). The containing directory can be specified in | |
11084 | C<CPAN.pm> in the C<prefs_dir> config variable. Try C<o conf init | |
11085 | prefs_dir> in the CPAN shell to set and activate the distroprefs | |
11086 | system. | |
d8773709 | 11087 | |
f20de9f0 SP |
11088 | Every YAML file may contain arbitrary documents according to the YAML |
11089 | specification and every single document is treated as an entity that | |
11090 | can specify the treatment of a single distribution. | |
d8773709 | 11091 | |
f20de9f0 SP |
11092 | The names of the files can be picked freely, C<CPAN.pm> always reads |
11093 | all files (in alphabetical order) and takes the key C<match> (see | |
11094 | below in I<Language Specs>) as a hashref containing match criteria | |
11095 | that determine if the current distribution matches the YAML document | |
11096 | or not. | |
d8773709 | 11097 | |
f20de9f0 | 11098 | =head2 Fallback Data::Dumper and Storable |
d8773709 | 11099 | |
f20de9f0 SP |
11100 | If neither your configured C<yaml_module> nor YAML.pm is installed |
11101 | CPAN.pm falls back to using Data::Dumper and Storable and looks for | |
11102 | files with the extensions C<.dd> or C<.st> in the C<prefs_dir> | |
11103 | directory. These files are expected to contain one or more hashrefs. | |
11104 | For Data::Dumper generated files, this is expected to be done with by | |
11105 | defining C<$VAR1>, C<$VAR2>, etc. The YAML shell would produce these | |
11106 | with the command | |
d8773709 | 11107 | |
f20de9f0 | 11108 | ysh < somefile.yml > somefile.dd |
d8773709 | 11109 | |
f20de9f0 SP |
11110 | For Storable files the rule is that they must be constructed such that |
11111 | C<Storable::retrieve(file)> returns an array reference and the array | |
11112 | elements represent one distropref object each. The conversion from | |
11113 | YAML would look like so: | |
d8773709 | 11114 | |
f20de9f0 SP |
11115 | perl -MYAML=LoadFile -MStorable=nstore -e ' |
11116 | @y=LoadFile(shift); | |
11117 | nstore(\@y, shift)' somefile.yml somefile.st | |
d8773709 | 11118 | |
f20de9f0 SP |
11119 | In bootstrapping situations it is usually sufficient to translate only |
11120 | a few YAML files to Data::Dumper for the crucial modules like | |
11121 | C<YAML::Syck>, C<YAML.pm> and C<Expect.pm>. If you prefer Storable | |
11122 | over Data::Dumper, remember to pull out a Storable version that writes | |
11123 | an older format than all the other Storable versions that will need to | |
11124 | read them. | |
d8773709 | 11125 | |
f20de9f0 | 11126 | =head2 Blueprint |
d8773709 | 11127 | |
f20de9f0 SP |
11128 | The following example contains all supported keywords and structures |
11129 | with the exception of C<eexpect> which can be used instead of | |
11130 | C<expect>. | |
d8773709 | 11131 | |
f20de9f0 SP |
11132 | --- |
11133 | comment: "Demo" | |
11134 | match: | |
11135 | module: "Dancing::Queen" | |
11136 | distribution: "^CHACHACHA/Dancing-" | |
11137 | perl: "/usr/local/cariba-perl/bin/perl" | |
2b3bde2a SP |
11138 | perlconfig: |
11139 | archname: "freebsd" | |
f20de9f0 SP |
11140 | disabled: 1 |
11141 | cpanconfig: | |
11142 | make: gmake | |
11143 | pl: | |
11144 | args: | |
11145 | - "--somearg=specialcase" | |
d8773709 | 11146 | |
f20de9f0 | 11147 | env: {} |
d8773709 | 11148 | |
f20de9f0 SP |
11149 | expect: |
11150 | - "Which is your favorite fruit" | |
11151 | - "apple\n" | |
d8773709 | 11152 | |
f20de9f0 SP |
11153 | make: |
11154 | args: | |
11155 | - all | |
11156 | - extra-all | |
d8773709 | 11157 | |
f20de9f0 | 11158 | env: {} |
4d1321a7 | 11159 | |
f20de9f0 | 11160 | expect: [] |
4d1321a7 | 11161 | |
f20de9f0 | 11162 | commendline: "echo SKIPPING make" |
87892b73 | 11163 | |
f20de9f0 SP |
11164 | test: |
11165 | args: [] | |
87892b73 | 11166 | |
f20de9f0 | 11167 | env: {} |
87892b73 | 11168 | |
f20de9f0 | 11169 | expect: [] |
87892b73 | 11170 | |
f20de9f0 SP |
11171 | install: |
11172 | args: [] | |
87892b73 | 11173 | |
f20de9f0 SP |
11174 | env: |
11175 | WANT_TO_INSTALL: YES | |
87892b73 | 11176 | |
f20de9f0 SP |
11177 | expect: |
11178 | - "Do you really want to install" | |
11179 | - "y\n" | |
87892b73 | 11180 | |
f20de9f0 SP |
11181 | patches: |
11182 | - "ABCDE/Fedcba-3.14-ABCDE-01.patch" | |
87892b73 | 11183 | |
f04ea8d1 SP |
11184 | depends: |
11185 | configure_requires: | |
11186 | LWP: 5.8 | |
11187 | build_requires: | |
11188 | Test::Exception: 0.25 | |
11189 | requires: | |
11190 | Spiffy: 0.30 | |
11191 | ||
d8773709 | 11192 | |
f20de9f0 | 11193 | =head2 Language Specs |
d8773709 | 11194 | |
f20de9f0 SP |
11195 | Every YAML document represents a single hash reference. The valid keys |
11196 | in this hash are as follows: | |
d8773709 | 11197 | |
f20de9f0 | 11198 | =over |
d8773709 | 11199 | |
f20de9f0 | 11200 | =item comment [scalar] |
d8773709 | 11201 | |
f20de9f0 | 11202 | A comment |
d8773709 | 11203 | |
f20de9f0 | 11204 | =item cpanconfig [hash] |
810a0276 | 11205 | |
f20de9f0 | 11206 | Temporarily override assorted C<CPAN.pm> configuration variables. |
810a0276 | 11207 | |
f20de9f0 SP |
11208 | Supported are: C<build_requires_install_policy>, C<check_sigs>, |
11209 | C<make>, C<make_install_make_command>, C<prefer_installer>, | |
11210 | C<test_report>. Please report as a bug when you need another one | |
11211 | supported. | |
d8773709 | 11212 | |
f04ea8d1 SP |
11213 | =item depends [hash] *** EXPERIMENTAL FEATURE *** |
11214 | ||
11215 | All three types, namely C<configure_requires>, C<build_requires>, and | |
11216 | C<requires> are supported in the way specified in the META.yml | |
11217 | specification. The current implementation I<merges> the specified | |
11218 | dependencies with those declared by the package maintainer. In a | |
11219 | future implementation this may be changed to override the original | |
11220 | declaration. | |
11221 | ||
f20de9f0 | 11222 | =item disabled [boolean] |
810a0276 | 11223 | |
f20de9f0 | 11224 | Specifies that this distribution shall not be processed at all. |
810a0276 | 11225 | |
f20de9f0 | 11226 | =item goto [string] |
d8773709 | 11227 | |
f20de9f0 SP |
11228 | The canonical name of a delegate distribution that shall be installed |
11229 | instead. Useful when a new version, although it tests OK itself, | |
11230 | breaks something else or a developer release or a fork is already | |
11231 | uploaded that is better than the last released version. | |
d8773709 | 11232 | |
f20de9f0 | 11233 | =item install [hash] |
d8773709 | 11234 | |
f20de9f0 SP |
11235 | Processing instructions for the C<make install> or C<./Build install> |
11236 | phase of the CPAN mantra. See below under I<Processiong Instructions>. | |
d8773709 | 11237 | |
f20de9f0 | 11238 | =item make [hash] |
d8773709 | 11239 | |
f20de9f0 SP |
11240 | Processing instructions for the C<make> or C<./Build> phase of the |
11241 | CPAN mantra. See below under I<Processiong Instructions>. | |
d8773709 | 11242 | |
f20de9f0 | 11243 | =item match [hash] |
d8773709 | 11244 | |
2b3bde2a SP |
11245 | A hashref with one or more of the keys C<distribution>, C<modules>, |
11246 | C<perl>, and C<perlconfig> that specify if a document is targeted at a | |
11247 | specific CPAN distribution or installation. | |
d8773709 | 11248 | |
f20de9f0 SP |
11249 | The corresponding values are interpreted as regular expressions. The |
11250 | C<distribution> related one will be matched against the canonical | |
11251 | distribution name, e.g. "AUTHOR/Foo-Bar-3.14.tar.gz". | |
d8773709 | 11252 | |
f20de9f0 SP |
11253 | The C<module> related one will be matched against I<all> modules |
11254 | contained in the distribution until one module matches. | |
554a9ef5 | 11255 | |
b03f445c RGS |
11256 | The C<perl> related one will be matched against C<$^X> (but with the |
11257 | absolute path). | |
554a9ef5 | 11258 | |
2b3bde2a SP |
11259 | The value associated with C<perlconfig> is itself a hashref that is |
11260 | matched against corresponding values in the C<%Config::Config> hash | |
11261 | living in the C< Config.pm > module. | |
11262 | ||
f20de9f0 SP |
11263 | If more than one restriction of C<module>, C<distribution>, and |
11264 | C<perl> is specified, the results of the separately computed match | |
11265 | values must all match. If this is the case then the hashref | |
11266 | represented by the YAML document is returned as the preference | |
11267 | structure for the current distribution. | |
4d1321a7 | 11268 | |
f20de9f0 | 11269 | =item patches [array] |
4d1321a7 | 11270 | |
f20de9f0 SP |
11271 | An array of patches on CPAN or on the local disk to be applied in |
11272 | order via the external patch program. If the value for the C<-p> | |
11273 | parameter is C<0> or C<1> is determined by reading the patch | |
11274 | beforehand. | |
d8773709 | 11275 | |
f20de9f0 SP |
11276 | Note: if the C<applypatch> program is installed and C<CPAN::Config> |
11277 | knows about it B<and> a patch is written by the C<makepatch> program, | |
11278 | then C<CPAN.pm> lets C<applypatch> apply the patch. Both C<makepatch> | |
11279 | and C<applypatch> are available from CPAN in the C<JV/makepatch-*> | |
11280 | distribution. | |
d8773709 | 11281 | |
f20de9f0 | 11282 | =item pl [hash] |
d8773709 | 11283 | |
f20de9f0 SP |
11284 | Processing instructions for the C<perl Makefile.PL> or C<perl |
11285 | Build.PL> phase of the CPAN mantra. See below under I<Processiong | |
11286 | Instructions>. | |
d8773709 | 11287 | |
f20de9f0 | 11288 | =item test [hash] |
d8773709 | 11289 | |
f20de9f0 SP |
11290 | Processing instructions for the C<make test> or C<./Build test> phase |
11291 | of the CPAN mantra. See below under I<Processiong Instructions>. | |
d8773709 | 11292 | |
d8773709 | 11293 | =back |
55e314ee | 11294 | |
f20de9f0 | 11295 | =head2 Processing Instructions |
5f05dabc | 11296 | |
f20de9f0 | 11297 | =over |
5f05dabc | 11298 | |
f20de9f0 | 11299 | =item args [array] |
5f05dabc | 11300 | |
f20de9f0 | 11301 | Arguments to be added to the command line |
5f05dabc | 11302 | |
f20de9f0 | 11303 | =item commandline |
5f05dabc | 11304 | |
f20de9f0 SP |
11305 | A full commandline that will be executed as it stands by a system |
11306 | call. During the execution the environment variable PERL will is set | |
b03f445c RGS |
11307 | to $^X (but with an absolute path). If C<commandline> is specified, |
11308 | the content of C<args> is not used. | |
5f05dabc | 11309 | |
f20de9f0 | 11310 | =item eexpect [hash] |
5f05dabc | 11311 | |
f04ea8d1 SP |
11312 | Extended C<expect>. This is a hash reference with four allowed keys, |
11313 | C<mode>, C<timeout>, C<reuse>, and C<talk>. | |
5f05dabc | 11314 | |
f20de9f0 SP |
11315 | C<mode> may have the values C<deterministic> for the case where all |
11316 | questions come in the order written down and C<anyorder> for the case | |
11317 | where the questions may come in any order. The default mode is | |
11318 | C<deterministic>. | |
5f05dabc | 11319 | |
f20de9f0 SP |
11320 | C<timeout> denotes a timeout in seconds. Floating point timeouts are |
11321 | OK. In the case of a C<mode=deterministic> the timeout denotes the | |
11322 | timeout per question, in the case of C<mode=anyorder> it denotes the | |
11323 | timeout per byte received from the stream or questions. | |
5f05dabc | 11324 | |
f20de9f0 SP |
11325 | C<talk> is a reference to an array that contains alternating questions |
11326 | and answers. Questions are regular expressions and answers are literal | |
11327 | strings. The Expect module will then watch the stream coming from the | |
11328 | execution of the external program (C<perl Makefile.PL>, C<perl | |
11329 | Build.PL>, C<make>, etc.). | |
5f05dabc | 11330 | |
f20de9f0 SP |
11331 | In the case of C<mode=deterministic> the CPAN.pm will inject the |
11332 | according answer as soon as the stream matches the regular expression. | |
f04ea8d1 SP |
11333 | |
11334 | In the case of C<mode=anyorder> CPAN.pm will answer a question as soon | |
11335 | as the timeout is reached for the next byte in the input stream. In | |
11336 | this mode you can use the C<reuse> parameter to decide what shall | |
11337 | happen with a question-answer pair after it has been used. In the | |
11338 | default case (reuse=0) it is removed from the array, so it cannot be | |
11339 | used again accidentally. In this case, if you want to answer the | |
11340 | question C<Do you really want to do that> several times, then it must | |
11341 | be included in the array at least as often as you want this answer to | |
11342 | be given. Setting the parameter C<reuse> to 1 makes this repetition | |
11343 | unnecessary. | |
5f05dabc | 11344 | |
f20de9f0 | 11345 | =item env [hash] |
5f05dabc | 11346 | |
f20de9f0 | 11347 | Environment variables to be set during the command |
2ccf00a7 | 11348 | |
f20de9f0 | 11349 | =item expect [array] |
09d9d230 | 11350 | |
f20de9f0 | 11351 | C<< expect: <array> >> is a short notation for |
5f05dabc | 11352 | |
f20de9f0 SP |
11353 | eexpect: |
11354 | mode: deterministic | |
11355 | timeout: 15 | |
11356 | talk: <array> | |
da199366 | 11357 | |
f20de9f0 | 11358 | =back |
da199366 | 11359 | |
f20de9f0 | 11360 | =head2 Schema verification with C<Kwalify> |
da199366 | 11361 | |
f20de9f0 SP |
11362 | If you have the C<Kwalify> module installed (which is part of the |
11363 | Bundle::CPANxxl), then all your distroprefs files are checked for | |
11364 | syntactical correctness. | |
da199366 | 11365 | |
f20de9f0 | 11366 | =head2 Example Distroprefs Files |
da199366 | 11367 | |
f20de9f0 SP |
11368 | C<CPAN.pm> comes with a collection of example YAML files. Note that these |
11369 | are really just examples and should not be used without care because | |
11370 | they cannot fit everybody's purpose. After all the authors of the | |
11371 | packages that ask questions had a need to ask, so you should watch | |
11372 | their questions and adjust the examples to your environment and your | |
11373 | needs. You have beend warned:-) | |
da199366 | 11374 | |
f20de9f0 | 11375 | =head1 PROGRAMMER'S INTERFACE |
da199366 | 11376 | |
f20de9f0 SP |
11377 | If you do not enter the shell, the available shell commands are both |
11378 | available as methods (C<CPAN::Shell-E<gt>install(...)>) and as | |
11379 | functions in the calling package (C<install(...)>). Before calling low-level | |
11380 | commands it makes sense to initialize components of CPAN you need, e.g.: | |
da199366 | 11381 | |
f20de9f0 SP |
11382 | CPAN::HandleConfig->load; |
11383 | CPAN::Shell::setup_output; | |
11384 | CPAN::Index->reload; | |
da199366 | 11385 | |
f20de9f0 | 11386 | High-level commands do such initializations automatically. |
da199366 | 11387 | |
f20de9f0 SP |
11388 | There's currently only one class that has a stable interface - |
11389 | CPAN::Shell. All commands that are available in the CPAN shell are | |
11390 | methods of the class CPAN::Shell. Each of the commands that produce | |
11391 | listings of modules (C<r>, C<autobundle>, C<u>) also return a list of | |
11392 | the IDs of all modules within the list. | |
7d97ad34 SP |
11393 | |
11394 | =over 2 | |
11395 | ||
f20de9f0 | 11396 | =item expand($type,@things) |
7d97ad34 | 11397 | |
f20de9f0 SP |
11398 | The IDs of all objects available within a program are strings that can |
11399 | be expanded to the corresponding real objects with the | |
11400 | C<CPAN::Shell-E<gt>expand("Module",@things)> method. Expand returns a | |
11401 | list of CPAN::Module objects according to the C<@things> arguments | |
11402 | given. In scalar context it only returns the first element of the | |
11403 | list. | |
7d97ad34 | 11404 | |
f20de9f0 | 11405 | =item expandany(@things) |
7d97ad34 | 11406 | |
f20de9f0 SP |
11407 | Like expand, but returns objects of the appropriate type, i.e. |
11408 | CPAN::Bundle objects for bundles, CPAN::Module objects for modules and | |
11409 | CPAN::Distribution objects for distributions. Note: it does not expand | |
11410 | to CPAN::Author objects. | |
7d97ad34 | 11411 | |
f20de9f0 SP |
11412 | =item Programming Examples |
11413 | ||
11414 | This enables the programmer to do operations that combine | |
11415 | functionalities that are available in the shell. | |
11416 | ||
11417 | # install everything that is outdated on my disk: | |
11418 | perl -MCPAN -e 'CPAN::Shell->install(CPAN::Shell->r)' | |
11419 | ||
11420 | # install my favorite programs if necessary: | |
f04ea8d1 | 11421 | for $mod (qw(Net::FTP Digest::SHA Data::Dumper)) { |
f20de9f0 SP |
11422 | CPAN::Shell->install($mod); |
11423 | } | |
11424 | ||
11425 | # list all modules on my disk that have no VERSION number | |
f04ea8d1 SP |
11426 | for $mod (CPAN::Shell->expand("Module","/./")) { |
11427 | next unless $mod->inst_file; | |
f20de9f0 | 11428 | # MakeMaker convention for undefined $VERSION: |
f04ea8d1 SP |
11429 | next unless $mod->inst_version eq "undef"; |
11430 | print "No VERSION in ", $mod->id, "\n"; | |
f20de9f0 SP |
11431 | } |
11432 | ||
11433 | # find out which distribution on CPAN contains a module: | |
11434 | print CPAN::Shell->expand("Module","Apache::Constants")->cpan_file | |
11435 | ||
11436 | Or if you want to write a cronjob to watch The CPAN, you could list | |
11437 | all modules that need updating. First a quick and dirty way: | |
11438 | ||
11439 | perl -e 'use CPAN; CPAN::Shell->r;' | |
11440 | ||
11441 | If you don't want to get any output in the case that all modules are | |
11442 | up to date, you can parse the output of above command for the regular | |
11443 | expression //modules are up to date// and decide to mail the output | |
11444 | only if it doesn't match. Ick? | |
11445 | ||
11446 | If you prefer to do it more in a programmer style in one single | |
11447 | process, maybe something like this suits you better: | |
11448 | ||
11449 | # list all modules on my disk that have newer versions on CPAN | |
f04ea8d1 | 11450 | for $mod (CPAN::Shell->expand("Module","/./")) { |
f20de9f0 SP |
11451 | next unless $mod->inst_file; |
11452 | next if $mod->uptodate; | |
11453 | printf "Module %s is installed as %s, could be updated to %s from CPAN\n", | |
11454 | $mod->id, $mod->inst_version, $mod->cpan_version; | |
11455 | } | |
11456 | ||
11457 | If that gives you too much output every day, you maybe only want to | |
11458 | watch for three modules. You can write | |
11459 | ||
f04ea8d1 | 11460 | for $mod (CPAN::Shell->expand("Module","/Apache|LWP|CGI/")) { |
f20de9f0 SP |
11461 | |
11462 | as the first line instead. Or you can combine some of the above | |
11463 | tricks: | |
11464 | ||
11465 | # watch only for a new mod_perl module | |
11466 | $mod = CPAN::Shell->expand("Module","mod_perl"); | |
11467 | exit if $mod->uptodate; | |
11468 | # new mod_perl arrived, let me know all update recommendations | |
11469 | CPAN::Shell->r; | |
7d97ad34 SP |
11470 | |
11471 | =back | |
11472 | ||
f20de9f0 | 11473 | =head2 Methods in the other Classes |
7d97ad34 | 11474 | |
f20de9f0 | 11475 | =over 4 |
7d97ad34 | 11476 | |
f20de9f0 | 11477 | =item CPAN::Author::as_glimpse() |
6d29edf5 | 11478 | |
f20de9f0 | 11479 | Returns a one-line description of the author |
da199366 | 11480 | |
f20de9f0 | 11481 | =item CPAN::Author::as_string() |
da199366 | 11482 | |
f20de9f0 | 11483 | Returns a multi-line description of the author |
10b2abe6 | 11484 | |
f20de9f0 | 11485 | =item CPAN::Author::email() |
2ccf00a7 | 11486 | |
f20de9f0 | 11487 | Returns the author's email address |
2ccf00a7 | 11488 | |
f20de9f0 | 11489 | =item CPAN::Author::fullname() |
2ccf00a7 | 11490 | |
f20de9f0 | 11491 | Returns the author's name |
2ccf00a7 | 11492 | |
f20de9f0 | 11493 | =item CPAN::Author::name() |
2ccf00a7 | 11494 | |
f20de9f0 | 11495 | An alias for fullname |
2ccf00a7 | 11496 | |
f20de9f0 | 11497 | =item CPAN::Bundle::as_glimpse() |
b72dd56f | 11498 | |
f20de9f0 | 11499 | Returns a one-line description of the bundle |
b72dd56f | 11500 | |
f20de9f0 | 11501 | =item CPAN::Bundle::as_string() |
2ccf00a7 | 11502 | |
f20de9f0 | 11503 | Returns a multi-line description of the bundle |
2ccf00a7 | 11504 | |
f20de9f0 | 11505 | =item CPAN::Bundle::clean() |
2ccf00a7 | 11506 | |
f20de9f0 | 11507 | Recursively runs the C<clean> method on all items contained in the bundle. |
5f05dabc | 11508 | |
f20de9f0 | 11509 | =item CPAN::Bundle::contains() |
35576f8c | 11510 | |
f20de9f0 SP |
11511 | Returns a list of objects' IDs contained in a bundle. The associated |
11512 | objects may be bundles, modules or distributions. | |
05bab18e | 11513 | |
f20de9f0 | 11514 | =item CPAN::Bundle::force($method,@args) |
05bab18e | 11515 | |
f20de9f0 SP |
11516 | Forces CPAN to perform a task that it normally would have refused to |
11517 | do. Force takes as arguments a method name to be called and any number | |
11518 | of additional arguments that should be passed to the called method. | |
11519 | The internals of the object get the needed changes so that CPAN.pm | |
11520 | does not refuse to take the action. The C<force> is passed recursively | |
11521 | to all contained objects. See also the section above on the C<force> | |
11522 | and the C<fforce> pragma. | |
05bab18e | 11523 | |
f20de9f0 | 11524 | =item CPAN::Bundle::get() |
05bab18e | 11525 | |
f20de9f0 | 11526 | Recursively runs the C<get> method on all items contained in the bundle |
05bab18e | 11527 | |
f20de9f0 | 11528 | =item CPAN::Bundle::inst_file() |
05bab18e | 11529 | |
f20de9f0 SP |
11530 | Returns the highest installed version of the bundle in either @INC or |
11531 | C<$CPAN::Config->{cpan_home}>. Note that this is different from | |
11532 | CPAN::Module::inst_file. | |
05bab18e | 11533 | |
f20de9f0 | 11534 | =item CPAN::Bundle::inst_version() |
05bab18e | 11535 | |
f20de9f0 | 11536 | Like CPAN::Bundle::inst_file, but returns the $VERSION |
05bab18e | 11537 | |
f20de9f0 | 11538 | =item CPAN::Bundle::uptodate() |
05bab18e | 11539 | |
f20de9f0 | 11540 | Returns 1 if the bundle itself and all its members are uptodate. |
05bab18e | 11541 | |
f20de9f0 | 11542 | =item CPAN::Bundle::install() |
05bab18e | 11543 | |
f20de9f0 | 11544 | Recursively runs the C<install> method on all items contained in the bundle |
05bab18e | 11545 | |
f20de9f0 | 11546 | =item CPAN::Bundle::make() |
05bab18e | 11547 | |
f20de9f0 | 11548 | Recursively runs the C<make> method on all items contained in the bundle |
05bab18e | 11549 | |
f20de9f0 | 11550 | =item CPAN::Bundle::readme() |
05bab18e | 11551 | |
f20de9f0 | 11552 | Recursively runs the C<readme> method on all items contained in the bundle |
05bab18e | 11553 | |
f20de9f0 | 11554 | =item CPAN::Bundle::test() |
05bab18e | 11555 | |
f20de9f0 | 11556 | Recursively runs the C<test> method on all items contained in the bundle |
05bab18e | 11557 | |
f20de9f0 | 11558 | =item CPAN::Distribution::as_glimpse() |
05bab18e | 11559 | |
f20de9f0 | 11560 | Returns a one-line description of the distribution |
05bab18e | 11561 | |
f20de9f0 | 11562 | =item CPAN::Distribution::as_string() |
05bab18e | 11563 | |
f20de9f0 | 11564 | Returns a multi-line description of the distribution |
05bab18e | 11565 | |
f20de9f0 | 11566 | =item CPAN::Distribution::author |
05bab18e | 11567 | |
f20de9f0 SP |
11568 | Returns the CPAN::Author object of the maintainer who uploaded this |
11569 | distribution | |
05bab18e | 11570 | |
f04ea8d1 SP |
11571 | =item CPAN::Distribution::pretty_id() |
11572 | ||
11573 | Returns a string of the form "AUTHORID/TARBALL", where AUTHORID is the | |
11574 | author's PAUSE ID and TARBALL is the distribution filename. | |
11575 | ||
11576 | =item CPAN::Distribution::base_id() | |
11577 | ||
11578 | Returns the distribution filename without any archive suffix. E.g | |
11579 | "Foo-Bar-0.01" | |
11580 | ||
f20de9f0 | 11581 | =item CPAN::Distribution::clean() |
05bab18e | 11582 | |
f20de9f0 SP |
11583 | Changes to the directory where the distribution has been unpacked and |
11584 | runs C<make clean> there. | |
05bab18e | 11585 | |
f20de9f0 | 11586 | =item CPAN::Distribution::containsmods() |
05bab18e | 11587 | |
f20de9f0 SP |
11588 | Returns a list of IDs of modules contained in a distribution file. |
11589 | Only works for distributions listed in the 02packages.details.txt.gz | |
11590 | file. This typically means that only the most recent version of a | |
11591 | distribution is covered. | |
05bab18e | 11592 | |
f20de9f0 | 11593 | =item CPAN::Distribution::cvs_import() |
35576f8c | 11594 | |
f20de9f0 SP |
11595 | Changes to the directory where the distribution has been unpacked and |
11596 | runs something like | |
5f05dabc | 11597 | |
f20de9f0 | 11598 | cvs -d $cvs_root import -m $cvs_log $cvs_dir $userid v$version |
05bab18e | 11599 | |
f20de9f0 | 11600 | there. |
5f05dabc | 11601 | |
f20de9f0 SP |
11602 | =item CPAN::Distribution::dir() |
11603 | ||
11604 | Returns the directory into which this distribution has been unpacked. | |
11605 | ||
11606 | =item CPAN::Distribution::force($method,@args) | |
11607 | ||
11608 | Forces CPAN to perform a task that it normally would have refused to | |
11609 | do. Force takes as arguments a method name to be called and any number | |
11610 | of additional arguments that should be passed to the called method. | |
11611 | The internals of the object get the needed changes so that CPAN.pm | |
11612 | does not refuse to take the action. See also the section above on the | |
11613 | C<force> and the C<fforce> pragma. | |
11614 | ||
11615 | =item CPAN::Distribution::get() | |
11616 | ||
11617 | Downloads the distribution from CPAN and unpacks it. Does nothing if | |
11618 | the distribution has already been downloaded and unpacked within the | |
11619 | current session. | |
11620 | ||
11621 | =item CPAN::Distribution::install() | |
11622 | ||
11623 | Changes to the directory where the distribution has been unpacked and | |
11624 | runs the external command C<make install> there. If C<make> has not | |
11625 | yet been run, it will be run first. A C<make test> will be issued in | |
11626 | any case and if this fails, the install will be canceled. The | |
11627 | cancellation can be avoided by letting C<force> run the C<install> for | |
11628 | you. | |
11629 | ||
11630 | This install method has only the power to install the distribution if | |
11631 | there are no dependencies in the way. To install an object and all of | |
11632 | its dependencies, use CPAN::Shell->install. | |
11633 | ||
11634 | Note that install() gives no meaningful return value. See uptodate(). | |
11635 | ||
11636 | =item CPAN::Distribution::install_tested() | |
11637 | ||
11638 | Install all the distributions that have been tested sucessfully but | |
11639 | not yet installed. See also C<is_tested>. | |
11640 | ||
11641 | =item CPAN::Distribution::isa_perl() | |
11642 | ||
11643 | Returns 1 if this distribution file seems to be a perl distribution. | |
11644 | Normally this is derived from the file name only, but the index from | |
11645 | CPAN can contain a hint to achieve a return value of true for other | |
11646 | filenames too. | |
11647 | ||
11648 | =item CPAN::Distribution::is_tested() | |
11649 | ||
11650 | List all the distributions that have been tested sucessfully but not | |
11651 | yet installed. See also C<install_tested>. | |
11652 | ||
11653 | =item CPAN::Distribution::look() | |
11654 | ||
11655 | Changes to the directory where the distribution has been unpacked and | |
11656 | opens a subshell there. Exiting the subshell returns. | |
11657 | ||
11658 | =item CPAN::Distribution::make() | |
11659 | ||
11660 | First runs the C<get> method to make sure the distribution is | |
11661 | downloaded and unpacked. Changes to the directory where the | |
11662 | distribution has been unpacked and runs the external commands C<perl | |
11663 | Makefile.PL> or C<perl Build.PL> and C<make> there. | |
11664 | ||
11665 | =item CPAN::Distribution::perldoc() | |
11666 | ||
11667 | Downloads the pod documentation of the file associated with a | |
11668 | distribution (in html format) and runs it through the external | |
11669 | command lynx specified in C<$CPAN::Config->{lynx}>. If lynx | |
11670 | isn't available, it converts it to plain text with external | |
11671 | command html2text and runs it through the pager specified | |
11672 | in C<$CPAN::Config->{pager}> | |
11673 | ||
11674 | =item CPAN::Distribution::prefs() | |
11675 | ||
11676 | Returns the hash reference from the first matching YAML file that the | |
11677 | user has deposited in the C<prefs_dir/> directory. The first | |
11678 | succeeding match wins. The files in the C<prefs_dir/> are processed | |
11679 | alphabetically and the canonical distroname (e.g. | |
11680 | AUTHOR/Foo-Bar-3.14.tar.gz) is matched against the regular expressions | |
11681 | stored in the $root->{match}{distribution} attribute value. | |
11682 | Additionally all module names contained in a distribution are matched | |
11683 | agains the regular expressions in the $root->{match}{module} attribute | |
11684 | value. The two match values are ANDed together. Each of the two | |
11685 | attributes are optional. | |
11686 | ||
11687 | =item CPAN::Distribution::prereq_pm() | |
11688 | ||
11689 | Returns the hash reference that has been announced by a distribution | |
11690 | as the the C<requires> and C<build_requires> elements. These can be | |
11691 | declared either by the C<META.yml> (if authoritative) or can be | |
11692 | deposited after the run of C<Build.PL> in the file C<./_build/prereqs> | |
11693 | or after the run of C<Makfile.PL> written as the C<PREREQ_PM> hash in | |
11694 | a comment in the produced C<Makefile>. I<Note>: this method only works | |
11695 | after an attempt has been made to C<make> the distribution. Returns | |
11696 | undef otherwise. | |
11697 | ||
11698 | =item CPAN::Distribution::readme() | |
11699 | ||
11700 | Downloads the README file associated with a distribution and runs it | |
11701 | through the pager specified in C<$CPAN::Config->{pager}>. | |
11702 | ||
dc053c64 SP |
11703 | =item CPAN::Distribution::reports() |
11704 | ||
11705 | Downloads report data for this distribution from cpantesters.perl.org | |
11706 | and displays a subset of them. | |
11707 | ||
f20de9f0 SP |
11708 | =item CPAN::Distribution::read_yaml() |
11709 | ||
11710 | Returns the content of the META.yml of this distro as a hashref. Note: | |
11711 | works only after an attempt has been made to C<make> the distribution. | |
11712 | Returns undef otherwise. Also returns undef if the content of META.yml | |
11713 | is not authoritative. (The rules about what exactly makes the content | |
11714 | authoritative are still in flux.) | |
11715 | ||
11716 | =item CPAN::Distribution::test() | |
11717 | ||
11718 | Changes to the directory where the distribution has been unpacked and | |
11719 | runs C<make test> there. | |
11720 | ||
11721 | =item CPAN::Distribution::uptodate() | |
11722 | ||
11723 | Returns 1 if all the modules contained in the distribution are | |
11724 | uptodate. Relies on containsmods. | |
11725 | ||
11726 | =item CPAN::Index::force_reload() | |
11727 | ||
11728 | Forces a reload of all indices. | |
11729 | ||
11730 | =item CPAN::Index::reload() | |
11731 | ||
11732 | Reloads all indices if they have not been read for more than | |
11733 | C<$CPAN::Config->{index_expire}> days. | |
11734 | ||
11735 | =item CPAN::InfoObj::dump() | |
11736 | ||
11737 | CPAN::Author, CPAN::Bundle, CPAN::Module, and CPAN::Distribution | |
11738 | inherit this method. It prints the data structure associated with an | |
11739 | object. Useful for debugging. Note: the data structure is considered | |
11740 | internal and thus subject to change without notice. | |
11741 | ||
11742 | =item CPAN::Module::as_glimpse() | |
11743 | ||
11744 | Returns a one-line description of the module in four columns: The | |
11745 | first column contains the word C<Module>, the second column consists | |
11746 | of one character: an equals sign if this module is already installed | |
11747 | and uptodate, a less-than sign if this module is installed but can be | |
11748 | upgraded, and a space if the module is not installed. The third column | |
11749 | is the name of the module and the fourth column gives maintainer or | |
11750 | distribution information. | |
11751 | ||
11752 | =item CPAN::Module::as_string() | |
11753 | ||
11754 | Returns a multi-line description of the module | |
11755 | ||
11756 | =item CPAN::Module::clean() | |
11757 | ||
11758 | Runs a clean on the distribution associated with this module. | |
11759 | ||
11760 | =item CPAN::Module::cpan_file() | |
11761 | ||
11762 | Returns the filename on CPAN that is associated with the module. | |
11763 | ||
11764 | =item CPAN::Module::cpan_version() | |
11765 | ||
11766 | Returns the latest version of this module available on CPAN. | |
11767 | ||
11768 | =item CPAN::Module::cvs_import() | |
11769 | ||
11770 | Runs a cvs_import on the distribution associated with this module. | |
11771 | ||
11772 | =item CPAN::Module::description() | |
11773 | ||
11774 | Returns a 44 character description of this module. Only available for | |
11775 | modules listed in The Module List (CPAN/modules/00modlist.long.html | |
11776 | or 00modlist.long.txt.gz) | |
11777 | ||
11778 | =item CPAN::Module::distribution() | |
11779 | ||
11780 | Returns the CPAN::Distribution object that contains the current | |
11781 | version of this module. | |
11782 | ||
11783 | =item CPAN::Module::dslip_status() | |
11784 | ||
11785 | Returns a hash reference. The keys of the hash are the letters C<D>, | |
11786 | C<S>, C<L>, C<I>, and <P>, for development status, support level, | |
11787 | language, interface and public licence respectively. The data for the | |
11788 | DSLIP status are collected by pause.perl.org when authors register | |
11789 | their namespaces. The values of the 5 hash elements are one-character | |
11790 | words whose meaning is described in the table below. There are also 5 | |
11791 | hash elements C<DV>, C<SV>, C<LV>, C<IV>, and <PV> that carry a more | |
11792 | verbose value of the 5 status variables. | |
11793 | ||
11794 | Where the 'DSLIP' characters have the following meanings: | |
11795 | ||
11796 | D - Development Stage (Note: *NO IMPLIED TIMESCALES*): | |
11797 | i - Idea, listed to gain consensus or as a placeholder | |
11798 | c - under construction but pre-alpha (not yet released) | |
11799 | a/b - Alpha/Beta testing | |
11800 | R - Released | |
11801 | M - Mature (no rigorous definition) | |
11802 | S - Standard, supplied with Perl 5 | |
11803 | ||
11804 | S - Support Level: | |
11805 | m - Mailing-list | |
11806 | d - Developer | |
11807 | u - Usenet newsgroup comp.lang.perl.modules | |
11808 | n - None known, try comp.lang.perl.modules | |
11809 | a - abandoned; volunteers welcome to take over maintainance | |
11810 | ||
11811 | L - Language Used: | |
11812 | p - Perl-only, no compiler needed, should be platform independent | |
11813 | c - C and perl, a C compiler will be needed | |
11814 | h - Hybrid, written in perl with optional C code, no compiler needed | |
11815 | + - C++ and perl, a C++ compiler will be needed | |
11816 | o - perl and another language other than C or C++ | |
11817 | ||
11818 | I - Interface Style | |
11819 | f - plain Functions, no references used | |
11820 | h - hybrid, object and function interfaces available | |
11821 | n - no interface at all (huh?) | |
11822 | r - some use of unblessed References or ties | |
11823 | O - Object oriented using blessed references and/or inheritance | |
11824 | ||
11825 | P - Public License | |
11826 | p - Standard-Perl: user may choose between GPL and Artistic | |
11827 | g - GPL: GNU General Public License | |
11828 | l - LGPL: "GNU Lesser General Public License" (previously known as | |
11829 | "GNU Library General Public License") | |
11830 | b - BSD: The BSD License | |
11831 | a - Artistic license alone | |
f04ea8d1 | 11832 | 2 - Artistic license 2.0 or later |
f20de9f0 SP |
11833 | o - open source: appoved by www.opensource.org |
11834 | d - allows distribution without restrictions | |
11835 | r - restricted distribtion | |
11836 | n - no license at all | |
11837 | ||
11838 | =item CPAN::Module::force($method,@args) | |
11839 | ||
11840 | Forces CPAN to perform a task that it normally would have refused to | |
11841 | do. Force takes as arguments a method name to be called and any number | |
11842 | of additional arguments that should be passed to the called method. | |
11843 | The internals of the object get the needed changes so that CPAN.pm | |
11844 | does not refuse to take the action. See also the section above on the | |
11845 | C<force> and the C<fforce> pragma. | |
11846 | ||
11847 | =item CPAN::Module::get() | |
11848 | ||
11849 | Runs a get on the distribution associated with this module. | |
11850 | ||
11851 | =item CPAN::Module::inst_file() | |
11852 | ||
11853 | Returns the filename of the module found in @INC. The first file found | |
11854 | is reported just like perl itself stops searching @INC when it finds a | |
11855 | module. | |
5f05dabc | 11856 | |
f20de9f0 | 11857 | =item CPAN::Module::available_file() |
5f05dabc | 11858 | |
f20de9f0 SP |
11859 | Returns the filename of the module found in PERL5LIB or @INC. The |
11860 | first file found is reported. The advantage of this method over | |
11861 | C<inst_file> is that modules that have been tested but not yet | |
11862 | installed are included because PERL5LIB keeps track of tested modules. | |
5f05dabc | 11863 | |
f20de9f0 | 11864 | =item CPAN::Module::inst_version() |
5f05dabc | 11865 | |
f20de9f0 | 11866 | Returns the version number of the installed module in readable format. |
5f05dabc | 11867 | |
f20de9f0 | 11868 | =item CPAN::Module::available_version() |
5f05dabc | 11869 | |
f20de9f0 | 11870 | Returns the version number of the available module in readable format. |
5f05dabc | 11871 | |
f20de9f0 | 11872 | =item CPAN::Module::install() |
5f05dabc | 11873 | |
f20de9f0 | 11874 | Runs an C<install> on the distribution associated with this module. |
5f05dabc | 11875 | |
f20de9f0 | 11876 | =item CPAN::Module::look() |
5f05dabc | 11877 | |
f20de9f0 SP |
11878 | Changes to the directory where the distribution associated with this |
11879 | module has been unpacked and opens a subshell there. Exiting the | |
11880 | subshell returns. | |
5f05dabc | 11881 | |
f20de9f0 | 11882 | =item CPAN::Module::make() |
5f05dabc | 11883 | |
f20de9f0 SP |
11884 | Runs a C<make> on the distribution associated with this module. |
11885 | ||
11886 | =item CPAN::Module::manpage_headline() | |
11887 | ||
11888 | If module is installed, peeks into the module's manpage, reads the | |
11889 | headline and returns it. Moreover, if the module has been downloaded | |
11890 | within this session, does the equivalent on the downloaded module even | |
11891 | if it is not installed. | |
11892 | ||
11893 | =item CPAN::Module::perldoc() | |
11894 | ||
11895 | Runs a C<perldoc> on this module. | |
11896 | ||
11897 | =item CPAN::Module::readme() | |
11898 | ||
11899 | Runs a C<readme> on the distribution associated with this module. | |
11900 | ||
dc053c64 SP |
11901 | =item CPAN::Module::reports() |
11902 | ||
11903 | Calls the reports() method on the associated distribution object. | |
11904 | ||
f20de9f0 SP |
11905 | =item CPAN::Module::test() |
11906 | ||
11907 | Runs a C<test> on the distribution associated with this module. | |
11908 | ||
11909 | =item CPAN::Module::uptodate() | |
11910 | ||
11911 | Returns 1 if the module is installed and up-to-date. | |
11912 | ||
11913 | =item CPAN::Module::userid() | |
11914 | ||
11915 | Returns the author's ID of the module. | |
5f05dabc | 11916 | |
11917 | =back | |
11918 | ||
f20de9f0 | 11919 | =head2 Cache Manager |
ca79d794 | 11920 | |
f20de9f0 SP |
11921 | Currently the cache manager only keeps track of the build directory |
11922 | ($CPAN::Config->{build_dir}). It is a simple FIFO mechanism that | |
11923 | deletes complete directories below C<build_dir> as soon as the size of | |
11924 | all directories there gets bigger than $CPAN::Config->{build_cache} | |
11925 | (in MB). The contents of this cache may be used for later | |
11926 | re-installations that you intend to do manually, but will never be | |
11927 | trusted by CPAN itself. This is due to the fact that the user might | |
11928 | use these directories for building modules on different architectures. | |
11929 | ||
11930 | There is another directory ($CPAN::Config->{keep_source_where}) where | |
11931 | the original distribution files are kept. This directory is not | |
11932 | covered by the cache manager and must be controlled by the user. If | |
11933 | you choose to have the same directory as build_dir and as | |
11934 | keep_source_where directory, then your sources will be deleted with | |
11935 | the same fifo mechanism. | |
11936 | ||
11937 | =head2 Bundles | |
11938 | ||
11939 | A bundle is just a perl module in the namespace Bundle:: that does not | |
11940 | define any functions or methods. It usually only contains documentation. | |
11941 | ||
11942 | It starts like a perl module with a package declaration and a $VERSION | |
11943 | variable. After that the pod section looks like any other pod with the | |
11944 | only difference being that I<one special pod section> exists starting with | |
11945 | (verbatim): | |
11946 | ||
f04ea8d1 | 11947 | =head1 CONTENTS |
f20de9f0 SP |
11948 | |
11949 | In this pod section each line obeys the format | |
11950 | ||
11951 | Module_Name [Version_String] [- optional text] | |
11952 | ||
11953 | The only required part is the first field, the name of a module | |
11954 | (e.g. Foo::Bar, ie. I<not> the name of the distribution file). The rest | |
11955 | of the line is optional. The comment part is delimited by a dash just | |
11956 | as in the man page header. | |
11957 | ||
11958 | The distribution of a bundle should follow the same convention as | |
11959 | other distributions. | |
11960 | ||
11961 | Bundles are treated specially in the CPAN package. If you say 'install | |
11962 | Bundle::Tkkit' (assuming such a bundle exists), CPAN will install all | |
11963 | the modules in the CONTENTS section of the pod. You can install your | |
11964 | own Bundles locally by placing a conformant Bundle file somewhere into | |
11965 | your @INC path. The autobundle() command which is available in the | |
11966 | shell interface does that for you by including all currently installed | |
11967 | modules in a snapshot bundle file. | |
11968 | ||
11969 | =head1 PREREQUISITES | |
11970 | ||
11971 | If you have a local mirror of CPAN and can access all files with | |
11972 | "file:" URLs, then you only need a perl better than perl5.003 to run | |
11973 | this module. Otherwise Net::FTP is strongly recommended. LWP may be | |
11974 | required for non-UNIX systems or if your nearest CPAN site is | |
11975 | associated with a URL that is not C<ftp:>. | |
11976 | ||
11977 | If you have neither Net::FTP nor LWP, there is a fallback mechanism | |
11978 | implemented for an external ftp command or for an external lynx | |
11979 | command. | |
11980 | ||
11981 | =head1 UTILITIES | |
11982 | ||
11983 | =head2 Finding packages and VERSION | |
11984 | ||
11985 | This module presumes that all packages on CPAN | |
ca79d794 | 11986 | |
2ccf00a7 SP |
11987 | =over 2 |
11988 | ||
f20de9f0 | 11989 | =item * |
2ccf00a7 | 11990 | |
f20de9f0 SP |
11991 | declare their $VERSION variable in an easy to parse manner. This |
11992 | prerequisite can hardly be relaxed because it consumes far too much | |
11993 | memory to load all packages into the running program just to determine | |
11994 | the $VERSION variable. Currently all programs that are dealing with | |
11995 | version use something like this | |
2ccf00a7 | 11996 | |
f20de9f0 SP |
11997 | perl -MExtUtils::MakeMaker -le \ |
11998 | 'print MM->parse_version(shift)' filename | |
2ccf00a7 | 11999 | |
f20de9f0 SP |
12000 | If you are author of a package and wonder if your $VERSION can be |
12001 | parsed, please try the above method. | |
2ccf00a7 | 12002 | |
f20de9f0 | 12003 | =item * |
2ccf00a7 | 12004 | |
f20de9f0 SP |
12005 | come as compressed or gzipped tarfiles or as zip files and contain a |
12006 | C<Makefile.PL> or C<Build.PL> (well, we try to handle a bit more, but | |
12007 | without much enthusiasm). | |
2ccf00a7 | 12008 | |
f20de9f0 | 12009 | =back |
2ccf00a7 | 12010 | |
f20de9f0 SP |
12011 | =head2 Debugging |
12012 | ||
12013 | The debugging of this module is a bit complex, because we have | |
12014 | interferences of the software producing the indices on CPAN, of the | |
12015 | mirroring process on CPAN, of packaging, of configuration, of | |
12016 | synchronicity, and of bugs within CPAN.pm. | |
12017 | ||
12018 | For debugging the code of CPAN.pm itself in interactive mode some more | |
12019 | or less useful debugging aid can be turned on for most packages within | |
12020 | CPAN.pm with one of | |
12021 | ||
12022 | =over 2 | |
12023 | ||
12024 | =item o debug package... | |
12025 | ||
12026 | sets debug mode for packages. | |
12027 | ||
12028 | =item o debug -package... | |
12029 | ||
12030 | unsets debug mode for packages. | |
12031 | ||
12032 | =item o debug all | |
12033 | ||
12034 | turns debugging on for all packages. | |
12035 | ||
12036 | =item o debug number | |
2ccf00a7 SP |
12037 | |
12038 | =back | |
ca79d794 | 12039 | |
f20de9f0 SP |
12040 | which sets the debugging packages directly. Note that C<o debug 0> |
12041 | turns debugging off. | |
36263cb3 | 12042 | |
f20de9f0 SP |
12043 | What seems quite a successful strategy is the combination of C<reload |
12044 | cpan> and the debugging switches. Add a new debug statement while | |
12045 | running in the shell and then issue a C<reload cpan> and see the new | |
12046 | debugging messages immediately without losing the current context. | |
36263cb3 | 12047 | |
f20de9f0 SP |
12048 | C<o debug> without an argument lists the valid package names and the |
12049 | current set of packages in debugging mode. C<o debug> has built-in | |
12050 | completion support. | |
36263cb3 | 12051 | |
f20de9f0 SP |
12052 | For debugging of CPAN data there is the C<dump> command which takes |
12053 | the same arguments as make/test/install and outputs each object's | |
12054 | Data::Dumper dump. If an argument looks like a perl variable and | |
12055 | contains one of C<$>, C<@> or C<%>, it is eval()ed and fed to | |
12056 | Data::Dumper directly. | |
36263cb3 | 12057 | |
f20de9f0 | 12058 | =head2 Floppy, Zip, Offline Mode |
36263cb3 | 12059 | |
f20de9f0 SP |
12060 | CPAN.pm works nicely without network too. If you maintain machines |
12061 | that are not networked at all, you should consider working with file: | |
12062 | URLs. Of course, you have to collect your modules somewhere first. So | |
12063 | you might use CPAN.pm to put together all you need on a networked | |
12064 | machine. Then copy the $CPAN::Config->{keep_source_where} (but not | |
12065 | $CPAN::Config->{build_dir}) directory on a floppy. This floppy is kind | |
12066 | of a personal CPAN. CPAN.pm on the non-networked machines works nicely | |
12067 | with this floppy. See also below the paragraph about CD-ROM support. | |
c356248b | 12068 | |
f20de9f0 | 12069 | =head2 Basic Utilities for Programmers |
c356248b | 12070 | |
f20de9f0 | 12071 | =over 2 |
c356248b | 12072 | |
f20de9f0 | 12073 | =item has_inst($module) |
c356248b | 12074 | |
f20de9f0 SP |
12075 | Returns true if the module is installed. Used to load all modules into |
12076 | the running CPAN.pm which are considered optional. The config variable | |
12077 | C<dontload_list> can be used to intercept the C<has_inst()> call such | |
12078 | that an optional module is not loaded despite being available. For | |
12079 | example the following command will prevent that C<YAML.pm> is being | |
12080 | loaded: | |
2e2b7522 | 12081 | |
f20de9f0 | 12082 | cpan> o conf dontload_list push YAML |
05bab18e | 12083 | |
f20de9f0 | 12084 | See the source for details. |
05bab18e | 12085 | |
f20de9f0 SP |
12086 | =item has_usable($module) |
12087 | ||
12088 | Returns true if the module is installed and is in a usable state. Only | |
12089 | useful for a handful of modules that are used internally. See the | |
12090 | source for details. | |
05bab18e | 12091 | |
f20de9f0 | 12092 | =item instance($module) |
1e8f9a0a | 12093 | |
f20de9f0 SP |
12094 | The constructor for all the singletons used to represent modules, |
12095 | distributions, authors and bundles. If the object already exists, this | |
12096 | method returns the object, otherwise it calls the constructor. | |
12097 | ||
12098 | =back | |
1e8f9a0a | 12099 | |
5f05dabc | 12100 | =head1 SECURITY |
12101 | ||
12102 | There's no strong security layer in CPAN.pm. CPAN.pm helps you to | |
12103 | install foreign, unmasked, unsigned code on your machine. We compare | |
12104 | to a checksum that comes from the net just as the distribution file | |
0cf35e6a SP |
12105 | itself. But we try to make it easy to add security on demand: |
12106 | ||
12107 | =head2 Cryptographically signed modules | |
12108 | ||
12109 | Since release 1.77 CPAN.pm has been able to verify cryptographically | |
12110 | signed module distributions using Module::Signature. The CPAN modules | |
12111 | can be signed by their authors, thus giving more security. The simple | |
12112 | unsigned MD5 checksums that were used before by CPAN protect mainly | |
12113 | against accidental file corruption. | |
12114 | ||
12115 | You will need to have Module::Signature installed, which in turn | |
12116 | requires that you have at least one of Crypt::OpenPGP module or the | |
12117 | command-line F<gpg> tool installed. | |
12118 | ||
12119 | You will also need to be able to connect over the Internet to the public | |
12120 | keyservers, like pgp.mit.edu, and their port 11731 (the HKP protocol). | |
5f05dabc | 12121 | |
ed84aac9 A |
12122 | The configuration parameter check_sigs is there to turn signature |
12123 | checking on or off. | |
12124 | ||
5f05dabc | 12125 | =head1 EXPORT |
12126 | ||
12127 | Most functions in package CPAN are exported per default. The reason | |
12128 | for this is that the primary use is intended for the cpan shell or for | |
d1be9408 | 12129 | one-liners. |
5f05dabc | 12130 | |
9ddc4ed0 A |
12131 | =head1 ENVIRONMENT |
12132 | ||
12133 | When the CPAN shell enters a subshell via the look command, it sets | |
12134 | the environment CPAN_SHELL_LEVEL to 1 or increments it if it is | |
12135 | already set. | |
12136 | ||
f04ea8d1 SP |
12137 | When CPAN runs, it sets the environment variable PERL5_CPAN_IS_RUNNING |
12138 | to the ID of the running process. It also sets | |
12139 | PERL5_CPANPLUS_IS_RUNNING to prevent runaway processes which could | |
12140 | happen with older versions of Module::Install. | |
12141 | ||
12142 | When running C<perl Makefile.PL>, the environment variable | |
12143 | C<PERL5_CPAN_IS_EXECUTING> is set to the full path of the | |
12144 | C<Makefile.PL> that is being executed. This prevents runaway processes | |
12145 | with newer versions of Module::Install. | |
be34b10d | 12146 | |
44d21104 A |
12147 | When the config variable ftp_passive is set, all downloads will be run |
12148 | with the environment variable FTP_PASSIVE set to this value. This is | |
4d1321a7 A |
12149 | in general a good idea as it influences both Net::FTP and LWP based |
12150 | connections. The same effect can be achieved by starting the cpan | |
12151 | shell with this environment variable set. For Net::FTP alone, one can | |
12152 | also always set passive mode by running libnetcfg. | |
44d21104 | 12153 | |
f610777f A |
12154 | =head1 POPULATE AN INSTALLATION WITH LOTS OF MODULES |
12155 | ||
d8773709 | 12156 | Populating a freshly installed perl with my favorite modules is pretty |
8b3ad137 | 12157 | easy if you maintain a private bundle definition file. To get a useful |
f610777f A |
12158 | blueprint of a bundle definition file, the command autobundle can be used |
12159 | on the CPAN shell command line. This command writes a bundle definition | |
36263cb3 | 12160 | file for all modules that are installed for the currently running perl |
f610777f A |
12161 | interpreter. It's recommended to run this command only once and from then |
12162 | on maintain the file manually under a private name, say | |
12163 | Bundle/my_bundle.pm. With a clever bundle file you can then simply say | |
12164 | ||
12165 | cpan> install Bundle::my_bundle | |
12166 | ||
36263cb3 | 12167 | then answer a few questions and then go out for a coffee. |
f610777f | 12168 | |
8b3ad137 | 12169 | Maintaining a bundle definition file means keeping track of two |
36263cb3 GS |
12170 | things: dependencies and interactivity. CPAN.pm sometimes fails on |
12171 | calculating dependencies because not all modules define all MakeMaker | |
12172 | attributes correctly, so a bundle definition file should specify | |
12173 | prerequisites as early as possible. On the other hand, it's a bit | |
12174 | annoying that many distributions need some interactive configuring. So | |
12175 | what I try to accomplish in my private bundle file is to have the | |
12176 | packages that need to be configured early in the file and the gentle | |
12177 | ones later, so I can go out after a few minutes and leave CPAN.pm | |
8b3ad137 | 12178 | untended. |
f610777f A |
12179 | |
12180 | =head1 WORKING WITH CPAN.pm BEHIND FIREWALLS | |
12181 | ||
36263cb3 | 12182 | Thanks to Graham Barr for contributing the following paragraphs about |
de34a54b | 12183 | the interaction between perl, and various firewall configurations. For |
3c4b39be | 12184 | further information on firewalls, it is recommended to consult the |
de34a54b JH |
12185 | documentation that comes with the ncftp program. If you are unable to |
12186 | go through the firewall with a simple Perl setup, it is very likely | |
12187 | that you can configure ncftp so that it works for your firewall. | |
12188 | ||
12189 | =head2 Three basic types of firewalls | |
f610777f A |
12190 | |
12191 | Firewalls can be categorized into three basic types. | |
12192 | ||
bbc7dcd2 | 12193 | =over 4 |
f610777f A |
12194 | |
12195 | =item http firewall | |
12196 | ||
12197 | This is where the firewall machine runs a web server and to access the | |
12198 | outside world you must do it via the web server. If you set environment | |
12199 | variables like http_proxy or ftp_proxy to a values beginning with http:// | |
12200 | or in your web browser you have to set proxy information then you know | |
d1be9408 | 12201 | you are running an http firewall. |
f610777f A |
12202 | |
12203 | To access servers outside these types of firewalls with perl (even for | |
12204 | ftp) you will need to use LWP. | |
12205 | ||
12206 | =item ftp firewall | |
12207 | ||
d1be9408 | 12208 | This where the firewall machine runs an ftp server. This kind of |
911a92db GS |
12209 | firewall will only let you access ftp servers outside the firewall. |
12210 | This is usually done by connecting to the firewall with ftp, then | |
12211 | entering a username like "user@outside.host.com" | |
f610777f A |
12212 | |
12213 | To access servers outside these type of firewalls with perl you | |
12214 | will need to use Net::FTP. | |
12215 | ||
12216 | =item One way visibility | |
12217 | ||
d1be9408 | 12218 | I say one way visibility as these firewalls try to make themselves look |
f610777f A |
12219 | invisible to the users inside the firewall. An FTP data connection is |
12220 | normally created by sending the remote server your IP address and then | |
12221 | listening for the connection. But the remote server will not be able to | |
12222 | connect to you because of the firewall. So for these types of firewall | |
12223 | FTP connections need to be done in a passive mode. | |
12224 | ||
12225 | There are two that I can think off. | |
12226 | ||
bbc7dcd2 | 12227 | =over 4 |
f610777f A |
12228 | |
12229 | =item SOCKS | |
12230 | ||
12231 | If you are using a SOCKS firewall you will need to compile perl and link | |
c4d24d4c | 12232 | it with the SOCKS library, this is what is normally called a 'socksified' |
f610777f A |
12233 | perl. With this executable you will be able to connect to servers outside |
12234 | the firewall as if it is not there. | |
12235 | ||
12236 | =item IP Masquerade | |
12237 | ||
12238 | This is the firewall implemented in the Linux kernel, it allows you to | |
12239 | hide a complete network behind one IP address. With this firewall no | |
d8773709 | 12240 | special compiling is needed as you can access hosts directly. |
f610777f | 12241 | |
4d1321a7 A |
12242 | For accessing ftp servers behind such firewalls you usually need to |
12243 | set the environment variable C<FTP_PASSIVE> or the config variable | |
12244 | ftp_passive to a true value. | |
5fc0f0f6 | 12245 | |
f610777f A |
12246 | =back |
12247 | ||
12248 | =back | |
12249 | ||
c4d24d4c | 12250 | =head2 Configuring lynx or ncftp for going through a firewall |
de34a54b JH |
12251 | |
12252 | If you can go through your firewall with e.g. lynx, presumably with a | |
12253 | command such as | |
12254 | ||
12255 | /usr/local/bin/lynx -pscott:tiger | |
12256 | ||
12257 | then you would configure CPAN.pm with the command | |
12258 | ||
12259 | o conf lynx "/usr/local/bin/lynx -pscott:tiger" | |
12260 | ||
12261 | That's all. Similarly for ncftp or ftp, you would configure something | |
12262 | like | |
12263 | ||
12264 | o conf ncftp "/usr/bin/ncftp -f /home/scott/ncftplogin.cfg" | |
12265 | ||
d1be9408 | 12266 | Your mileage may vary... |
de34a54b JH |
12267 | |
12268 | =head1 FAQ | |
12269 | ||
bbc7dcd2 | 12270 | =over 4 |
de34a54b | 12271 | |
551e1d92 RB |
12272 | =item 1) |
12273 | ||
12274 | I installed a new version of module X but CPAN keeps saying, | |
12275 | I have the old version installed | |
de34a54b JH |
12276 | |
12277 | Most probably you B<do> have the old version installed. This can | |
12278 | happen if a module installs itself into a different directory in the | |
12279 | @INC path than it was previously installed. This is not really a | |
12280 | CPAN.pm problem, you would have the same problem when installing the | |
12281 | module manually. The easiest way to prevent this behaviour is to add | |
12282 | the argument C<UNINST=1> to the C<make install> call, and that is why | |
12283 | many people add this argument permanently by configuring | |
12284 | ||
12285 | o conf make_install_arg UNINST=1 | |
12286 | ||
551e1d92 RB |
12287 | =item 2) |
12288 | ||
12289 | So why is UNINST=1 not the default? | |
de34a54b JH |
12290 | |
12291 | Because there are people who have their precise expectations about who | |
12292 | may install where in the @INC path and who uses which @INC array. In | |
12293 | fine tuned environments C<UNINST=1> can cause damage. | |
12294 | ||
551e1d92 RB |
12295 | =item 3) |
12296 | ||
12297 | I want to clean up my mess, and install a new perl along with | |
12298 | all modules I have. How do I go about it? | |
9d61fa1d A |
12299 | |
12300 | Run the autobundle command for your old perl and optionally rename the | |
12301 | resulting bundle file (e.g. Bundle/mybundle.pm), install the new perl | |
12302 | with the Configure option prefix, e.g. | |
12303 | ||
12304 | ./Configure -Dprefix=/usr/local/perl-5.6.78.9 | |
12305 | ||
12306 | Install the bundle file you produced in the first step with something like | |
12307 | ||
12308 | cpan> install Bundle::mybundle | |
12309 | ||
12310 | and you're done. | |
12311 | ||
551e1d92 RB |
12312 | =item 4) |
12313 | ||
12314 | When I install bundles or multiple modules with one command | |
12315 | there is too much output to keep track of. | |
de34a54b JH |
12316 | |
12317 | You may want to configure something like | |
12318 | ||
12319 | o conf make_arg "| tee -ai /root/.cpan/logs/make.out" | |
12320 | o conf make_install_arg "| tee -ai /root/.cpan/logs/make_install.out" | |
12321 | ||
12322 | so that STDOUT is captured in a file for later inspection. | |
12323 | ||
c4d24d4c | 12324 | |
551e1d92 RB |
12325 | =item 5) |
12326 | ||
12327 | I am not root, how can I install a module in a personal directory? | |
c4d24d4c | 12328 | |
554a9ef5 | 12329 | First of all, you will want to use your own configuration, not the one |
44d21104 A |
12330 | that your root user installed. If you do not have permission to write |
12331 | in the cpan directory that root has configured, you will be asked if | |
12332 | you want to create your own config. Answering "yes" will bring you into | |
12333 | CPAN's configuration stage, using the system config for all defaults except | |
12334 | things that have to do with CPAN's work directory, saving your choices to | |
12335 | your MyConfig.pm file. | |
12336 | ||
12337 | You can also manually initiate this process with the following command: | |
12338 | ||
12339 | % perl -MCPAN -e 'mkmyconfig' | |
554a9ef5 | 12340 | |
44d21104 | 12341 | or by running |
554a9ef5 | 12342 | |
44d21104 A |
12343 | mkmyconfig |
12344 | ||
12345 | from the CPAN shell. | |
12346 | ||
12347 | You will most probably also want to configure something like this: | |
c4d24d4c A |
12348 | |
12349 | o conf makepl_arg "LIB=~/myperl/lib \ | |
12350 | INSTALLMAN1DIR=~/myperl/man/man1 \ | |
ed756621 SP |
12351 | INSTALLMAN3DIR=~/myperl/man/man3 \ |
12352 | INSTALLSCRIPT=~/myperl/bin \ | |
12353 | INSTALLBIN=~/myperl/bin" | |
12354 | ||
f04ea8d1 SP |
12355 | and then (oh joy) the equivalent command for Module::Build. That would |
12356 | be | |
12357 | ||
12358 | o conf mbuildpl_arg "--lib=~/myperl/lib \ | |
12359 | --installman1dir=~/myperl/man/man1 \ | |
12360 | --installman3dir=~/myperl/man/man3 \ | |
12361 | --installscript=~/myperl/bin \ | |
12362 | --installbin=~/myperl/bin" | |
c4d24d4c A |
12363 | |
12364 | You can make this setting permanent like all C<o conf> settings with | |
ed756621 | 12365 | C<o conf commit> or by setting C<auto_commit> beforehand. |
c4d24d4c A |
12366 | |
12367 | You will have to add ~/myperl/man to the MANPATH environment variable | |
12368 | and also tell your perl programs to look into ~/myperl/lib, e.g. by | |
12369 | including | |
12370 | ||
12371 | use lib "$ENV{HOME}/myperl/lib"; | |
12372 | ||
12373 | or setting the PERL5LIB environment variable. | |
12374 | ||
87892b73 RGS |
12375 | While we're speaking about $ENV{HOME}, it might be worth mentioning, |
12376 | that for Windows we use the File::HomeDir module that provides an | |
12377 | equivalent to the concept of the home directory on Unix. | |
12378 | ||
4d1321a7 | 12379 | Another thing you should bear in mind is that the UNINST parameter can |
f04ea8d1 | 12380 | be dangerous when you are installing into a private area because you |
4d1321a7 A |
12381 | might accidentally remove modules that other people depend on that are |
12382 | not using the private area. | |
c4d24d4c | 12383 | |
551e1d92 RB |
12384 | =item 6) |
12385 | ||
12386 | How to get a package, unwrap it, and make a change before building it? | |
c4d24d4c | 12387 | |
8962fc49 | 12388 | Have a look at the C<look> (!) command. |
c4d24d4c | 12389 | |
551e1d92 RB |
12390 | =item 7) |
12391 | ||
12392 | I installed a Bundle and had a couple of fails. When I | |
12393 | retried, everything resolved nicely. Can this be fixed to work | |
12394 | on first try? | |
c4d24d4c A |
12395 | |
12396 | The reason for this is that CPAN does not know the dependencies of all | |
12397 | modules when it starts out. To decide about the additional items to | |
44d21104 A |
12398 | install, it just uses data found in the META.yml file or the generated |
12399 | Makefile. An undetected missing piece breaks the process. But it may | |
12400 | well be that your Bundle installs some prerequisite later than some | |
12401 | depending item and thus your second try is able to resolve everything. | |
12402 | Please note, CPAN.pm does not know the dependency tree in advance and | |
12403 | cannot sort the queue of things to install in a topologically correct | |
12404 | order. It resolves perfectly well IF all modules declare the | |
12405 | prerequisites correctly with the PREREQ_PM attribute to MakeMaker or | |
12406 | the C<requires> stanza of Module::Build. For bundles which fail and | |
12407 | you need to install often, it is recommended to sort the Bundle | |
12408 | definition file manually. | |
5a5fac02 | 12409 | |
551e1d92 RB |
12410 | =item 8) |
12411 | ||
12412 | In our intranet we have many modules for internal use. How | |
12413 | can I integrate these modules with CPAN.pm but without uploading | |
12414 | the modules to CPAN? | |
5a5fac02 JH |
12415 | |
12416 | Have a look at the CPAN::Site module. | |
c4d24d4c | 12417 | |
551e1d92 RB |
12418 | =item 9) |
12419 | ||
44d21104 A |
12420 | When I run CPAN's shell, I get an error message about things in my |
12421 | /etc/inputrc (or ~/.inputrc) file. | |
9d61fa1d | 12422 | |
44d21104 A |
12423 | These are readline issues and can only be fixed by studying readline |
12424 | configuration on your architecture and adjusting the referenced file | |
12425 | accordingly. Please make a backup of the /etc/inputrc or ~/.inputrc | |
12426 | and edit them. Quite often harmless changes like uppercasing or | |
12427 | lowercasing some arguments solves the problem. | |
8d97e4a1 | 12428 | |
551e1d92 RB |
12429 | =item 10) |
12430 | ||
12431 | Some authors have strange characters in their names. | |
8d97e4a1 JH |
12432 | |
12433 | Internally CPAN.pm uses the UTF-8 charset. If your terminal is | |
12434 | expecting ISO-8859-1 charset, a converter can be activated by setting | |
12435 | term_is_latin to a true value in your config file. One way of doing so | |
12436 | would be | |
12437 | ||
44d21104 | 12438 | cpan> o conf term_is_latin 1 |
8d97e4a1 | 12439 | |
44d21104 A |
12440 | If other charset support is needed, please file a bugreport against |
12441 | CPAN.pm at rt.cpan.org and describe your needs. Maybe we can extend | |
12442 | the support or maybe UTF-8 terminals become widely available. | |
9d61fa1d | 12443 | |
f04ea8d1 SP |
12444 | Note: this config variable is deprecated and will be removed in a |
12445 | future version of CPAN.pm. It will be replaced with the conventions | |
12446 | around the family of $LANG and $LC_* environment variables. | |
12447 | ||
554a9ef5 SP |
12448 | =item 11) |
12449 | ||
12450 | When an install fails for some reason and then I correct the error | |
12451 | condition and retry, CPAN.pm refuses to install the module, saying | |
12452 | C<Already tried without success>. | |
12453 | ||
12454 | Use the force pragma like so | |
12455 | ||
12456 | force install Foo::Bar | |
12457 | ||
554a9ef5 SP |
12458 | Or you can use |
12459 | ||
12460 | look Foo::Bar | |
12461 | ||
12462 | and then 'make install' directly in the subshell. | |
12463 | ||
44d21104 A |
12464 | =item 12) |
12465 | ||
12466 | How do I install a "DEVELOPER RELEASE" of a module? | |
12467 | ||
8962fc49 SP |
12468 | By default, CPAN will install the latest non-developer release of a |
12469 | module. If you want to install a dev release, you have to specify the | |
12470 | partial path starting with the author id to the tarball you wish to | |
12471 | install, like so: | |
44d21104 | 12472 | |
4d1321a7 | 12473 | cpan> install KWILLIAMS/Module-Build-0.27_07.tar.gz |
44d21104 | 12474 | |
8962fc49 SP |
12475 | Note that you can use the C<ls> command to get this path listed. |
12476 | ||
44d21104 A |
12477 | =item 13) |
12478 | ||
4d1321a7 | 12479 | How do I install a module and all its dependencies from the commandline, |
44d21104 A |
12480 | without being prompted for anything, despite my CPAN configuration |
12481 | (or lack thereof)? | |
12482 | ||
4d1321a7 | 12483 | CPAN uses ExtUtils::MakeMaker's prompt() function to ask its questions, so |
44d21104 A |
12484 | if you set the PERL_MM_USE_DEFAULT environment variable, you shouldn't be |
12485 | asked any questions at all (assuming the modules you are installing are | |
12486 | nice about obeying that variable as well): | |
12487 | ||
12488 | % PERL_MM_USE_DEFAULT=1 perl -MCPAN -e 'install My::Module' | |
12489 | ||
b96578bb SP |
12490 | =item 14) |
12491 | ||
05bab18e | 12492 | How do I create a Module::Build based Build.PL derived from an |
ed84aac9 | 12493 | ExtUtils::MakeMaker focused Makefile.PL? |
b96578bb SP |
12494 | |
12495 | http://search.cpan.org/search?query=Module::Build::Convert | |
12496 | ||
ade94d80 | 12497 | http://www.refcnt.org/papers/module-build-convert |
b96578bb | 12498 | |
05bab18e SP |
12499 | =item 15) |
12500 | ||
12501 | What's the best CPAN site for me? | |
12502 | ||
12503 | The urllist config parameter is yours. You can add and remove sites at | |
12504 | will. You should find out which sites have the best uptodateness, | |
12505 | bandwidth, reliability, etc. and are topologically close to you. Some | |
12506 | people prefer fast downloads, others uptodateness, others reliability. | |
12507 | You decide which to try in which order. | |
12508 | ||
12509 | Henk P. Penning maintains a site that collects data about CPAN sites: | |
12510 | ||
12511 | http://www.cs.uu.nl/people/henkp/mirmon/cpan.html | |
b96578bb | 12512 | |
f04ea8d1 SP |
12513 | =item 16) |
12514 | ||
12515 | Why do I get asked the same questions every time I start the shell? | |
12516 | ||
12517 | You can make your configuration changes permanent by calling the | |
12518 | command C<o conf commit>. Alternatively set the C<auto_commit> | |
12519 | variable to true by running C<o conf init auto_commit> and answering | |
12520 | the following question with yes. | |
12521 | ||
de34a54b JH |
12522 | =back |
12523 | ||
b72dd56f | 12524 | =head1 COMPATIBILITY |
5f05dabc | 12525 | |
b72dd56f | 12526 | =head2 OLD PERL VERSIONS |
4d1321a7 | 12527 | |
b72dd56f SP |
12528 | CPAN.pm is regularly tested to run under 5.004, 5.005, and assorted |
12529 | newer versions. It is getting more and more difficult to get the | |
12530 | minimal prerequisites working on older perls. It is close to | |
12531 | impossible to get the whole Bundle::CPAN working there. If you're in | |
12532 | the position to have only these old versions, be advised that CPAN is | |
12533 | designed to work fine without the Bundle::CPAN installed. | |
12534 | ||
12535 | To get things going, note that GBARR/Scalar-List-Utils-1.18.tar.gz is | |
12536 | compatible with ancient perls and that File::Temp is listed as a | |
12537 | prerequisite but CPAN has reasonable workarounds if it is missing. | |
12538 | ||
12539 | =head2 CPANPLUS | |
12540 | ||
12541 | This module and its competitor, the CPANPLUS module, are both much | |
12542 | cooler than the other. CPAN.pm is older. CPANPLUS was designed to be | |
12543 | more modular but it was never tried to make it compatible with CPAN.pm. | |
09d9d230 | 12544 | |
ed84aac9 A |
12545 | =head1 SECURITY ADVICE |
12546 | ||
12547 | This software enables you to upgrade software on your computer and so | |
12548 | is inherently dangerous because the newly installed software may | |
12549 | contain bugs and may alter the way your computer works or even make it | |
12550 | unusable. Please consider backing up your data before every upgrade. | |
12551 | ||
b72dd56f SP |
12552 | =head1 BUGS |
12553 | ||
b03f445c | 12554 | Please report bugs via L<http://rt.cpan.org/> |
b72dd56f SP |
12555 | |
12556 | Before submitting a bug, please make sure that the traditional method | |
12557 | of building a Perl module package from a shell by following the | |
12558 | installation instructions of that package still works in your | |
12559 | environment. | |
12560 | ||
5f05dabc | 12561 | =head1 AUTHOR |
12562 | ||
e82b9348 | 12563 | Andreas Koenig C<< <andk@cpan.org> >> |
5f05dabc | 12564 | |
2ccf00a7 SP |
12565 | =head1 LICENSE |
12566 | ||
12567 | This program is free software; you can redistribute it and/or | |
12568 | modify it under the same terms as Perl itself. | |
12569 | ||
12570 | See L<http://www.perl.com/perl/misc/Artistic.html> | |
12571 | ||
c049f953 JH |
12572 | =head1 TRANSLATIONS |
12573 | ||
12574 | Kawai,Takanori provides a Japanese translation of this manpage at | |
b03f445c | 12575 | L<http://homepage3.nifty.com/hippo2000/perltips/CPAN.htm> |
c049f953 | 12576 | |
5f05dabc | 12577 | =head1 SEE ALSO |
12578 | ||
b03f445c | 12579 | L<cpan>, L<CPAN::Nox>, L<CPAN::Version> |
5f05dabc | 12580 | |
12581 | =cut | |
810a0276 SP |
12582 | |
12583 |