File Coverage

blib/lib/CPAN.pm
Criterion Covered Total %
statement 247 813 30.3
branch 51 394 12.9
condition 23 168 13.6
subroutine 63 107 58.8
pod 13 27 48.1
total 397 1509 26.3


line stmt bran cond sub pod time code
1             # -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*-
2             # vim: ts=4 sts=4 sw=4:
3 13     13   110312 use strict;
  13         84  
  13         1140  
4             package CPAN;
5             $CPAN::VERSION = '2.26';
6             $CPAN::VERSION =~ s/_//;
7              
8             # we need to run chdir all over and we would get at wrong libraries
9             # there
10 13     13   88 use File::Spec ();
  13         30  
  13         1278  
11             BEGIN {
12 13 50   13   326 if (File::Spec->can("rel2abs")) {
13 13         54 for my $inc (@INC) {
14 148 50       1866 $inc = File::Spec->rel2abs($inc) unless ref $inc;
15             }
16             }
17 13 50       794 $SIG{WINCH} = 'IGNORE' if exists $SIG{WINCH};
18             }
19 13     13   5592 use CPAN::Author;
  13         32  
  13         451  
20 13     13   6290 use CPAN::HandleConfig;
  13         40  
  13         479  
21 13     13   5073 use CPAN::Version;
  13         37  
  13         406  
22 13     13   5403 use CPAN::Bundle;
  13         56  
  13         441  
23 13     13   5608 use CPAN::CacheMgr;
  13         36  
  13         473  
24 13     13   5377 use CPAN::Complete;
  13         31  
  13         467  
25 13     13   100 use CPAN::Debug;
  13         29  
  13         260  
26 13     13   11515 use CPAN::Distribution;
  13         44  
  13         666  
27 13     13   6412 use CPAN::Distrostatus;
  13         37  
  13         704  
28 13     13   7211 use CPAN::FTP;
  13         39  
  13         574  
29 13     13   6254 use CPAN::Index 1.93; # https://rt.cpan.org/Ticket/Display.html?id=43349
  13         332  
  13         452  
30 13     13   93 use CPAN::InfoObj;
  13         25  
  13         267  
31 13     13   63 use CPAN::Module;
  13         118  
  13         274  
32 13     13   5174 use CPAN::Prompt;
  13         33  
  13         401  
33 13     13   4941 use CPAN::URL;
  13         34  
  13         410  
34 13     13   5094 use CPAN::Queue;
  13         33  
  13         410  
35 13     13   5789 use CPAN::Tarzip;
  13         35  
  13         525  
36 13     13   4942 use CPAN::DeferredCode;
  13         34  
  13         381  
37 13     13   8028 use CPAN::Shell;
  13         44  
  13         511  
38 13     13   5956 use CPAN::LWP::UserAgent;
  13         37  
  13         414  
39 13     13   5385 use CPAN::Exception::RecursiveDependency;
  13         33  
  13         408  
40 13     13   5113 use CPAN::Exception::yaml_not_installed;
  13         36  
  13         434  
41 13     13   5134 use CPAN::Exception::yaml_process_error;
  13         35  
  13         361  
42              
43 13     13   77 use Carp ();
  13         25  
  13         189  
44 13     13   52 use Config ();
  13         26  
  13         237  
45 13     13   59 use Cwd qw(chdir);
  13         22  
  13         629  
46 13     13   68 use DirHandle ();
  13         23  
  13         159  
47 13     13   56 use Exporter ();
  13         24  
  13         689  
48 13     13   9647 use ExtUtils::MakeMaker qw(prompt); # for some unknown reason,
  13         1298812  
  13         947  
49             # 5.005_04 does not work without
50             # this
51 13     13   111 use File::Basename ();
  13         40  
  13         210  
52 13     13   4728 use File::Copy ();
  13         23442  
  13         347  
53 13     13   87 use File::Find;
  13         22  
  13         782  
54 13     13   82 use File::Path ();
  13         26  
  13         206  
55 13     13   5207 use FileHandle ();
  13         96270  
  13         448  
56 13     13   88 use Fcntl qw(:flock);
  13         25  
  13         1742  
57 13     13   6762 use Safe ();
  13         476049  
  13         1113  
58 13     13   5701 use Sys::Hostname qw(hostname);
  13         13456  
  13         901  
59 13     13   5648 use Text::ParseWords ();
  13         15026  
  13         361  
60 13     13   5484 use Text::Wrap ();
  13         30382  
  13         705  
61              
62             # protect against "called too early"
63             sub find_perl ();
64             sub anycwd ();
65             sub _uniq;
66              
67 13     13   4965 no lib ".";
  13         6844  
  13         115  
68              
69             require Mac::BuildTools if $^O eq 'MacOS';
70             if ($ENV{PERL5_CPAN_IS_RUNNING} && $$ != $ENV{PERL5_CPAN_IS_RUNNING}) {
71             $ENV{PERL5_CPAN_IS_RUNNING_IN_RECURSION} ||= $ENV{PERL5_CPAN_IS_RUNNING};
72             my @rec = _uniq split(/,/, $ENV{PERL5_CPAN_IS_RUNNING_IN_RECURSION}), $$;
73             $ENV{PERL5_CPAN_IS_RUNNING_IN_RECURSION} = join ",", @rec;
74             # warn "# Note: Recursive call of CPAN.pm detected\n";
75             my $w = sprintf "# Note: CPAN.pm is running in process %d now", pop @rec;
76             my %sleep = (
77             5 => 30,
78             6 => 60,
79             7 => 120,
80             );
81             my $sleep = @rec > 7 ? 300 : ($sleep{scalar @rec}||0);
82             my $verbose = @rec >= 4;
83             while (@rec) {
84             $w .= sprintf " which has been called by process %d", pop @rec;
85             }
86             if ($sleep) {
87             $w .= ".\n\n# Sleeping $sleep seconds to protect other processes\n";
88             }
89             if ($verbose) {
90             warn $w;
91             }
92             local $| = 1;
93             my $have_been_sleeping = 0;
94             while ($sleep > 0) {
95             printf "\r#%5d", --$sleep;
96             sleep 1;
97             ++$have_been_sleeping;
98             }
99             print "\n" if $have_been_sleeping;
100             }
101             $ENV{PERL5_CPAN_IS_RUNNING}=$$;
102             $ENV{PERL5_CPANPLUS_IS_RUNNING}=$$; # https://rt.cpan.org/Ticket/Display.html?id=23735
103              
104 13     13   5994721 END { $CPAN::End++; &cleanup; }
  13         90  
105              
106             $CPAN::Signal ||= 0;
107             $CPAN::Frontend ||= "CPAN::Shell";
108             unless (@CPAN::Defaultsites) {
109             @CPAN::Defaultsites = map {
110             CPAN::URL->new(TEXT => $_, FROM => "DEF")
111             }
112             "http://www.perl.org/CPAN/",
113             "ftp://ftp.perl.org/pub/CPAN/";
114             }
115             # $CPAN::iCwd (i for initial)
116             $CPAN::iCwd ||= CPAN::anycwd();
117             $CPAN::Perl ||= CPAN::find_perl();
118             $CPAN::Defaultdocs ||= "http://search.cpan.org/perldoc?";
119             $CPAN::Defaultrecent ||= "http://search.cpan.org/uploads.rdf";
120             $CPAN::Defaultrecent ||= "http://cpan.uwinnipeg.ca/htdocs/cpan.xml";
121              
122             # our globals are getting a mess
123 13         17757 use vars qw(
124             $AUTOLOAD
125             $Be_Silent
126             $CONFIG_DIRTY
127             $Defaultdocs
128             $Echo_readline
129             $Frontend
130             $GOTOSHELL
131             $HAS_USABLE
132             $Have_warned
133             $MAX_RECURSION
134             $META
135             $RUN_DEGRADED
136             $Signal
137             $SQLite
138             $Suppress_readline
139             $VERSION
140             $autoload_recursion
141             $term
142             @Defaultsites
143             @EXPORT
144 13     13   5473 );
  13         31  
145              
146             $MAX_RECURSION = 32;
147              
148             @CPAN::ISA = qw(CPAN::Debug Exporter);
149              
150             # note that these functions live in CPAN::Shell and get executed via
151             # AUTOLOAD when called directly
152             @EXPORT = qw(
153             autobundle
154             bundle
155             clean
156             cvs_import
157             expand
158             force
159             fforce
160             get
161             install
162             install_tested
163             is_tested
164             make
165             mkmyconfig
166             notest
167             perldoc
168             readme
169             recent
170             recompile
171             report
172             shell
173             smoke
174             test
175             upgrade
176             );
177              
178             sub soft_chdir_with_alternatives ($);
179              
180             {
181             $autoload_recursion ||= 0;
182              
183             #-> sub CPAN::AUTOLOAD ;
184             sub AUTOLOAD { ## no critic
185 1     1   20 $autoload_recursion++;
186 1         8 my($l) = $AUTOLOAD;
187 1         13 $l =~ s/.*:://;
188 1 50       15 if ($CPAN::Signal) {
189 0         0 warn "Refusing to autoload '$l' while signal pending";
190 0         0 $autoload_recursion--;
191 0         0 return;
192             }
193 1 50       5 if ($autoload_recursion > 1) {
194 0         0 my $fullcommand = join " ", map { "'$_'" } $l, @_;
  0         0  
195 0         0 warn "Refusing to autoload $fullcommand in recursion\n";
196 0         0 $autoload_recursion--;
197 0         0 return;
198             }
199 1         3 my(%export);
200 1         76 @export{@EXPORT} = '';
201 1 50       41 CPAN::HandleConfig->load unless $CPAN::Config_loaded++;
202 1 50       4 if (exists $export{$l}) {
203 0         0 CPAN::Shell->$l(@_);
204             } else {
205 1         12 die(qq{Unknown CPAN command "$AUTOLOAD". }.
206             qq{Type ? for help.\n});
207             }
208 0         0 $autoload_recursion--;
209             }
210             }
211              
212             {
213             my $x = *SAVEOUT; # avoid warning
214             open($x,">&STDOUT") or die "dup failed";
215             my $redir = 0;
216             sub _redirect(@) {
217             #die if $redir;
218 0     0   0 local $_;
219 0         0 push(@_,undef);
220 0         0 while(defined($_=shift)) {
221 0 0       0 if (s/^\s*>//){
    0          
222 0 0       0 my ($m) = s/^>// ? ">" : "";
223 0         0 s/\s+//;
224 0 0       0 $_=shift unless length;
225 0 0       0 die "no dest" unless defined;
226 0 0       0 open(STDOUT,">$m$_") or die "open:$_:$!\n";
227 0         0 $redir=1;
228             } elsif ( s/^\s*\|\s*// ) {
229 0         0 my $pipe="| $_";
230 0         0 while(defined($_[0])){
231 0         0 $pipe .= ' ' . shift;
232             }
233 0 0       0 open(STDOUT,$pipe) or die "open:$pipe:$!\n";
234 0         0 $redir=1;
235             } else {
236 0         0 push(@_,$_);
237             }
238             }
239 0         0 return @_;
240             }
241             sub _unredirect {
242 0 0   0   0 return unless $redir;
243 0         0 $redir = 0;
244             ## redirect: unredirect and propagate errors. explicit close to wait for pipe.
245 0         0 close(STDOUT);
246 0         0 open(STDOUT,">&SAVEOUT");
247 0 0       0 die "$@" if "$@";
248             ## redirect: done
249             }
250             }
251              
252             sub _uniq {
253 0     0   0 my(@list) = @_;
254 0         0 my %seen;
255 0         0 return grep { !$seen{$_}++ } @list;
  0         0  
256             }
257              
258             #-> sub CPAN::shell ;
259             sub shell {
260 0     0 1 0 my($self) = @_;
261 0 0       0 $Suppress_readline = ! -t STDIN unless defined $Suppress_readline;
262 0 0       0 CPAN::HandleConfig->load unless $CPAN::Config_loaded++;
263              
264 0   0     0 my $oprompt = shift || CPAN::Prompt->new;
265 0         0 my $prompt = $oprompt;
266 0   0     0 my $commandline = shift || "";
267 0   0     0 $CPAN::CurrentCommandId ||= 1;
268              
269 0         0 local($^W) = 1;
270 0 0       0 unless ($Suppress_readline) {
271 0         0 require Term::ReadLine;
272 0 0 0     0 if (! $term
273             or
274             $term->ReadLine eq "Term::ReadLine::Stub"
275             ) {
276 0         0 $term = Term::ReadLine->new('CPAN Monitor');
277             }
278 0 0       0 if ($term->ReadLine eq "Term::ReadLine::Gnu") {
279 0         0 my $attribs = $term->Attribs;
280             $attribs->{attempted_completion_function} = sub {
281 0     0   0 &CPAN::Complete::gnu_cpl;
282             }
283 0         0 } else {
284 0         0 $readline::rl_completion_function =
285             $readline::rl_completion_function = 'CPAN::Complete::cpl';
286             }
287 0 0       0 if (my $histfile = $CPAN::Config->{'histfile'}) {{
288 0 0       0 unless ($term->can("AddHistory")) {
  0         0  
289 0         0 $CPAN::Frontend->mywarn("Terminal does not support AddHistory.\n");
290 0 0       0 unless ($CPAN::META->has_inst('Term::ReadLine::Perl')) {
291 0         0 $CPAN::Frontend->mywarn("\nTo fix that, maybe try> install Term::ReadLine::Perl\n\n");
292             }
293 0         0 last;
294             }
295 0         0 $META->readhist($term,$histfile);
296             }}
297 0         0 for ($CPAN::Config->{term_ornaments}) { # alias
298 0         0 local $Term::ReadLine::termcap_nowarn = 1;
299 0 0       0 $term->ornaments($_) if defined;
300             }
301             # $term->OUT is autoflushed anyway
302 0         0 my $odef = select STDERR;
303 0         0 $| = 1;
304 0         0 select STDOUT;
305 0         0 $| = 1;
306 0         0 select $odef;
307             }
308              
309 0         0 $META->checklock();
310 0 0       0 my @cwd = grep { defined $_ and length $_ }
  0 0       0  
311             CPAN::anycwd(),
312             File::Spec->can("tmpdir") ? File::Spec->tmpdir() : (),
313             File::Spec->rootdir();
314 0         0 my $try_detect_readline;
315 0 0       0 $try_detect_readline = $term->ReadLine eq "Term::ReadLine::Stub" if $term;
316 0 0       0 unless ($CPAN::Config->{inhibit_startup_message}) {
317 0 0       0 my $rl_avail = $Suppress_readline ? "suppressed" :
    0          
318             ($term->ReadLine ne "Term::ReadLine::Stub") ? "enabled" :
319             "available (maybe install Bundle::CPAN or Bundle::CPANxxl?)";
320 0         0 $CPAN::Frontend->myprint(
321             sprintf qq{
322             cpan shell -- CPAN exploration and modules installation (v%s)
323             Enter 'h' for help.
324              
325             },
326             $CPAN::VERSION,
327             )
328             }
329 0         0 my($continuation) = "";
330 0         0 my $last_term_ornaments;
331 0         0 SHELLCOMMAND: while () {
332 0 0       0 if ($Suppress_readline) {
333 0 0       0 if ($Echo_readline) {
334 0         0 $|=1;
335             }
336 0         0 print $prompt;
337 0 0       0 last SHELLCOMMAND unless defined ($_ = <> );
338 0 0       0 if ($Echo_readline) {
339             # backdoor: I could not find a way to record sessions
340 0         0 print $_;
341             }
342 0         0 chomp;
343             } else {
344             last SHELLCOMMAND unless
345 0 0       0 defined ($_ = $term->readline($prompt, $commandline));
346             }
347 0 0       0 $_ = "$continuation$_" if $continuation;
348 0         0 s/^\s+//;
349 0 0       0 next SHELLCOMMAND if /^$/;
350 0         0 s/^\s*\?\s*/help /;
351 0 0       0 if (/^(?:q(?:uit)?|bye|exit)\s*$/i) {
    0          
    0          
    0          
352 0         0 last SHELLCOMMAND;
353             } elsif (s/\\$//s) {
354 0         0 chomp;
355 0         0 $continuation = $_;
356 0         0 $prompt = " > ";
357             } elsif (/^\!/) {
358 0         0 s/^\!//;
359 0         0 my($eval) = $_;
360             package
361             CPAN::Eval; # hide from the indexer
362 13     13   109 use strict;
  13         38  
  13         379  
363 13     13   76 use vars qw($import_done);
  13         31  
  13         16078  
364 0 0       0 CPAN->import(':DEFAULT') unless $import_done++;
365 0 0       0 CPAN->debug("eval[$eval]") if $CPAN::DEBUG;
366 0         0 eval($eval);
367 0 0       0 warn $@ if $@;
368 0         0 $continuation = "";
369 0         0 $prompt = $oprompt;
370             } elsif (/./) {
371 0         0 my(@line);
372 0         0 eval { @line = Text::ParseWords::shellwords($_) };
  0         0  
373 0 0       0 warn($@), next SHELLCOMMAND if $@;
374 0 0       0 warn("Text::Parsewords could not parse the line [$_]"),
375             next SHELLCOMMAND unless @line;
376 0 0       0 $CPAN::META->debug("line[".join("|",@line)."]") if $CPAN::DEBUG;
377 0         0 my $command = shift @line;
378 0         0 eval {
379 0         0 local (*STDOUT)=*STDOUT;
380 0         0 @line = _redirect(@line);
381 0         0 CPAN::Shell->$command(@line)
382             };
383 0         0 my $command_error = $@;
384 0         0 _unredirect;
385 0         0 my $reported_error;
386 0 0       0 if ($command_error) {
387 0         0 my $err = $command_error;
388 0 0 0     0 if (ref $err and $err->isa('CPAN::Exception::blocked_urllist')) {
389 0         0 $CPAN::Frontend->mywarn("Client not fully configured, please proceed with configuring.$err");
390 0         0 $reported_error = ref $err;
391             } else {
392             # I'd prefer never to arrive here and make all errors exception objects
393 0 0       0 if ($err =~ /\S/) {
394 0         0 require Carp;
395 0         0 require Dumpvalue;
396 0         0 my $dv = Dumpvalue->new(tick => '"');
397 0         0 Carp::cluck(sprintf "Catching error: %s", $dv->stringify($err));
398             }
399             }
400             }
401 0 0       0 if ($command =~ /^(
402             # classic commands
403             make
404             |test
405             |install
406             |clean
407              
408             # pragmas for classic commands
409             |ff?orce
410             |notest
411              
412             # compounds
413             |report
414             |smoke
415             |upgrade
416             )$/x) {
417             # only commands that tell us something about failed distros
418             # eval necessary for people without an urllist
419 0         0 eval {CPAN::Shell->failed($CPAN::CurrentCommandId,1);};
  0         0  
420 0 0       0 if (my $err = $@) {
421 0 0 0     0 unless (ref $err and $reported_error eq ref $err) {
422 0         0 die $@;
423             }
424             }
425             }
426 0         0 soft_chdir_with_alternatives(\@cwd);
427 0         0 $CPAN::Frontend->myprint("\n");
428 0         0 $continuation = "";
429 0         0 $CPAN::CurrentCommandId++;
430 0         0 $prompt = $oprompt;
431             }
432             } continue {
433 0         0 $commandline = ""; # I do want to be able to pass a default to
434             # shell, but on the second command I see no
435             # use in that
436 0         0 $Signal=0;
437 0         0 CPAN::Queue->nullify_queue;
438 0 0       0 if ($try_detect_readline) {
439 0 0 0     0 if ($CPAN::META->has_inst("Term::ReadLine::Gnu")
440             ||
441             $CPAN::META->has_inst("Term::ReadLine::Perl")
442             ) {
443 0         0 delete $INC{"Term/ReadLine.pm"};
444 0         0 my $redef = 0;
445 0         0 local($SIG{__WARN__}) = CPAN::Shell::paintdots_onreload(\$redef);
446 0         0 require Term::ReadLine;
447 0         0 $CPAN::Frontend->myprint("\n$redef subroutines in ".
448             "Term::ReadLine redefined\n");
449 0         0 $GOTOSHELL = 1;
450             }
451             }
452 0 0 0     0 if ($term and $term->can("ornaments")) {
453 0         0 for ($CPAN::Config->{term_ornaments}) { # alias
454 0 0       0 if (defined $_) {
455 0 0 0     0 if (not defined $last_term_ornaments
456             or $_ != $last_term_ornaments
457             ) {
458 0         0 local $Term::ReadLine::termcap_nowarn = 1;
459 0         0 $term->ornaments($_);
460 0         0 $last_term_ornaments = $_;
461             }
462             } else {
463 0         0 undef $last_term_ornaments;
464             }
465             }
466             }
467 0         0 for my $class (qw(Module Distribution)) {
468             # again unsafe meta access?
469 0         0 for my $dm (sort keys %{$CPAN::META->{readwrite}{"CPAN::$class"}}) {
  0         0  
470 0 0       0 next unless $CPAN::META->{readwrite}{"CPAN::$class"}{$dm}{incommandcolor};
471 0         0 CPAN->debug("BUG: $class '$dm' was in command state, resetting");
472 0         0 delete $CPAN::META->{readwrite}{"CPAN::$class"}{$dm}{incommandcolor};
473             }
474             }
475 0 0       0 if ($GOTOSHELL) {
476 0         0 $GOTOSHELL = 0; # not too often
477 0 0 0     0 $META->savehist if $CPAN::term && $CPAN::term->can("GetHistory");
478 0         0 @_ = ($oprompt,"");
479 0         0 goto &shell;
480             }
481             }
482 0         0 soft_chdir_with_alternatives(\@cwd);
483             }
484              
485             #-> CPAN::soft_chdir_with_alternatives ;
486             sub soft_chdir_with_alternatives ($) {
487 0     0 0 0 my($cwd) = @_;
488 0 0       0 unless (@$cwd) {
489 0         0 my $root = File::Spec->rootdir();
490 0         0 $CPAN::Frontend->mywarn(qq{Warning: no good directory to chdir to!
491             Trying '$root' as temporary haven.
492             });
493 0         0 push @$cwd, $root;
494             }
495 0         0 while () {
496 0 0       0 if (chdir "$cwd->[0]") {
497 0         0 return;
498             } else {
499 0 0       0 if (@$cwd>1) {
500 0         0 $CPAN::Frontend->mywarn(qq{Could not chdir to "$cwd->[0]": $!
501             Trying to chdir to "$cwd->[1]" instead.
502             });
503 0         0 shift @$cwd;
504             } else {
505 0         0 $CPAN::Frontend->mydie(qq{Could not chdir to "$cwd->[0]": $!});
506             }
507             }
508             }
509             }
510              
511             sub _flock {
512 0     0   0 my($fh,$mode) = @_;
513 0 0 0     0 if ( $Config::Config{d_flock} || $Config::Config{d_fcntl_can_lock} ) {
    0          
514 0         0 return flock $fh, $mode;
515             } elsif (!$Have_warned->{"d_flock"}++) {
516 0         0 $CPAN::Frontend->mywarn("Your OS does not seem to support locking; continuing and ignoring all locking issues\n");
517 0         0 $CPAN::Frontend->mysleep(5);
518 0         0 return 1;
519             } else {
520 0         0 return 1;
521             }
522             }
523              
524             sub _yaml_module () {
525 3   50 3   16 my $yaml_module = $CPAN::Config->{yaml_module} || "YAML";
526 3 50 33     13 if (
527             $yaml_module ne "YAML"
528             &&
529             !$CPAN::META->has_inst($yaml_module)
530             ) {
531             # $CPAN::Frontend->mywarn("'$yaml_module' not installed, falling back to 'YAML'\n");
532 0         0 $yaml_module = "YAML";
533             }
534 3 0 33     13 if ($yaml_module eq "YAML"
      33        
      33        
535             &&
536             $CPAN::META->has_inst($yaml_module)
537             &&
538             $YAML::VERSION < 0.60
539             &&
540             !$Have_warned->{"YAML"}++
541             ) {
542 0         0 $CPAN::Frontend->mywarn("Warning: YAML version '$YAML::VERSION' is too low, please upgrade!\n".
543             "I'll continue but problems are *very* likely to happen.\n"
544             );
545 0         0 $CPAN::Frontend->mysleep(5);
546             }
547 3         10 return $yaml_module;
548             }
549              
550             # CPAN::_yaml_loadfile
551             sub _yaml_loadfile {
552 0     0   0 my($self,$local_file) = @_;
553 0 0       0 return +[] unless -s $local_file;
554 0         0 my $yaml_module = _yaml_module;
555 0 0       0 if ($CPAN::META->has_inst($yaml_module)) {
556             # temporarily enable yaml code deserialisation
557 13     13   113 no strict 'refs';
  13         33  
  13         50410  
558             # 5.6.2 could not do the local() with the reference
559             # so we do it manually instead
560 0         0 my $old_loadcode = ${"$yaml_module\::LoadCode"};
  0         0  
561 0   0     0 ${ "$yaml_module\::LoadCode" } = $CPAN::Config->{yaml_load_code} || 0;
  0         0  
562              
563 0         0 my ($code, @yaml);
564 0 0       0 if ($code = UNIVERSAL::can($yaml_module, "LoadFile")) {
    0          
565 0         0 eval { @yaml = $code->($local_file); };
  0         0  
566 0 0       0 if ($@) {
567             # this shall not be done by the frontend
568 0         0 die CPAN::Exception::yaml_process_error->new($yaml_module,$local_file,"parse",$@);
569             }
570             } elsif ($code = UNIVERSAL::can($yaml_module, "Load")) {
571 0         0 local *FH;
572 0 0       0 unless (open FH, $local_file) {
573 0         0 $CPAN::Frontend->mywarn("Could not open '$local_file': $!");
574 0         0 return +[];
575             }
576 0         0 local $/;
577 0         0 my $ystream = ;
578 0         0 eval { @yaml = $code->($ystream); };
  0         0  
579 0 0       0 if ($@) {
580             # this shall not be done by the frontend
581 0         0 die CPAN::Exception::yaml_process_error->new($yaml_module,$local_file,"parse",$@);
582             }
583             }
584 0         0 ${"$yaml_module\::LoadCode"} = $old_loadcode;
  0         0  
585 0         0 return \@yaml;
586             } else {
587             # this shall not be done by the frontend
588 0         0 die CPAN::Exception::yaml_not_installed->new($yaml_module, $local_file, "parse");
589             }
590 0         0 return +[];
591             }
592              
593             # CPAN::_yaml_dumpfile
594             sub _yaml_dumpfile {
595 0     0   0 my($self,$local_file,@what) = @_;
596 0         0 my $yaml_module = _yaml_module;
597 0 0       0 if ($CPAN::META->has_inst($yaml_module)) {
598 0         0 my $code;
599 0 0       0 if (UNIVERSAL::isa($local_file, "FileHandle")) {
    0          
    0          
600 0         0 $code = UNIVERSAL::can($yaml_module, "Dump");
601 0         0 eval { print $local_file $code->(@what) };
  0         0  
602             } elsif ($code = UNIVERSAL::can($yaml_module, "DumpFile")) {
603 0         0 eval { $code->($local_file,@what); };
  0         0  
604             } elsif ($code = UNIVERSAL::can($yaml_module, "Dump")) {
605 0         0 local *FH;
606 0 0       0 open FH, ">$local_file" or die "Could not open '$local_file': $!";
607 0         0 print FH $code->(@what);
608             }
609 0 0       0 if ($@) {
610 0         0 die CPAN::Exception::yaml_process_error->new($yaml_module,$local_file,"dump",$@);
611             }
612             } else {
613 0 0       0 if (UNIVERSAL::isa($local_file, "FileHandle")) {
614             # I think this case does not justify a warning at all
615             } else {
616 0         0 die CPAN::Exception::yaml_not_installed->new($yaml_module, $local_file, "dump");
617             }
618             }
619             }
620              
621             sub _init_sqlite () {
622 0 0   0   0 unless ($CPAN::META->has_inst("CPAN::SQLite")) {
623             $CPAN::Frontend->mywarn(qq{CPAN::SQLite not installed, trying to work without\n})
624 0 0       0 unless $Have_warned->{"CPAN::SQLite"}++;
625 0         0 return;
626             }
627 0         0 require CPAN::SQLite::META; # not needed since CVS version of 2006-12-17
628 0   0     0 $CPAN::SQLite ||= CPAN::SQLite::META->new($CPAN::META);
629             }
630              
631             {
632             my $negative_cache = {};
633             sub _sqlite_running {
634 130 100 66 130   396 if ($negative_cache->{time} && time < $negative_cache->{time} + 60) {
635             # need to cache the result, otherwise too slow
636 129         299 return $negative_cache->{fact};
637             } else {
638 1         4 $negative_cache = {}; # reset
639             }
640 1   33     5 my $ret = $CPAN::Config->{use_sqlite} && ($CPAN::SQLite || _init_sqlite());
641 1 50       3 return $ret if $ret; # fast anyway
642 1         8 $negative_cache->{time} = time;
643 1         6 return $negative_cache->{fact} = $ret;
644             }
645             }
646              
647             $META ||= CPAN->new; # In case we re-eval ourselves we need the ||
648              
649             # from here on only subs.
650             ################################################################################
651              
652             sub _perl_fingerprint {
653 0     0   0 my($self,$other_fingerprint) = @_;
654 0         0 my $dll = eval {OS2::DLLname()};
  0         0  
655 0         0 my $mtime_dll = 0;
656 0 0       0 if (defined $dll) {
657 0 0       0 $mtime_dll = (-f $dll ? (stat(_))[9] : '-1');
658             }
659 0 0       0 my $mtime_perl = (-f CPAN::find_perl ? (stat(_))[9] : '-1');
660             my $this_fingerprint = {
661             '$^X' => CPAN::find_perl,
662             sitearchexp => $Config::Config{sitearchexp},
663 0         0 'mtime_$^X' => $mtime_perl,
664             'mtime_dll' => $mtime_dll,
665             };
666 0 0       0 if ($other_fingerprint) {
667 0 0       0 if (exists $other_fingerprint->{'stat($^X)'}) { # repair fp from rev. 1.88_57
668 0         0 $other_fingerprint->{'mtime_$^X'} = $other_fingerprint->{'stat($^X)'}[9];
669             }
670             # mandatory keys since 1.88_57
671 0         0 for my $key (qw($^X sitearchexp mtime_dll mtime_$^X)) {
672 0 0       0 return unless $other_fingerprint->{$key} eq $this_fingerprint->{$key};
673             }
674 0         0 return 1;
675             } else {
676 0         0 return $this_fingerprint;
677             }
678             }
679              
680             sub suggest_myconfig () {
681 0 0   0 0 0 SUGGEST_MYCONFIG: if(!$INC{'CPAN/MyConfig.pm'}) {
682 0         0 $CPAN::Frontend->myprint("You don't seem to have a user ".
683             "configuration (MyConfig.pm) yet.\n");
684 0         0 my $new = CPAN::Shell::colorable_makemaker_prompt("Do you want to create a ".
685             "user configuration now? (Y/n)",
686             "yes");
687 0 0       0 if($new =~ m{^y}i) {
688 0         0 CPAN::Shell->mkmyconfig();
689 0         0 return &checklock;
690             } else {
691 0         0 $CPAN::Frontend->mydie("OK, giving up.");
692             }
693             }
694             }
695              
696             #-> sub CPAN::all_objects ;
697             sub all_objects {
698 0     0 0 0 my($mgr,$class) = @_;
699 0 0       0 CPAN::HandleConfig->load unless $CPAN::Config_loaded++;
700 0 0       0 CPAN->debug("mgr[$mgr] class[$class]") if $CPAN::DEBUG;
701 0         0 CPAN::Index->reload;
702 0         0 values %{ $META->{readwrite}{$class} }; # unsafe meta access, ok
  0         0  
703             }
704              
705             # Called by shell, not in batch mode. In batch mode I see no risk in
706             # having many processes updating something as installations are
707             # continually checked at runtime. In shell mode I suspect it is
708             # unintentional to open more than one shell at a time
709              
710             #-> sub CPAN::checklock ;
711             sub checklock {
712 0     0 0 0 my($self) = @_;
713 0         0 my $lockfile = File::Spec->catfile($CPAN::Config->{cpan_home},".lock");
714 0 0 0     0 if (-f $lockfile && -M _ > 0) {
715 0 0       0 my $fh = FileHandle->new($lockfile) or
716             $CPAN::Frontend->mydie("Could not open lockfile '$lockfile': $!");
717 0         0 my $otherpid = <$fh>;
718 0         0 my $otherhost = <$fh>;
719 0         0 $fh->close;
720 0 0 0     0 if (defined $otherpid && length $otherpid) {
721 0         0 chomp $otherpid;
722             }
723 0 0 0     0 if (defined $otherhost && length $otherhost) {
724 0         0 chomp $otherhost;
725             }
726 0         0 my $thishost = hostname();
727 0         0 my $ask_if_degraded_wanted = 0;
728 0 0 0     0 if (defined $otherhost && defined $thishost &&
    0 0        
    0 0        
    0 0        
      0        
729             $otherhost ne '' && $thishost ne '' &&
730             $otherhost ne $thishost) {
731 0         0 $CPAN::Frontend->mydie(sprintf("CPAN.pm panic: Lockfile '$lockfile'\n".
732             "reports other host $otherhost and other ".
733             "process $otherpid.\n".
734             "Cannot proceed.\n"));
735             } elsif ($RUN_DEGRADED) {
736 0         0 $CPAN::Frontend->mywarn("Running in downgraded mode (experimental)\n");
737             } elsif (defined $otherpid && $otherpid) {
738 0 0       0 return if $$ == $otherpid; # should never happen
739 0         0 $CPAN::Frontend->mywarn(
740             qq{
741             There seems to be running another CPAN process (pid $otherpid). Contacting...
742             });
743 0 0 0     0 if (kill 0, $otherpid or $!{EPERM}) {
    0          
744 0         0 $CPAN::Frontend->mywarn(qq{Other job is running.\n});
745 0         0 $ask_if_degraded_wanted = 1;
746             } elsif (-w $lockfile) {
747 0         0 my($ans) =
748             CPAN::Shell::colorable_makemaker_prompt
749             (qq{Other job not responding. Shall I overwrite }.
750             qq{the lockfile '$lockfile'? (Y/n)},"y");
751 0 0       0 $CPAN::Frontend->myexit("Ok, bye\n")
752             unless $ans =~ /^y/i;
753             } else {
754 0         0 Carp::croak(
755             qq{Lockfile '$lockfile' not writable by you. }.
756             qq{Cannot proceed.\n}.
757             qq{ On UNIX try:\n}.
758             qq{ rm '$lockfile'\n}.
759             qq{ and then rerun us.\n}
760             );
761             }
762             } elsif ($^O eq "MSWin32") {
763 0         0 $CPAN::Frontend->mywarn(
764             qq{
765             There seems to be running another CPAN process according to '$lockfile'.
766             });
767 0         0 $ask_if_degraded_wanted = 1;
768             } else {
769 0         0 $CPAN::Frontend->mydie(sprintf("CPAN.pm panic: Found invalid lockfile ".
770             "'$lockfile', please remove. Cannot proceed.\n"));
771             }
772 0 0       0 if ($ask_if_degraded_wanted) {
773 0         0 my($ans) =
774             CPAN::Shell::colorable_makemaker_prompt
775             (qq{Shall I try to run in downgraded }.
776             qq{mode? (Y/n)},"y");
777 0 0       0 if ($ans =~ /^y/i) {
778 0         0 $CPAN::Frontend->mywarn("Running in downgraded mode (experimental).
779             Please report if something unexpected happens\n");
780 0         0 $RUN_DEGRADED = 1;
781 0         0 for ($CPAN::Config) {
782             # XXX
783             # $_->{build_dir_reuse} = 0; # 2006-11-17 akoenig Why was that?
784 0         0 $_->{commandnumber_in_prompt} = 0; # visibility
785 0         0 $_->{histfile} = ""; # who should win otherwise?
786 0         0 $_->{cache_metadata} = 0; # better would be a lock?
787 0         0 $_->{use_sqlite} = 0; # better would be a write lock!
788 0         0 $_->{auto_commit} = 0; # we are violent, do not persist
789 0         0 $_->{test_report} = 0; # Oliver Paukstadt had sent wrong reports in degraded mode
790             }
791             } else {
792 0         0 my $msg = "You may want to kill the other job and delete the lockfile.";
793 0 0       0 if (defined $otherpid) {
794 0         0 $msg .= " Something like:
795             kill $otherpid
796             rm $lockfile
797             ";
798             }
799 0         0 $CPAN::Frontend->mydie("\n$msg");
800             }
801             }
802             }
803 0         0 my $dotcpan = $CPAN::Config->{cpan_home};
804 0         0 eval { File::Path::mkpath($dotcpan);};
  0         0  
805 0 0       0 if ($@) {
806             # A special case at least for Jarkko.
807 0         0 my $firsterror = $@;
808 0         0 my $seconderror;
809             my $symlinkcpan;
810 0 0       0 if (-l $dotcpan) {
811 0         0 $symlinkcpan = readlink $dotcpan;
812 0 0       0 die "readlink $dotcpan failed: $!" unless defined $symlinkcpan;
813 0         0 eval { File::Path::mkpath($symlinkcpan); };
  0         0  
814 0 0       0 if ($@) {
815 0         0 $seconderror = $@;
816             } else {
817 0         0 $CPAN::Frontend->mywarn(qq{
818             Working directory $symlinkcpan created.
819             });
820             }
821             }
822 0 0       0 unless (-d $dotcpan) {
823 0         0 my $mess = qq{
824             Your configuration suggests "$dotcpan" as your
825             CPAN.pm working directory. I could not create this directory due
826             to this error: $firsterror\n};
827 0 0       0 $mess .= qq{
828             As "$dotcpan" is a symlink to "$symlinkcpan",
829             I tried to create that, but I failed with this error: $seconderror
830             } if $seconderror;
831 0         0 $mess .= qq{
832             Please make sure the directory exists and is writable.
833             };
834 0         0 $CPAN::Frontend->mywarn($mess);
835 0         0 return suggest_myconfig;
836             }
837             } # $@ after eval mkpath $dotcpan
838 0         0 if (0) { # to test what happens when a race condition occurs
839             for (reverse 1..10) {
840             print $_, "\n";
841             sleep 1;
842             }
843             }
844             # locking
845 0 0 0     0 if (!$RUN_DEGRADED && !$self->{LOCKFH}) {
846 0         0 my $fh;
847 0 0       0 unless ($fh = FileHandle->new("+>>$lockfile")) {
848 0         0 $CPAN::Frontend->mywarn(qq{
849              
850             Your configuration suggests that CPAN.pm should use a working
851             directory of
852             $CPAN::Config->{cpan_home}
853             Unfortunately we could not create the lock file
854             $lockfile
855             due to '$!'.
856              
857             Please make sure that the configuration variable
858             \$CPAN::Config->{cpan_home}
859             points to a directory where you can write a .lock file. You can set
860             this variable in either a CPAN/MyConfig.pm or a CPAN/Config.pm in your
861             \@INC path;
862             });
863 0         0 return suggest_myconfig;
864             }
865 0         0 my $sleep = 1;
866 0         0 while (!CPAN::_flock($fh, LOCK_EX|LOCK_NB)) {
867 0   0     0 my $err = $! || "unknown error";
868 0 0       0 if ($sleep>3) {
869 0         0 $CPAN::Frontend->mydie("Could not lock '$lockfile' with flock: $err; giving up\n");
870             }
871 0         0 $CPAN::Frontend->mysleep($sleep+=0.1);
872 0         0 $CPAN::Frontend->mywarn("Could not lock '$lockfile' with flock: $err; retrying\n");
873             }
874              
875 0         0 seek $fh, 0, 0;
876 0         0 truncate $fh, 0;
877 0         0 $fh->autoflush(1);
878 0         0 $fh->print($$, "\n");
879 0         0 $fh->print(hostname(), "\n");
880 0         0 $self->{LOCK} = $lockfile;
881 0         0 $self->{LOCKFH} = $fh;
882             }
883             $SIG{TERM} = sub {
884 0     0   0 my $sig = shift;
885 0         0 &cleanup;
886 0         0 $CPAN::Frontend->mydie("Got SIG$sig, leaving");
887 0         0 };
888             $SIG{INT} = sub {
889             # no blocks!!!
890 0     0   0 my $sig = shift;
891 0 0       0 &cleanup if $Signal;
892 0 0       0 die "Got yet another signal" if $Signal > 1;
893 0 0       0 $CPAN::Frontend->mydie("Got another SIG$sig") if $Signal;
894 0         0 $CPAN::Frontend->mywarn("Caught SIG$sig, trying to continue\n");
895 0         0 $Signal++;
896 0         0 };
897              
898             # From: Larry Wall
899             # Subject: Re: deprecating SIGDIE
900             # To: perl5-porters@perl.org
901             # Date: Thu, 30 Sep 1999 14:58:40 -0700 (PDT)
902             #
903             # The original intent of __DIE__ was only to allow you to substitute one
904             # kind of death for another on an application-wide basis without respect
905             # to whether you were in an eval or not. As a global backstop, it should
906             # not be used any more lightly (or any more heavily :-) than class
907             # UNIVERSAL. Any attempt to build a general exception model on it should
908             # be politely squashed. Any bug that causes every eval {} to have to be
909             # modified should be not so politely squashed.
910             #
911             # Those are my current opinions. It is also my opinion that polite
912             # arguments degenerate to personal arguments far too frequently, and that
913             # when they do, it's because both people wanted it to, or at least didn't
914             # sufficiently want it not to.
915             #
916             # Larry
917              
918             # global backstop to cleanup if we should really die
919 0         0 $SIG{__DIE__} = \&cleanup;
920 0 0       0 $self->debug("Signal handler set.") if $CPAN::DEBUG;
921             }
922              
923             #-> sub CPAN::DESTROY ;
924             sub DESTROY {
925 0     0   0 &cleanup; # need an eval?
926             }
927              
928             #-> sub CPAN::anycwd ;
929             sub anycwd () {
930 13     13 1 31 my $getcwd;
931 13   100     82 $getcwd = $CPAN::Config->{'getcwd'} || 'cwd';
932 13         79 CPAN->$getcwd();
933             }
934              
935             #-> sub CPAN::cwd ;
936 13     13 1 47203 sub cwd {Cwd::cwd();}
937              
938             #-> sub CPAN::getcwd ;
939 0     0 1 0 sub getcwd {Cwd::getcwd();}
940              
941             #-> sub CPAN::fastcwd ;
942 0     0 1 0 sub fastcwd {Cwd::fastcwd();}
943              
944             #-> sub CPAN::getdcwd ;
945 0     0 1 0 sub getdcwd {Cwd::getdcwd();}
946              
947             #-> sub CPAN::backtickcwd ;
948 0     0 1 0 sub backtickcwd {my $cwd = `cwd`; chomp $cwd; $cwd}
  0         0  
  0         0  
949              
950             # Adapted from Probe::Perl
951             #-> sub CPAN::_perl_is_same
952             sub _perl_is_same {
953 0     0   0 my ($perl) = @_;
954 0   0     0 return MM->maybe_command($perl)
955             && `$perl -MConfig=myconfig -e print -e myconfig` eq Config->myconfig;
956             }
957              
958             # Adapted in part from Probe::Perl
959             #-> sub CPAN::find_perl ;
960             sub find_perl () {
961 13 50   13 0 1230 if ( File::Spec->file_name_is_absolute($^X) ) {
962 13         270 return $^X;
963             }
964             else {
965 0         0 my $exe = $Config::Config{exe_ext};
966             my @candidates = (
967             File::Spec->catfile($CPAN::iCwd,$^X),
968 0         0 $Config::Config{'perlpath'},
969             );
970 0         0 for my $perl_name ($^X, 'perl', 'perl5', "perl$]") {
971 0         0 for my $path (File::Spec->path(), $Config::Config{'binexp'}) {
972 0 0 0     0 if ( defined($path) && length $path && -d $path ) {
      0        
973 0         0 my $perl = File::Spec->catfile($path,$perl_name);
974 0         0 push @candidates, $perl;
975             # try with extension if not provided already
976 0 0 0     0 if ($^O eq 'VMS') {
    0          
977             # VMS might have a file version at the end
978 0 0       0 push @candidates, $perl . $exe
979             unless $perl =~ m/$exe(;\d+)?$/i;
980             } elsif (defined $exe && length $exe) {
981 0 0       0 push @candidates, $perl . $exe
982             unless $perl =~ m/$exe$/i;
983             }
984             }
985             }
986             }
987 0         0 for my $perl ( @candidates ) {
988 0 0 0     0 if (MM->maybe_command($perl) && _perl_is_same($perl)) {
989 0         0 $^X = $perl;
990 0         0 return $perl;
991             }
992             }
993             }
994 0         0 return $^X; # default fall back
995             }
996              
997             #-> sub CPAN::exists ;
998             sub exists {
999 31     31 0 74 my($mgr,$class,$id) = @_;
1000 31 50       85 CPAN::HandleConfig->load unless $CPAN::Config_loaded++;
1001 31         109 CPAN::Index->reload;
1002             ### Carp::croak "exists called without class argument" unless $class;
1003 31   50     56 $id ||= "";
1004 31 100       71 $id =~ s/:+/::/g if $class eq "CPAN::Module";
1005 31         37 my $exists;
1006 31 50       53 if (CPAN::_sqlite_running) {
1007 0   0     0 $exists = (exists $META->{readonly}{$class}{$id} or
1008             $CPAN::SQLite->set($class, $id));
1009             } else {
1010 31         72 $exists = exists $META->{readonly}{$class}{$id};
1011             }
1012 31   66     175 $exists ||= exists $META->{readwrite}{$class}{$id}; # unsafe meta access, ok
1013             }
1014              
1015             #-> sub CPAN::delete ;
1016             sub delete {
1017 0     0 0 0 my($mgr,$class,$id) = @_;
1018 0         0 delete $META->{readonly}{$class}{$id}; # unsafe meta access, ok
1019 0         0 delete $META->{readwrite}{$class}{$id}; # unsafe meta access, ok
1020             }
1021              
1022             #-> sub CPAN::has_usable
1023             # has_inst is sometimes too optimistic, we should replace it with this
1024             # has_usable whenever a case is given
1025             sub has_usable {
1026 115     115 1 245 my($self,$mod,$message) = @_;
1027 115 100       357 return 1 if $HAS_USABLE->{$mod};
1028 6         42 my $has_inst = $self->has_inst($mod,$message);
1029 6 100       31 return unless $has_inst;
1030 3         8 my $usable;
1031             $usable = {
1032              
1033             #
1034             # most of these subroutines warn on the frontend, then
1035             # die if the installed version is unusable for some
1036             # reason; has_usable() then returns false when it caught
1037             # an exception, otherwise returns true and caches that;
1038             #
1039             'CPAN::Meta' => [
1040             sub {
1041 1     1   7 require CPAN::Meta;
1042 1 50       37 unless (CPAN::Version->vge(CPAN::Meta->VERSION, 2.110350)) {
1043 0         0 for ("Will not use CPAN::Meta, need version 2.110350\n") {
1044 0         0 $CPAN::Frontend->mywarn($_);
1045 0         0 die $_;
1046             }
1047             }
1048             },
1049             ],
1050              
1051             'CPAN::Meta::Requirements' => [
1052             sub {
1053 0 0 0 0   0 if (defined $CPAN::Meta::Requirements::VERSION
1054             && CPAN::Version->vlt($CPAN::Meta::Requirements::VERSION, "2.120920")
1055             ) {
1056 0         0 delete $INC{"CPAN/Meta/Requirements.pm"};
1057             }
1058 0         0 require CPAN::Meta::Requirements;
1059 0 0       0 unless (CPAN::Version->vge(CPAN::Meta::Requirements->VERSION, 2.120920)) {
1060 0         0 for ("Will not use CPAN::Meta::Requirements, need version 2.120920\n") {
1061 0         0 $CPAN::Frontend->mywarn($_);
1062 0         0 die $_;
1063             }
1064             }
1065             },
1066             ],
1067              
1068             'CPAN::Reporter' => [
1069             sub {
1070 0 0 0 0   0 if (defined $CPAN::Reporter::VERSION
1071             && CPAN::Version->vlt($CPAN::Reporter::VERSION, "1.2011")
1072             ) {
1073 0         0 delete $INC{"CPAN/Reporter.pm"};
1074             }
1075 0         0 require CPAN::Reporter;
1076 0 0       0 unless (CPAN::Version->vge(CPAN::Reporter->VERSION, "1.2011")) {
1077 0         0 for ("Will not use CPAN::Reporter, need version 1.2011\n") {
1078 0         0 $CPAN::Frontend->mywarn($_);
1079 0         0 die $_;
1080             }
1081             }
1082             },
1083             ],
1084              
1085             LWP => [ # we frequently had "Can't locate object
1086             # method "new" via package "LWP::UserAgent" at
1087             # (eval 69) line 2006
1088 0     0   0 sub {require LWP},
1089 0     0   0 sub {require LWP::UserAgent},
1090 0     0   0 sub {require HTTP::Request},
1091 0     0   0 sub {require URI::URL;
1092 0 0       0 unless (CPAN::Version->vge(URI::URL::->VERSION,0.08)) {
1093 0         0 for ("Will not use URI::URL, need 0.08\n") {
1094 0         0 $CPAN::Frontend->mywarn($_);
1095 0         0 die $_;
1096             }
1097             }
1098             },
1099             ],
1100             'Net::FTP' => [
1101             sub {
1102 0   0 0   0 my $var = $CPAN::Config->{ftp_proxy} || $ENV{ftp_proxy};
1103 0 0 0     0 if ($var and $var =~ /^http:/i) {
1104             # rt #110833
1105 0         0 for ("Net::FTP cannot handle http proxy") {
1106 0         0 $CPAN::Frontend->mywarn($_);
1107 0         0 die $_;
1108             }
1109             }
1110             },
1111 0     0   0 sub {require Net::FTP},
1112 0     0   0 sub {require Net::Config},
1113             ],
1114             'HTTP::Tiny' => [
1115             sub {
1116 0     0   0 require HTTP::Tiny;
1117 0 0       0 unless (CPAN::Version->vge(HTTP::Tiny->VERSION, 0.005)) {
1118 0         0 for ("Will not use HTTP::Tiny, need version 0.005\n") {
1119 0         0 $CPAN::Frontend->mywarn($_);
1120 0         0 die $_;
1121             }
1122             }
1123             },
1124             ],
1125             'File::HomeDir' => [
1126 0     0   0 sub {require File::HomeDir;
1127 0 0       0 unless (CPAN::Version->vge(File::HomeDir::->VERSION, 0.52)) {
1128 0         0 for ("Will not use File::HomeDir, need 0.52\n") {
1129 0         0 $CPAN::Frontend->mywarn($_);
1130 0         0 die $_;
1131             }
1132             }
1133             },
1134             ],
1135             'Archive::Tar' => [
1136 1     1   8 sub {require Archive::Tar;
1137 1         2 my $demand = "1.50";
1138 1 50       38 unless (CPAN::Version->vge(Archive::Tar::->VERSION, $demand)) {
1139 0         0 my $atv = Archive::Tar->VERSION;
1140 0         0 for ("You have Archive::Tar $atv, but $demand or later is recommended. Please upgrade.\n") {
1141 0         0 $CPAN::Frontend->mywarn($_);
1142             # don't die, because we may need
1143             # Archive::Tar to upgrade
1144             }
1145              
1146             }
1147             },
1148             ],
1149             'File::Temp' => [
1150             # XXX we should probably delete from
1151             # %INC too so we can load after we
1152             # installed a new enough version --
1153             # I'm not sure.
1154 0     0   0 sub {require File::Temp;
1155 0 0       0 unless (CPAN::Version->vge(File::Temp::->VERSION,0.16)) {
1156 0         0 for ("Will not use File::Temp, need 0.16\n") {
1157 0         0 $CPAN::Frontend->mywarn($_);
1158 0         0 die $_;
1159             }
1160             }
1161             },
1162 3         215 ]
1163             };
1164 3 100       19 if ($usable->{$mod}) {
1165 2         19 local @INC = @INC;
1166 2 50       19 pop @INC if $INC[-1] eq '.';
1167 2         6 for my $c (0..$#{$usable->{$mod}}) {
  2         11  
1168 2         5 my $code = $usable->{$mod}[$c];
1169 2         5 my $ret = eval { &$code() };
  2         8  
1170 2 50       8 $ret = "" unless defined $ret;
1171 2 50       22 if ($@) {
1172             # warn "DEBUG: c[$c]\$\@[$@]ret[$ret]";
1173 0         0 return;
1174             }
1175             }
1176             }
1177 3         206 return $HAS_USABLE->{$mod} = 1;
1178             }
1179              
1180             sub frontend {
1181 0     0 1 0 shift;
1182 0 0       0 $CPAN::Frontend = shift if @_;
1183 0         0 $CPAN::Frontend;
1184             }
1185              
1186             sub use_inst {
1187 8     8 1 27 my ($self, $module) = @_;
1188              
1189 8 50       28 unless ($self->has_inst($module)) {
1190 0         0 $self->frontend->mydie("$module not installed, cannot continue");
1191             }
1192             }
1193              
1194             #-> sub CPAN::has_inst
1195             sub has_inst {
1196 51     51 1 2284 my($self,$mod,$message) = @_;
1197 51 50       134 Carp::croak("CPAN->has_inst() called without an argument")
1198             unless defined $mod;
1199 15 100       39 my %dont = map { $_ => 1 } keys %{$CPAN::META->{dontload_hash}||{}},
  51         317  
1200 51 50       262 keys %{$CPAN::Config->{dontload_hash}||{}},
1201 51 50       102 @{$CPAN::Config->{dontload_list}||[]};
  51         249  
1202 51 100 66     352 if (defined $message && $message eq "no" # as far as I remember only used by Nox
      100        
1203             ||
1204             $dont{$mod}
1205             ) {
1206 9   100     62 $CPAN::META->{dontload_hash}{$mod}||=1; # unsafe meta access, ok
1207 9         33 return 0;
1208             }
1209 42         351 local @INC = @INC;
1210 42 50       117 pop @INC if $INC[-1] eq '.';
1211 42         67 my $file = $mod;
1212 42         54 my $obj;
1213 42         208 $file =~ s|::|/|g;
1214 42         82 $file .= ".pm";
1215 42 100       137 if ($INC{$file}) {
    100          
    50          
    50          
    50          
1216             # checking %INC is wrong, because $INC{LWP} may be true
1217             # although $INC{"URI/URL.pm"} may have failed. But as
1218             # I really want to say "blah loaded OK", I have to somehow
1219             # cache results.
1220             ### warn "$file in %INC"; #debug
1221 25         133 return 1;
1222 17         8719 } elsif (eval { require $file }) {
1223             # eval is good: if we haven't yet read the database it's
1224             # perfect and if we have installed the module in the meantime,
1225             # it tries again. The second require is only a NOOP returning
1226             # 1 if we had success, otherwise it's retrying
1227              
1228 7         239542 my $mtime = (stat $INC{$file})[9];
1229             # privileged files loaded by has_inst; Note: we use $mtime
1230             # as a proxy for a checksum.
1231 7         51 $CPAN::Shell::reload->{$file} = $mtime;
1232 7         1038 my $v = eval "\$$mod\::VERSION";
1233 7 50       68 $v = $v ? " (v$v)" : "";
1234 7         176 CPAN::Shell->optprint("load_module","CPAN: $mod loaded ok$v\n");
1235 7 50       50 if ($mod eq "CPAN::WAIT") {
1236 0         0 push @CPAN::Shell::ISA, 'CPAN::WAIT';
1237             }
1238 7         73 return 1;
1239             } elsif ($mod eq "Net::FTP") {
1240             $CPAN::Frontend->mywarn(qq{
1241             Please, install Net::FTP as soon as possible. CPAN.pm installs it for you
1242             if you just type
1243             install Bundle::libnet
1244              
1245 0 0       0 }) unless $Have_warned->{"Net::FTP"}++;
1246 0         0 $CPAN::Frontend->mysleep(3);
1247             } elsif ($mod eq "Digest::SHA") {
1248 0 0       0 if ($Have_warned->{"Digest::SHA"}++) {
1249 0         0 $CPAN::Frontend->mywarn(qq{CPAN: checksum security checks disabled }.
1250             qq{because Digest::SHA not installed.\n});
1251             } else {
1252 0         0 $CPAN::Frontend->mywarn(qq{
1253             CPAN: checksum security checks disabled because Digest::SHA not installed.
1254             Please consider installing the Digest::SHA module.
1255              
1256             });
1257 0         0 $CPAN::Frontend->mysleep(2);
1258             }
1259             } elsif ($mod eq "Module::Signature") {
1260             # NOT prefs_lookup, we are not a distro
1261 0         0 my $check_sigs = $CPAN::Config->{check_sigs};
1262 0 0       0 if (not $check_sigs) {
    0          
1263             # they do not want us:-(
1264             } elsif (not $Have_warned->{"Module::Signature"}++) {
1265             # No point in complaining unless the user can
1266             # reasonably install and use it.
1267 0 0 0     0 if (eval { require Crypt::OpenPGP; 1 } ||
  0   0     0  
  0         0  
1268             (
1269             defined $CPAN::Config->{'gpg'}
1270             &&
1271             $CPAN::Config->{'gpg'} =~ /\S/
1272             )
1273             ) {
1274 0         0 $CPAN::Frontend->mywarn(qq{
1275             CPAN: Module::Signature security checks disabled because Module::Signature
1276             not installed. Please consider installing the Module::Signature module.
1277             You may also need to be able to connect over the Internet to the public
1278             key servers like pool.sks-keyservers.net or pgp.mit.edu.
1279              
1280             });
1281 0         0 $CPAN::Frontend->mysleep(2);
1282             }
1283             }
1284             } else {
1285 10         31 delete $INC{$file}; # if it inc'd LWP but failed during, say, URI
1286             }
1287 10         70 return 0;
1288             }
1289              
1290             #-> sub CPAN::instance ;
1291             sub instance {
1292 46     46 1 95 my($mgr,$class,$id) = @_;
1293 46         145 CPAN::Index->reload;
1294 46   50     87 $id ||= "";
1295             # unsafe meta access, ok?
1296 46 100       120 return $META->{readwrite}{$class}{$id} if exists $META->{readwrite}{$class}{$id};
1297 41   33     301 $META->{readwrite}{$class}{$id} ||= $class->new(ID => $id);
1298             }
1299              
1300             #-> sub CPAN::new ;
1301             sub new {
1302 13     13 0 314 bless {}, shift;
1303             }
1304              
1305             #-> sub CPAN::_exit_messages ;
1306             sub _exit_messages {
1307 0     0   0 my ($self) = @_;
1308 0   0     0 $self->{exit_messages} ||= [];
1309             }
1310              
1311             #-> sub CPAN::cleanup ;
1312             sub cleanup {
1313             # warn "cleanup called with arg[@_] End[$CPAN::End] Signal[$Signal]";
1314 13     13 0 130 local $SIG{__DIE__} = '';
1315 13         49 my($message) = @_;
1316 13         59 my $i = 0;
1317 13         50 my $ineval = 0;
1318 13         35 my($subroutine);
1319 13         155 while ((undef,undef,undef,$subroutine) = caller(++$i)) {
1320 26 100       162 $ineval = 1, last if
1321             $subroutine eq '(eval)';
1322             }
1323 13 50 33     198 return if $ineval && !$CPAN::End;
1324 13 50       442 return unless defined $META->{LOCK};
1325 0 0         return unless -f $META->{LOCK};
1326 0           $META->savehist;
1327 0   0       $META->{cachemgr} ||= CPAN::CacheMgr->new('atexit');
1328 0           close $META->{LOCKFH};
1329 0           unlink $META->{LOCK};
1330             # require Carp;
1331             # Carp::cluck("DEBUGGING");
1332 0 0         if ( $CPAN::CONFIG_DIRTY ) {
1333 0           $CPAN::Frontend->mywarn("Warning: Configuration not saved.\n");
1334             }
1335 0           $CPAN::Frontend->myprint("Lockfile removed.\n");
1336 0           for my $msg ( @{ $META->_exit_messages } ) {
  0            
1337 0           $CPAN::Frontend->myprint($msg);
1338             }
1339             }
1340              
1341             #-> sub CPAN::readhist
1342             sub readhist {
1343 0     0 0   my($self,$term,$histfile) = @_;
1344 0   0       my $histsize = $CPAN::Config->{'histsize'} || 100;
1345 0 0         $term->Attribs->{'MaxHistorySize'} = $histsize if (defined($term->Attribs->{'MaxHistorySize'}));
1346 0           my($fh) = FileHandle->new;
1347 0 0         open $fh, "<$histfile" or return;
1348 0           local $/ = "\n";
1349 0           while (<$fh>) {
1350 0           chomp;
1351 0           $term->AddHistory($_);
1352             }
1353 0           close $fh;
1354             }
1355              
1356             #-> sub CPAN::savehist
1357             sub savehist {
1358 0     0 0   my($self) = @_;
1359 0           my($histfile,$histsize);
1360 0 0         unless ($histfile = $CPAN::Config->{'histfile'}) {
1361 0           $CPAN::Frontend->mywarn("No history written (no histfile specified).\n");
1362 0           return;
1363             }
1364 0   0       $histsize = $CPAN::Config->{'histsize'} || 100;
1365 0 0         if ($CPAN::term) {
1366 0 0         unless ($CPAN::term->can("GetHistory")) {
1367 0           $CPAN::Frontend->mywarn("Terminal does not support GetHistory.\n");
1368 0           return;
1369             }
1370             } else {
1371 0           return;
1372             }
1373 0           my @h = $CPAN::term->GetHistory;
1374 0 0         splice @h, 0, @h-$histsize if @h>$histsize;
1375 0           my($fh) = FileHandle->new;
1376 0 0         open $fh, ">$histfile" or $CPAN::Frontend->mydie("Couldn't open >$histfile: $!");
1377 0           local $\ = local $, = "\n";
1378 0           print $fh @h;
1379 0           close $fh;
1380             }
1381              
1382             #-> sub CPAN::is_tested
1383             sub is_tested {
1384 0     0 1   my($self,$what,$when) = @_;
1385 0 0         unless ($what) {
1386 0           Carp::cluck("DEBUG: empty what");
1387 0           return;
1388             }
1389 0           $self->{is_tested}{$what} = $when;
1390             }
1391              
1392             #-> sub CPAN::reset_tested
1393             # forget all distributions tested -- resets what gets included in PERL5LIB
1394             sub reset_tested {
1395 0     0 0   my ($self) = @_;
1396 0           $self->{is_tested} = {};
1397             }
1398              
1399             #-> sub CPAN::is_installed
1400             # unsets the is_tested flag: as soon as the thing is installed, it is
1401             # not needed in set_perl5lib anymore
1402             sub is_installed {
1403 0     0 0   my($self,$what) = @_;
1404 0           delete $self->{is_tested}{$what};
1405             }
1406              
1407             sub _list_sorted_descending_is_tested {
1408 0     0     my($self) = @_;
1409 0           my $foul = 0;
1410             my @sorted = sort
1411 0   0       { ($self->{is_tested}{$b}||0) <=> ($self->{is_tested}{$a}||0) }
      0        
1412             grep
1413 0 0         { if ($foul){ 0 } elsif (-e) { 1 } else { $foul = $_; 0 } }
  0 0          
  0            
  0            
  0            
1414 0           keys %{$self->{is_tested}};
  0            
1415 0 0         if ($foul) {
1416 0           $CPAN::Frontend->mywarn("Lost build_dir detected ($foul), giving up all cached test results of currently running session.\n");
1417 0           for my $dbd (sort keys %{$self->{is_tested}}) { # distro-build-dir
  0            
1418 0           SEARCH: for my $d (sort { $a->id cmp $b->id } $CPAN::META->all_objects("CPAN::Distribution")) {
  0            
1419 0 0 0       if ($d->{build_dir} && $d->{build_dir} eq $dbd) {
1420 0           $CPAN::Frontend->mywarn(sprintf "Flushing cache for %s\n", $d->pretty_id);
1421 0           $d->fforce("");
1422 0           last SEARCH;
1423             }
1424             }
1425 0           delete $self->{is_tested}{$dbd};
1426             }
1427 0           return ();
1428             } else {
1429 0           return @sorted;
1430             }
1431             }
1432              
1433             #-> sub CPAN::set_perl5lib
1434             # Notes on max environment variable length:
1435             # - Win32 : XP or later, 8191; Win2000 or NT4, 2047
1436             {
1437             my $fh;
1438             sub set_perl5lib {
1439 0     0 0   my($self,$for) = @_;
1440 0 0         unless ($for) {
1441 0           (undef,undef,undef,$for) = caller(1);
1442 0           $for =~ s/.*://;
1443             }
1444 0   0       $self->{is_tested} ||= {};
1445 0 0         return unless %{$self->{is_tested}};
  0            
1446 0           my $env = $ENV{PERL5LIB};
1447 0 0         $env = $ENV{PERLLIB} unless defined $env;
1448 0           my @env;
1449 0 0 0       push @env, split /\Q$Config::Config{path_sep}\E/, $env if defined $env and length $env;
1450             #my @dirs = map {("$_/blib/arch", "$_/blib/lib")} keys %{$self->{is_tested}};
1451             #$CPAN::Frontend->myprint("Prepending @dirs to PERL5LIB.\n");
1452              
1453 0           my @dirs = map {("$_/blib/arch", "$_/blib/lib")} $self->_list_sorted_descending_is_tested;
  0            
1454 0 0         return if !@dirs;
1455              
1456 0 0         if (@dirs < 12) {
    0          
1457 0           $CPAN::Frontend->optprint('perl5lib', "Prepending @dirs to PERL5LIB for '$for'\n");
1458 0           $ENV{PERL5LIB} = join $Config::Config{path_sep}, @dirs, @env;
1459             } elsif (@dirs < 24 ) {
1460 0           my @d = map {my $cp = $_;
  0            
1461 0           $cp =~ s/^\Q$CPAN::Config->{build_dir}\E/%BUILDDIR%/;
1462 0           $cp
1463             } @dirs;
1464 0           $CPAN::Frontend->optprint('perl5lib', "Prepending @d to PERL5LIB; ".
1465             "%BUILDDIR%=$CPAN::Config->{build_dir} ".
1466             "for '$for'\n"
1467             );
1468 0           $ENV{PERL5LIB} = join $Config::Config{path_sep}, @dirs, @env;
1469             } else {
1470 0           my $cnt = keys %{$self->{is_tested}};
  0            
1471 0           $CPAN::Frontend->optprint('perl5lib', "Prepending blib/arch and blib/lib of ".
1472             "$cnt build dirs to PERL5LIB; ".
1473             "for '$for'\n"
1474             );
1475 0           $ENV{PERL5LIB} = join $Config::Config{path_sep}, @dirs, @env;
1476             }
1477             }}
1478              
1479              
1480             1;
1481              
1482              
1483             __END__