File Coverage

blib/lib/CPAN.pm
Criterion Covered Total %
statement 247 830 29.7
branch 51 400 12.7
condition 23 170 13.5
subroutine 63 109 57.8
pod 13 27 48.1
total 397 1536 25.8


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   133140 use strict;
  13         67  
  13         1082  
4             package CPAN;
5             $CPAN::VERSION = '2.32';
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   94 use File::Spec ();
  13         31  
  13         1300  
11             BEGIN {
12 13 50   13   400 if (File::Spec->can("rel2abs")) {
13 13         51 for my $inc (@INC) {
14 148 50       1836 $inc = File::Spec->rel2abs($inc) unless ref $inc;
15             }
16             }
17 13 50       876 $SIG{WINCH} = 'IGNORE' if exists $SIG{WINCH};
18             }
19 13     13   5966 use CPAN::Author;
  13         36  
  13         439  
20 13     13   7091 use CPAN::HandleConfig;
  13         47  
  13         505  
21 13     13   5839 use CPAN::Version;
  13         32  
  13         413  
22 13     13   5587 use CPAN::Bundle;
  13         43  
  13         487  
23 13     13   8108 use CPAN::CacheMgr;
  13         44  
  13         489  
24 13     13   5934 use CPAN::Complete;
  13         40  
  13         439  
25 13     13   79 use CPAN::Debug;
  13         26  
  13         254  
26 13     13   12941 use CPAN::Distribution;
  13         43  
  13         668  
27 13     13   6778 use CPAN::Distrostatus;
  13         33  
  13         399  
28 13     13   7511 use CPAN::FTP;
  13         39  
  13         613  
29 13     13   6821 use CPAN::Index 1.93; # https://rt.cpan.org/Ticket/Display.html?id=43349
  13         396  
  13         481  
30 13     13   104 use CPAN::InfoObj;
  13         60  
  13         306  
31 13     13   70 use CPAN::Module;
  13         31  
  13         334  
32 13     13   5712 use CPAN::Prompt;
  13         32  
  13         398  
33 13     13   5206 use CPAN::URL;
  13         35  
  13         373  
34 13     13   5229 use CPAN::Queue;
  13         38  
  13         411  
35 13     13   6108 use CPAN::Tarzip;
  13         39  
  13         519  
36 13     13   5869 use CPAN::DeferredCode;
  13         32  
  13         458  
37 13     13   8319 use CPAN::Shell;
  13         39  
  13         520  
38 13     13   5953 use CPAN::LWP::UserAgent;
  13         43  
  13         414  
39 13     13   5641 use CPAN::Exception::RecursiveDependency;
  13         34  
  13         409  
40 13     13   5401 use CPAN::Exception::yaml_not_installed;
  13         39  
  13         398  
41 13     13   5193 use CPAN::Exception::yaml_process_error;
  13         31  
  13         365  
42              
43 13     13   75 use Carp ();
  13         34  
  13         177  
44 13     13   54 use Config ();
  13         24  
  13         222  
45 13     13   66 use Cwd qw(chdir);
  13         22  
  13         658  
46 13     13   66 use DirHandle ();
  13         36  
  13         155  
47 13     13   118 use Exporter ();
  13         34  
  13         317  
48 13     13   10062 use ExtUtils::MakeMaker qw(prompt); # for some unknown reason,
  13         1284771  
  13         971  
49             # 5.005_04 does not work without
50             # this
51 13     13   113 use File::Basename ();
  13         30  
  13         210  
52 13     13   4456 use File::Copy ();
  13         20900  
  13         366  
53 13     13   87 use File::Find;
  13         27  
  13         765  
54 13     13   85 use File::Path ();
  13         25  
  13         251  
55 13     13   5656 use FileHandle ();
  13         97490  
  13         455  
56 13     13   110 use Fcntl qw(:flock);
  13         31  
  13         1631  
57 13     13   7318 use Safe ();
  13         466445  
  13         913  
58 13     13   6288 use Sys::Hostname qw(hostname);
  13         13383  
  13         874  
59 13     13   5658 use Text::ParseWords ();
  13         14396  
  13         361  
60 13     13   5956 use Text::Wrap ();
  13         29393  
  13         692  
61              
62             # protect against "called too early"
63             sub find_perl ();
64             sub anycwd ();
65             sub _uniq;
66              
67 13     13   5077 no lib ".";
  13         6691  
  13         83  
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   7854909 END { $CPAN::End++; &cleanup; }
  13         98  
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         17026 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   5250 );
  13         30  
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   19 $autoload_recursion++;
186 1         7 my($l) = $AUTOLOAD;
187 1         11 $l =~ s/.*:://;
188 1 50       5 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       8 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         6 my(%export);
200 1         79 @export{@EXPORT} = '';
201 1 50       56 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         11 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   117 use strict;
  13         33  
  13         437  
363 13     13   91 use vars qw($import_done);
  13         30  
  13         15429  
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     9 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     15 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         11 return $yaml_module;
548             }
549              
550             # CPAN::_yaml_loadfile
551             sub _yaml_loadfile {
552 0     0   0 my($self,$local_file,$opt) = @_;
553 0 0       0 return +[] unless -s $local_file;
554 0   0     0 my $opt_loadblessed = $opt->{loadblessed} || $CPAN::Config->{yaml_load_code} || 0;
555 0         0 my $yaml_module = _yaml_module;
556 0 0       0 if ($CPAN::META->has_inst($yaml_module)) {
557             # temporarily enable yaml code deserialisation
558 13     13   106 no strict 'refs';
  13         35  
  13         52395  
559             # 5.6.2 could not do the local() with the reference
560             # so we do it manually instead
561 0         0 my $old_loadcode = ${"$yaml_module\::LoadCode"};
  0         0  
562 0         0 my $old_loadblessed = ${"$yaml_module\::LoadBlessed"};
  0         0  
563 0   0     0 ${ "$yaml_module\::LoadCode" } = $CPAN::Config->{yaml_load_code} || 0;
  0         0  
564 0 0       0 ${ "$yaml_module\::LoadBlessed" } = $opt_loadblessed ? 1 : 0;
  0         0  
565              
566 0         0 my ($code, @yaml);
567 0 0       0 if ($code = UNIVERSAL::can($yaml_module, "LoadFile")) {
    0          
568 0         0 eval { @yaml = $code->($local_file); };
  0         0  
569 0 0       0 if ($@) {
570             # this shall not be done by the frontend
571 0         0 die CPAN::Exception::yaml_process_error->new($yaml_module,$local_file,"parse",$@);
572             }
573             } elsif ($code = UNIVERSAL::can($yaml_module, "Load")) {
574 0         0 local *FH;
575 0 0       0 if (open FH, $local_file) {
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             } else {
584 0         0 $CPAN::Frontend->mywarn("Could not open '$local_file': $!");
585             }
586             }
587 0         0 ${"$yaml_module\::LoadCode"} = $old_loadcode;
  0         0  
588 0         0 ${"$yaml_module\::LoadBlessed"} = $old_loadblessed;
  0         0  
589 0         0 return \@yaml;
590             } else {
591             # this shall not be done by the frontend
592 0         0 die CPAN::Exception::yaml_not_installed->new($yaml_module, $local_file, "parse");
593             }
594 0         0 return +[];
595             }
596              
597             # CPAN::_yaml_dumpfile
598             sub _yaml_dumpfile {
599 0     0   0 my($self,$local_file,@what) = @_;
600 0         0 my $yaml_module = _yaml_module;
601 0 0       0 if ($CPAN::META->has_inst($yaml_module)) {
602 0         0 my $code;
603 0 0       0 if (UNIVERSAL::isa($local_file, "FileHandle")) {
    0          
    0          
604 0         0 $code = UNIVERSAL::can($yaml_module, "Dump");
605 0         0 eval { print $local_file $code->(@what) };
  0         0  
606             } elsif ($code = UNIVERSAL::can($yaml_module, "DumpFile")) {
607 0         0 eval { $code->($local_file,@what); };
  0         0  
608             } elsif ($code = UNIVERSAL::can($yaml_module, "Dump")) {
609 0         0 local *FH;
610 0 0       0 open FH, ">$local_file" or die "Could not open '$local_file': $!";
611 0         0 print FH $code->(@what);
612             }
613 0 0       0 if ($@) {
614 0         0 die CPAN::Exception::yaml_process_error->new($yaml_module,$local_file,"dump",$@);
615             }
616             } else {
617 0 0       0 if (UNIVERSAL::isa($local_file, "FileHandle")) {
618             # I think this case does not justify a warning at all
619             } else {
620 0         0 die CPAN::Exception::yaml_not_installed->new($yaml_module, $local_file, "dump");
621             }
622             }
623             }
624              
625             sub _init_sqlite () {
626 0 0   0   0 unless ($CPAN::META->has_inst("CPAN::SQLite")) {
627             $CPAN::Frontend->mywarn(qq{CPAN::SQLite not installed, trying to work without\n})
628 0 0       0 unless $Have_warned->{"CPAN::SQLite"}++;
629 0         0 return;
630             }
631 0         0 require CPAN::SQLite::META; # not needed since CVS version of 2006-12-17
632 0   0     0 $CPAN::SQLite ||= CPAN::SQLite::META->new($CPAN::META);
633             }
634              
635             {
636             my $negative_cache = {};
637             sub _sqlite_running {
638 130 100 66 130   406 if ($negative_cache->{time} && time < $negative_cache->{time} + 60) {
639             # need to cache the result, otherwise too slow
640 129         312 return $negative_cache->{fact};
641             } else {
642 1         3 $negative_cache = {}; # reset
643             }
644 1   33     3 my $ret = $CPAN::Config->{use_sqlite} && ($CPAN::SQLite || _init_sqlite());
645 1 50       3 return $ret if $ret; # fast anyway
646 1         9 $negative_cache->{time} = time;
647 1         6 return $negative_cache->{fact} = $ret;
648             }
649             }
650              
651             $META ||= CPAN->new; # In case we re-eval ourselves we need the ||
652              
653             # from here on only subs.
654             ################################################################################
655              
656             sub _perl_fingerprint {
657 0     0   0 my($self,$other_fingerprint) = @_;
658 0         0 my $dll = eval {OS2::DLLname()};
  0         0  
659 0         0 my $mtime_dll = 0;
660 0 0       0 if (defined $dll) {
661 0 0       0 $mtime_dll = (-f $dll ? (stat(_))[9] : '-1');
662             }
663 0 0       0 my $mtime_perl = (-f CPAN::find_perl ? (stat(_))[9] : '-1');
664             my $this_fingerprint = {
665             '$^X' => CPAN::find_perl,
666             sitearchexp => $Config::Config{sitearchexp},
667 0         0 'mtime_$^X' => $mtime_perl,
668             'mtime_dll' => $mtime_dll,
669             };
670 0 0       0 if ($other_fingerprint) {
671 0 0       0 if (exists $other_fingerprint->{'stat($^X)'}) { # repair fp from rev. 1.88_57
672 0         0 $other_fingerprint->{'mtime_$^X'} = $other_fingerprint->{'stat($^X)'}[9];
673             }
674             # mandatory keys since 1.88_57
675 0         0 for my $key (qw($^X sitearchexp mtime_dll mtime_$^X)) {
676 0 0       0 return unless $other_fingerprint->{$key} eq $this_fingerprint->{$key};
677             }
678 0         0 return 1;
679             } else {
680 0         0 return $this_fingerprint;
681             }
682             }
683              
684             sub suggest_myconfig () {
685 0 0   0 0 0 SUGGEST_MYCONFIG: if(!$INC{'CPAN/MyConfig.pm'}) {
686 0         0 $CPAN::Frontend->myprint("You don't seem to have a user ".
687             "configuration (MyConfig.pm) yet.\n");
688 0         0 my $new = CPAN::Shell::colorable_makemaker_prompt("Do you want to create a ".
689             "user configuration now? (Y/n)",
690             "yes");
691 0 0       0 if($new =~ m{^y}i) {
692 0         0 CPAN::Shell->mkmyconfig();
693 0         0 return &checklock;
694             } else {
695 0         0 $CPAN::Frontend->mydie("OK, giving up.");
696             }
697             }
698             }
699              
700             #-> sub CPAN::all_objects ;
701             sub all_objects {
702 0     0 0 0 my($mgr,$class) = @_;
703 0 0       0 CPAN::HandleConfig->load unless $CPAN::Config_loaded++;
704 0 0       0 CPAN->debug("mgr[$mgr] class[$class]") if $CPAN::DEBUG;
705 0         0 CPAN::Index->reload;
706 0         0 values %{ $META->{readwrite}{$class} }; # unsafe meta access, ok
  0         0  
707             }
708              
709             # Called by shell, not in batch mode. In batch mode I see no risk in
710             # having many processes updating something as installations are
711             # continually checked at runtime. In shell mode I suspect it is
712             # unintentional to open more than one shell at a time
713              
714             #-> sub CPAN::checklock ;
715             sub checklock {
716 0     0 0 0 my($self) = @_;
717 0         0 my $lockfile = File::Spec->catfile($CPAN::Config->{cpan_home},".lock");
718 0 0 0     0 if (-f $lockfile && -M _ > 0) {
719 0 0       0 my $fh = FileHandle->new($lockfile) or
720             $CPAN::Frontend->mydie("Could not open lockfile '$lockfile': $!");
721 0         0 my $otherpid = <$fh>;
722 0         0 my $otherhost = <$fh>;
723 0         0 $fh->close;
724 0 0 0     0 if (defined $otherpid && length $otherpid) {
725 0         0 chomp $otherpid;
726             }
727 0 0 0     0 if (defined $otherhost && length $otherhost) {
728 0         0 chomp $otherhost;
729             }
730 0         0 my $thishost = hostname();
731 0         0 my $ask_if_degraded_wanted = 0;
732 0 0 0     0 if (defined $otherhost && defined $thishost &&
    0 0        
    0 0        
    0 0        
      0        
733             $otherhost ne '' && $thishost ne '' &&
734             $otherhost ne $thishost) {
735 0         0 $CPAN::Frontend->mydie(sprintf("CPAN.pm panic: Lockfile '$lockfile'\n".
736             "reports other host $otherhost and other ".
737             "process $otherpid.\n".
738             "Cannot proceed.\n"));
739             } elsif ($RUN_DEGRADED) {
740 0         0 $CPAN::Frontend->mywarn("Running in downgraded mode (experimental)\n");
741             } elsif (defined $otherpid && $otherpid) {
742 0 0       0 return if $$ == $otherpid; # should never happen
743 0         0 $CPAN::Frontend->mywarn(
744             qq{
745             There seems to be running another CPAN process (pid $otherpid). Contacting...
746             });
747 0 0 0     0 if (kill 0, $otherpid or $!{EPERM}) {
    0          
748 0         0 $CPAN::Frontend->mywarn(qq{Other job is running.\n});
749 0         0 $ask_if_degraded_wanted = 1;
750             } elsif (-w $lockfile) {
751 0         0 my($ans) =
752             CPAN::Shell::colorable_makemaker_prompt
753             (qq{Other job not responding. Shall I overwrite }.
754             qq{the lockfile '$lockfile'? (Y/n)},"y");
755 0 0       0 $CPAN::Frontend->myexit("Ok, bye\n")
756             unless $ans =~ /^y/i;
757             } else {
758 0         0 Carp::croak(
759             qq{Lockfile '$lockfile' not writable by you. }.
760             qq{Cannot proceed.\n}.
761             qq{ On UNIX try:\n}.
762             qq{ rm '$lockfile'\n}.
763             qq{ and then rerun us.\n}
764             );
765             }
766             } elsif ($^O eq "MSWin32") {
767 0         0 $CPAN::Frontend->mywarn(
768             qq{
769             There seems to be running another CPAN process according to '$lockfile'.
770             });
771 0         0 $ask_if_degraded_wanted = 1;
772             } else {
773 0         0 $CPAN::Frontend->mydie(sprintf("CPAN.pm panic: Found invalid lockfile ".
774             "'$lockfile', please remove. Cannot proceed.\n"));
775             }
776 0 0       0 if ($ask_if_degraded_wanted) {
777 0         0 my($ans) =
778             CPAN::Shell::colorable_makemaker_prompt
779             (qq{Shall I try to run in downgraded }.
780             qq{mode? (Y/n)},"y");
781 0 0       0 if ($ans =~ /^y/i) {
782 0         0 $CPAN::Frontend->mywarn("Running in downgraded mode (experimental).
783             Please report if something unexpected happens\n");
784 0         0 $RUN_DEGRADED = 1;
785 0         0 for ($CPAN::Config) {
786             # XXX
787             # $_->{build_dir_reuse} = 0; # 2006-11-17 akoenig Why was that?
788 0         0 $_->{commandnumber_in_prompt} = 0; # visibility
789 0         0 $_->{histfile} = ""; # who should win otherwise?
790 0         0 $_->{cache_metadata} = 0; # better would be a lock?
791 0         0 $_->{use_sqlite} = 0; # better would be a write lock!
792 0         0 $_->{auto_commit} = 0; # we are violent, do not persist
793 0         0 $_->{test_report} = 0; # Oliver Paukstadt had sent wrong reports in degraded mode
794             }
795             } else {
796 0         0 my $msg = "You may want to kill the other job and delete the lockfile.";
797 0 0       0 if (defined $otherpid) {
798 0         0 $msg .= " Something like:
799             kill $otherpid
800             rm $lockfile
801             ";
802             }
803 0         0 $CPAN::Frontend->mydie("\n$msg");
804             }
805             }
806             }
807 0         0 my $dotcpan = $CPAN::Config->{cpan_home};
808 0         0 eval { File::Path::mkpath($dotcpan);};
  0         0  
809 0 0       0 if ($@) {
810             # A special case at least for Jarkko.
811 0         0 my $firsterror = $@;
812 0         0 my $seconderror;
813             my $symlinkcpan;
814 0 0       0 if (-l $dotcpan) {
815 0         0 $symlinkcpan = readlink $dotcpan;
816 0 0       0 die "readlink $dotcpan failed: $!" unless defined $symlinkcpan;
817 0         0 eval { File::Path::mkpath($symlinkcpan); };
  0         0  
818 0 0       0 if ($@) {
819 0         0 $seconderror = $@;
820             } else {
821 0         0 $CPAN::Frontend->mywarn(qq{
822             Working directory $symlinkcpan created.
823             });
824             }
825             }
826 0 0       0 unless (-d $dotcpan) {
827 0         0 my $mess = qq{
828             Your configuration suggests "$dotcpan" as your
829             CPAN.pm working directory. I could not create this directory due
830             to this error: $firsterror\n};
831 0 0       0 $mess .= qq{
832             As "$dotcpan" is a symlink to "$symlinkcpan",
833             I tried to create that, but I failed with this error: $seconderror
834             } if $seconderror;
835 0         0 $mess .= qq{
836             Please make sure the directory exists and is writable.
837             };
838 0         0 $CPAN::Frontend->mywarn($mess);
839 0         0 return suggest_myconfig;
840             }
841             } # $@ after eval mkpath $dotcpan
842 0         0 if (0) { # to test what happens when a race condition occurs
843             for (reverse 1..10) {
844             print $_, "\n";
845             sleep 1;
846             }
847             }
848             # locking
849 0 0 0     0 if (!$RUN_DEGRADED && !$self->{LOCKFH}) {
850 0         0 my $fh;
851 0 0       0 unless ($fh = FileHandle->new("+>>$lockfile")) {
852 0         0 $CPAN::Frontend->mywarn(qq{
853              
854             Your configuration suggests that CPAN.pm should use a working
855             directory of
856             $CPAN::Config->{cpan_home}
857             Unfortunately we could not create the lock file
858             $lockfile
859             due to '$!'.
860              
861             Please make sure that the configuration variable
862             \$CPAN::Config->{cpan_home}
863             points to a directory where you can write a .lock file. You can set
864             this variable in either a CPAN/MyConfig.pm or a CPAN/Config.pm in your
865             \@INC path;
866             });
867 0         0 return suggest_myconfig;
868             }
869 0         0 my $sleep = 1;
870 0         0 while (!CPAN::_flock($fh, LOCK_EX|LOCK_NB)) {
871 0   0     0 my $err = $! || "unknown error";
872 0 0       0 if ($sleep>3) {
873 0         0 $CPAN::Frontend->mydie("Could not lock '$lockfile' with flock: $err; giving up\n");
874             }
875 0         0 $CPAN::Frontend->mysleep($sleep+=0.1);
876 0         0 $CPAN::Frontend->mywarn("Could not lock '$lockfile' with flock: $err; retrying\n");
877             }
878              
879 0         0 seek $fh, 0, 0;
880 0         0 truncate $fh, 0;
881 0         0 $fh->autoflush(1);
882 0         0 $fh->print($$, "\n");
883 0         0 $fh->print(hostname(), "\n");
884 0         0 $self->{LOCK} = $lockfile;
885 0         0 $self->{LOCKFH} = $fh;
886             }
887             $SIG{TERM} = sub {
888 0     0   0 my $sig = shift;
889 0         0 &cleanup;
890 0         0 $CPAN::Frontend->mydie("Got SIG$sig, leaving");
891 0         0 };
892             $SIG{INT} = sub {
893             # no blocks!!!
894 0     0   0 my $sig = shift;
895 0 0       0 &cleanup if $Signal;
896 0 0       0 die "Got yet another signal" if $Signal > 1;
897 0 0       0 $CPAN::Frontend->mydie("Got another SIG$sig") if $Signal;
898 0         0 $CPAN::Frontend->mywarn("Caught SIG$sig, trying to continue\n");
899 0         0 $Signal++;
900 0         0 };
901              
902             # From: Larry Wall
903             # Subject: Re: deprecating SIGDIE
904             # To: perl5-porters@perl.org
905             # Date: Thu, 30 Sep 1999 14:58:40 -0700 (PDT)
906             #
907             # The original intent of __DIE__ was only to allow you to substitute one
908             # kind of death for another on an application-wide basis without respect
909             # to whether you were in an eval or not. As a global backstop, it should
910             # not be used any more lightly (or any more heavily :-) than class
911             # UNIVERSAL. Any attempt to build a general exception model on it should
912             # be politely squashed. Any bug that causes every eval {} to have to be
913             # modified should be not so politely squashed.
914             #
915             # Those are my current opinions. It is also my opinion that polite
916             # arguments degenerate to personal arguments far too frequently, and that
917             # when they do, it's because both people wanted it to, or at least didn't
918             # sufficiently want it not to.
919             #
920             # Larry
921              
922             # global backstop to cleanup if we should really die
923 0         0 $SIG{__DIE__} = \&cleanup;
924 0 0       0 $self->debug("Signal handler set.") if $CPAN::DEBUG;
925             }
926              
927             #-> sub CPAN::DESTROY ;
928             sub DESTROY {
929 0     0   0 &cleanup; # need an eval?
930             }
931              
932             #-> sub CPAN::anycwd ;
933             sub anycwd () {
934 13     13 1 26 my $getcwd;
935 13   100     70 $getcwd = $CPAN::Config->{'getcwd'} || 'cwd';
936 13         80 CPAN->$getcwd();
937             }
938              
939             #-> sub CPAN::cwd ;
940 13     13 1 64978 sub cwd {Cwd::cwd();}
941              
942             #-> sub CPAN::getcwd ;
943 0     0 1 0 sub getcwd {Cwd::getcwd();}
944              
945             #-> sub CPAN::fastcwd ;
946 0     0 1 0 sub fastcwd {Cwd::fastcwd();}
947              
948             #-> sub CPAN::getdcwd ;
949 0     0 1 0 sub getdcwd {Cwd::getdcwd();}
950              
951             #-> sub CPAN::backtickcwd ;
952 0     0 1 0 sub backtickcwd {my $cwd = `cwd`; chomp $cwd; $cwd}
  0         0  
  0         0  
953              
954             # Adapted from Probe::Perl
955             #-> sub CPAN::_perl_is_same
956             sub _perl_is_same {
957 0     0   0 my ($perl) = @_;
958 0   0     0 return MM->maybe_command($perl)
959             && `$perl -MConfig=myconfig -e print -e myconfig` eq Config->myconfig;
960             }
961              
962             # Adapted in part from Probe::Perl
963             #-> sub CPAN::find_perl ;
964             sub find_perl () {
965 13 50   13 0 1143 if ( File::Spec->file_name_is_absolute($^X) ) {
966 13         237 return $^X;
967             }
968             else {
969 0         0 my $exe = $Config::Config{exe_ext};
970             my @candidates = (
971             File::Spec->catfile($CPAN::iCwd,$^X),
972 0         0 $Config::Config{'perlpath'},
973             );
974 0         0 for my $perl_name ($^X, 'perl', 'perl5', "perl$]") {
975 0         0 for my $path (File::Spec->path(), $Config::Config{'binexp'}) {
976 0 0 0     0 if ( defined($path) && length $path && -d $path ) {
      0        
977 0         0 my $perl = File::Spec->catfile($path,$perl_name);
978 0         0 push @candidates, $perl;
979             # try with extension if not provided already
980 0 0 0     0 if ($^O eq 'VMS') {
    0          
981             # VMS might have a file version at the end
982 0 0       0 push @candidates, $perl . $exe
983             unless $perl =~ m/$exe(;\d+)?$/i;
984             } elsif (defined $exe && length $exe) {
985 0 0       0 push @candidates, $perl . $exe
986             unless $perl =~ m/$exe$/i;
987             }
988             }
989             }
990             }
991 0         0 for my $perl ( @candidates ) {
992 0 0 0     0 if (MM->maybe_command($perl) && _perl_is_same($perl)) {
993 0         0 $^X = $perl;
994 0         0 return $perl;
995             }
996             }
997             }
998 0         0 return $^X; # default fall back
999             }
1000              
1001             #-> sub CPAN::exists ;
1002             sub exists {
1003 31     31 0 63 my($mgr,$class,$id) = @_;
1004 31 50       65 CPAN::HandleConfig->load unless $CPAN::Config_loaded++;
1005 31         112 CPAN::Index->reload;
1006             ### Carp::croak "exists called without class argument" unless $class;
1007 31   50     54 $id ||= "";
1008 31 100       76 $id =~ s/:+/::/g if $class eq "CPAN::Module";
1009 31         53 my $exists;
1010 31 50       45 if (CPAN::_sqlite_running) {
1011 0   0     0 $exists = (exists $META->{readonly}{$class}{$id} or
1012             $CPAN::SQLite->set($class, $id));
1013             } else {
1014 31         79 $exists = exists $META->{readonly}{$class}{$id};
1015             }
1016 31   66     149 $exists ||= exists $META->{readwrite}{$class}{$id}; # unsafe meta access, ok
1017             }
1018              
1019             #-> sub CPAN::delete ;
1020             sub delete {
1021 0     0 0 0 my($mgr,$class,$id) = @_;
1022 0         0 delete $META->{readonly}{$class}{$id}; # unsafe meta access, ok
1023 0         0 delete $META->{readwrite}{$class}{$id}; # unsafe meta access, ok
1024             }
1025              
1026             #-> sub CPAN::has_usable
1027             # has_inst is sometimes too optimistic, we should replace it with this
1028             # has_usable whenever a case is given
1029             sub has_usable {
1030 115     115 1 205 my($self,$mod,$message) = @_;
1031 115 100       324 return 1 if $HAS_USABLE->{$mod};
1032 6         36 my $has_inst = $self->has_inst($mod,$message);
1033 6 100       29 return unless $has_inst;
1034 3         6 my $usable;
1035             $usable = {
1036              
1037             #
1038             # most of these subroutines warn on the frontend, then
1039             # die if the installed version is unusable for some
1040             # reason; has_usable() then returns false when it caught
1041             # an exception, otherwise returns true and caches that;
1042             #
1043             'CPAN::Meta' => [
1044             sub {
1045 1     1   8 require CPAN::Meta;
1046 1 50       37 unless (CPAN::Version->vge(CPAN::Meta->VERSION, 2.110350)) {
1047 0         0 for ("Will not use CPAN::Meta, need version 2.110350\n") {
1048 0         0 $CPAN::Frontend->mywarn($_);
1049 0         0 die $_;
1050             }
1051             }
1052             },
1053             ],
1054              
1055             'CPAN::Meta::Requirements' => [
1056             sub {
1057 0 0 0 0   0 if (defined $CPAN::Meta::Requirements::VERSION
1058             && CPAN::Version->vlt($CPAN::Meta::Requirements::VERSION, "2.120920")
1059             ) {
1060 0         0 delete $INC{"CPAN/Meta/Requirements.pm"};
1061             }
1062 0         0 require CPAN::Meta::Requirements;
1063 0 0       0 unless (CPAN::Version->vge(CPAN::Meta::Requirements->VERSION, 2.120920)) {
1064 0         0 for ("Will not use CPAN::Meta::Requirements, need version 2.120920\n") {
1065 0         0 $CPAN::Frontend->mywarn($_);
1066 0         0 die $_;
1067             }
1068             }
1069             },
1070             ],
1071              
1072             'CPAN::Reporter' => [
1073             sub {
1074 0 0 0 0   0 if (defined $CPAN::Reporter::VERSION
1075             && CPAN::Version->vlt($CPAN::Reporter::VERSION, "1.2011")
1076             ) {
1077 0         0 delete $INC{"CPAN/Reporter.pm"};
1078             }
1079 0         0 require CPAN::Reporter;
1080 0 0       0 unless (CPAN::Version->vge(CPAN::Reporter->VERSION, "1.2011")) {
1081 0         0 for ("Will not use CPAN::Reporter, need version 1.2011\n") {
1082 0         0 $CPAN::Frontend->mywarn($_);
1083 0         0 die $_;
1084             }
1085             }
1086             },
1087             ],
1088              
1089             LWP => [ # we frequently had "Can't locate object
1090             # method "new" via package "LWP::UserAgent" at
1091             # (eval 69) line 2006
1092 0     0   0 sub {require LWP},
1093 0     0   0 sub {require LWP::UserAgent},
1094 0     0   0 sub {require HTTP::Request},
1095 0     0   0 sub {require URI::URL;
1096 0 0       0 unless (CPAN::Version->vge(URI::URL::->VERSION,0.08)) {
1097 0         0 for ("Will not use URI::URL, need 0.08\n") {
1098 0         0 $CPAN::Frontend->mywarn($_);
1099 0         0 die $_;
1100             }
1101             }
1102             },
1103             ],
1104             'Net::FTP' => [
1105             sub {
1106 0   0 0   0 my $var = $CPAN::Config->{ftp_proxy} || $ENV{ftp_proxy};
1107 0 0 0     0 if ($var and $var =~ /^http:/i) {
1108             # rt #110833
1109 0         0 for ("Net::FTP cannot handle http proxy") {
1110 0         0 $CPAN::Frontend->mywarn($_);
1111 0         0 die $_;
1112             }
1113             }
1114             },
1115 0     0   0 sub {require Net::FTP},
1116 0     0   0 sub {require Net::Config},
1117             ],
1118             'IO::Socket::SSL' => [
1119             sub {
1120 0     0   0 require IO::Socket::SSL;
1121 0 0       0 unless (CPAN::Version->vge(IO::Socket::SSL::->VERSION,1.56)) {
1122 0         0 for ("Will not use IO::Socket::SSL, need 1.56\n") {
1123 0         0 $CPAN::Frontend->mywarn($_);
1124 0         0 die $_;
1125             }
1126             }
1127             }
1128             ],
1129             'Net::SSLeay' => [
1130             sub {
1131 0     0   0 require Net::SSLeay;
1132 0 0       0 unless (CPAN::Version->vge(Net::SSLeay::->VERSION,1.49)) {
1133 0         0 for ("Will not use Net::SSLeay, need 1.49\n") {
1134 0         0 $CPAN::Frontend->mywarn($_);
1135 0         0 die $_;
1136             }
1137             }
1138             }
1139             ],
1140             'HTTP::Tiny' => [
1141             sub {
1142 0     0   0 require HTTP::Tiny;
1143 0 0       0 unless (CPAN::Version->vge(HTTP::Tiny->VERSION, 0.005)) {
1144 0         0 for ("Will not use HTTP::Tiny, need version 0.005\n") {
1145 0         0 $CPAN::Frontend->mywarn($_);
1146 0         0 die $_;
1147             }
1148             }
1149             },
1150             ],
1151             'File::HomeDir' => [
1152 0     0   0 sub {require File::HomeDir;
1153 0 0       0 unless (CPAN::Version->vge(File::HomeDir::->VERSION, 0.52)) {
1154 0         0 for ("Will not use File::HomeDir, need 0.52\n") {
1155 0         0 $CPAN::Frontend->mywarn($_);
1156 0         0 die $_;
1157             }
1158             }
1159             },
1160             ],
1161             'Archive::Tar' => [
1162 1     1   8 sub {require Archive::Tar;
1163 1         7 my $demand = "1.50";
1164 1 50       38 unless (CPAN::Version->vge(Archive::Tar::->VERSION, $demand)) {
1165 0         0 my $atv = Archive::Tar->VERSION;
1166 0         0 for ("You have Archive::Tar $atv, but $demand or later is recommended. Please upgrade.\n") {
1167 0         0 $CPAN::Frontend->mywarn($_);
1168             # don't die, because we may need
1169             # Archive::Tar to upgrade
1170             }
1171              
1172             }
1173             },
1174             ],
1175             'File::Temp' => [
1176             # XXX we should probably delete from
1177             # %INC too so we can load after we
1178             # installed a new enough version --
1179             # I'm not sure.
1180 0     0   0 sub {require File::Temp;
1181 0 0       0 unless (CPAN::Version->vge(File::Temp::->VERSION,0.16)) {
1182 0         0 for ("Will not use File::Temp, need 0.16\n") {
1183 0         0 $CPAN::Frontend->mywarn($_);
1184 0         0 die $_;
1185             }
1186             }
1187             },
1188 3         223 ]
1189             };
1190 3 100       18 if ($usable->{$mod}) {
1191 2         20 local @INC = @INC;
1192 2 50       8 pop @INC if $INC[-1] eq '.';
1193 2         5 for my $c (0..$#{$usable->{$mod}}) {
  2         19  
1194 2         9 my $code = $usable->{$mod}[$c];
1195 2         4 my $ret = eval { &$code() };
  2         10  
1196 2 50       9 $ret = "" unless defined $ret;
1197 2 50       23 if ($@) {
1198             # warn "DEBUG: c[$c]\$\@[$@]ret[$ret]";
1199 0         0 return;
1200             }
1201             }
1202             }
1203 3         198 return $HAS_USABLE->{$mod} = 1;
1204             }
1205              
1206             sub frontend {
1207 0     0 1 0 shift;
1208 0 0       0 $CPAN::Frontend = shift if @_;
1209 0         0 $CPAN::Frontend;
1210             }
1211              
1212             sub use_inst {
1213 8     8 1 19 my ($self, $module) = @_;
1214              
1215 8 50       29 unless ($self->has_inst($module)) {
1216 0         0 $self->frontend->mydie("$module not installed, cannot continue");
1217             }
1218             }
1219              
1220             #-> sub CPAN::has_inst
1221             sub has_inst {
1222 51     51 1 2441 my($self,$mod,$message) = @_;
1223 51 50       140 Carp::croak("CPAN->has_inst() called without an argument")
1224             unless defined $mod;
1225 15 100       37 my %dont = map { $_ => 1 } keys %{$CPAN::META->{dontload_hash}||{}},
  51         333  
1226 51 50       276 keys %{$CPAN::Config->{dontload_hash}||{}},
1227 51 50       76 @{$CPAN::Config->{dontload_list}||[]};
  51         221  
1228 51 100 66     317 if (defined $message && $message eq "no" # as far as I remember only used by Nox
      100        
1229             ||
1230             $dont{$mod}
1231             ) {
1232 9   100     59 $CPAN::META->{dontload_hash}{$mod}||=1; # unsafe meta access, ok
1233 9         35 return 0;
1234             }
1235 42         357 local @INC = @INC;
1236 42 50       103 pop @INC if $INC[-1] eq '.';
1237 42         74 my $file = $mod;
1238 42         65 my $obj;
1239 42         195 $file =~ s|::|/|g;
1240 42         84 $file .= ".pm";
1241 42 100       130 if ($INC{$file}) {
    100          
    50          
    50          
    50          
1242             # checking %INC is wrong, because $INC{LWP} may be true
1243             # although $INC{"URI/URL.pm"} may have failed. But as
1244             # I really want to say "blah loaded OK", I have to somehow
1245             # cache results.
1246             ### warn "$file in %INC"; #debug
1247 25         110 return 1;
1248 17         10243 } elsif (eval { require $file }) {
1249             # eval is good: if we haven't yet read the database it's
1250             # perfect and if we have installed the module in the meantime,
1251             # it tries again. The second require is only a NOOP returning
1252             # 1 if we had success, otherwise it's retrying
1253              
1254 7         251723 my $mtime = (stat $INC{$file})[9];
1255             # privileged files loaded by has_inst; Note: we use $mtime
1256             # as a proxy for a checksum.
1257 7         57 $CPAN::Shell::reload->{$file} = $mtime;
1258 7         1076 my $v = eval "\$$mod\::VERSION";
1259 7 50       67 $v = $v ? " (v$v)" : "";
1260 7         378 CPAN::Shell->optprint("load_module","CPAN: $mod loaded ok$v\n");
1261 7 50       37 if ($mod eq "CPAN::WAIT") {
1262 0         0 push @CPAN::Shell::ISA, 'CPAN::WAIT';
1263             }
1264 7         82 return 1;
1265             } elsif ($mod eq "Net::FTP") {
1266             $CPAN::Frontend->mywarn(qq{
1267             Please, install Net::FTP as soon as possible. CPAN.pm installs it for you
1268             if you just type
1269             install Bundle::libnet
1270              
1271 0 0       0 }) unless $Have_warned->{"Net::FTP"}++;
1272 0         0 $CPAN::Frontend->mysleep(3);
1273             } elsif ($mod eq "Digest::SHA") {
1274 0 0       0 if ($Have_warned->{"Digest::SHA"}++) {
1275 0         0 $CPAN::Frontend->mywarn(qq{CPAN: checksum security checks disabled }.
1276             qq{because Digest::SHA not installed.\n});
1277             } else {
1278 0         0 $CPAN::Frontend->mywarn(qq{
1279             CPAN: checksum security checks disabled because Digest::SHA not installed.
1280             Please consider installing the Digest::SHA module.
1281              
1282             });
1283 0         0 $CPAN::Frontend->mysleep(2);
1284             }
1285             } elsif ($mod eq "Module::Signature") {
1286             # NOT prefs_lookup, we are not a distro
1287 0         0 my $check_sigs = $CPAN::Config->{check_sigs};
1288 0 0       0 if (not $check_sigs) {
    0          
1289             # they do not want us:-(
1290             } elsif (not $Have_warned->{"Module::Signature"}++) {
1291             # No point in complaining unless the user can
1292             # reasonably install and use it.
1293 0 0 0     0 if (eval { require Crypt::OpenPGP; 1 } ||
  0   0     0  
  0         0  
1294             (
1295             defined $CPAN::Config->{'gpg'}
1296             &&
1297             $CPAN::Config->{'gpg'} =~ /\S/
1298             )
1299             ) {
1300 0         0 $CPAN::Frontend->mywarn(qq{
1301             CPAN: Module::Signature security checks disabled because Module::Signature
1302             not installed. Please consider installing the Module::Signature module.
1303             You may also need to be able to connect over the Internet to the public
1304             key servers like pool.sks-keyservers.net or pgp.mit.edu.
1305              
1306             });
1307 0         0 $CPAN::Frontend->mysleep(2);
1308             }
1309             }
1310             } else {
1311 10         28 delete $INC{$file}; # if it inc'd LWP but failed during, say, URI
1312             }
1313 10         70 return 0;
1314             }
1315              
1316             #-> sub CPAN::instance ;
1317             sub instance {
1318 46     46 1 104 my($mgr,$class,$id) = @_;
1319 46         141 CPAN::Index->reload;
1320 46   50     88 $id ||= "";
1321             # unsafe meta access, ok?
1322 46 100       118 return $META->{readwrite}{$class}{$id} if exists $META->{readwrite}{$class}{$id};
1323 41   33     294 $META->{readwrite}{$class}{$id} ||= $class->new(ID => $id);
1324             }
1325              
1326             #-> sub CPAN::new ;
1327             sub new {
1328 13     13 0 319 bless {}, shift;
1329             }
1330              
1331             #-> sub CPAN::_exit_messages ;
1332             sub _exit_messages {
1333 0     0   0 my ($self) = @_;
1334 0   0     0 $self->{exit_messages} ||= [];
1335             }
1336              
1337             #-> sub CPAN::cleanup ;
1338             sub cleanup {
1339             # warn "cleanup called with arg[@_] End[$CPAN::End] Signal[$Signal]";
1340 13     13 0 146 local $SIG{__DIE__} = '';
1341 13         61 my($message) = @_;
1342 13         43 my $i = 0;
1343 13         43 my $ineval = 0;
1344 13         46 my($subroutine);
1345 13         171 while ((undef,undef,undef,$subroutine) = caller(++$i)) {
1346 26 100       175 $ineval = 1, last if
1347             $subroutine eq '(eval)';
1348             }
1349 13 50 33     249 return if $ineval && !$CPAN::End;
1350 13 50       476 return unless defined $META->{LOCK};
1351 0 0         return unless -f $META->{LOCK};
1352 0           $META->savehist;
1353 0   0       $META->{cachemgr} ||= CPAN::CacheMgr->new('atexit');
1354 0           close $META->{LOCKFH};
1355 0           unlink $META->{LOCK};
1356             # require Carp;
1357             # Carp::cluck("DEBUGGING");
1358 0 0         if ( $CPAN::CONFIG_DIRTY ) {
1359 0           $CPAN::Frontend->mywarn("Warning: Configuration not saved.\n");
1360             }
1361 0           $CPAN::Frontend->myprint("Lockfile removed.\n");
1362 0           for my $msg ( @{ $META->_exit_messages } ) {
  0            
1363 0           $CPAN::Frontend->myprint($msg);
1364             }
1365             }
1366              
1367             #-> sub CPAN::readhist
1368             sub readhist {
1369 0     0 0   my($self,$term,$histfile) = @_;
1370 0   0       my $histsize = $CPAN::Config->{'histsize'} || 100;
1371 0 0         $term->Attribs->{'MaxHistorySize'} = $histsize if (defined($term->Attribs->{'MaxHistorySize'}));
1372 0           my($fh) = FileHandle->new;
1373 0 0         open $fh, "<$histfile" or return;
1374 0           local $/ = "\n";
1375 0           while (<$fh>) {
1376 0           chomp;
1377 0           $term->AddHistory($_);
1378             }
1379 0           close $fh;
1380             }
1381              
1382             #-> sub CPAN::savehist
1383             sub savehist {
1384 0     0 0   my($self) = @_;
1385 0           my($histfile,$histsize);
1386 0 0         unless ($histfile = $CPAN::Config->{'histfile'}) {
1387 0           $CPAN::Frontend->mywarn("No history written (no histfile specified).\n");
1388 0           return;
1389             }
1390 0   0       $histsize = $CPAN::Config->{'histsize'} || 100;
1391 0 0         if ($CPAN::term) {
1392 0 0         unless ($CPAN::term->can("GetHistory")) {
1393 0           $CPAN::Frontend->mywarn("Terminal does not support GetHistory.\n");
1394 0           return;
1395             }
1396             } else {
1397 0           return;
1398             }
1399 0           my @h = $CPAN::term->GetHistory;
1400 0 0         splice @h, 0, @h-$histsize if @h>$histsize;
1401 0           my($fh) = FileHandle->new;
1402 0 0         open $fh, ">$histfile" or $CPAN::Frontend->mydie("Couldn't open >$histfile: $!");
1403 0           local $\ = local $, = "\n";
1404 0           print $fh @h;
1405 0           close $fh;
1406             }
1407              
1408             #-> sub CPAN::is_tested
1409             sub is_tested {
1410 0     0 1   my($self,$what,$when) = @_;
1411 0 0         unless ($what) {
1412 0           Carp::cluck("DEBUG: empty what");
1413 0           return;
1414             }
1415 0           $self->{is_tested}{$what} = $when;
1416             }
1417              
1418             #-> sub CPAN::reset_tested
1419             # forget all distributions tested -- resets what gets included in PERL5LIB
1420             sub reset_tested {
1421 0     0 0   my ($self) = @_;
1422 0           $self->{is_tested} = {};
1423             }
1424              
1425             #-> sub CPAN::is_installed
1426             # unsets the is_tested flag: as soon as the thing is installed, it is
1427             # not needed in set_perl5lib anymore
1428             sub is_installed {
1429 0     0 0   my($self,$what) = @_;
1430 0           delete $self->{is_tested}{$what};
1431             }
1432              
1433             sub _list_sorted_descending_is_tested {
1434 0     0     my($self) = @_;
1435 0           my $foul = 0;
1436             my @sorted = sort
1437 0   0       { ($self->{is_tested}{$b}||0) <=> ($self->{is_tested}{$a}||0) }
      0        
1438             grep
1439 0 0         { if ($foul){ 0 } elsif (-e) { 1 } else { $foul = $_; 0 } }
  0 0          
  0            
  0            
  0            
1440 0           keys %{$self->{is_tested}};
  0            
1441 0 0         if ($foul) {
1442 0           $CPAN::Frontend->mywarn("Lost build_dir detected ($foul), giving up all cached test results of currently running session.\n");
1443 0           for my $dbd (sort keys %{$self->{is_tested}}) { # distro-build-dir
  0            
1444 0           SEARCH: for my $d (sort { $a->id cmp $b->id } $CPAN::META->all_objects("CPAN::Distribution")) {
  0            
1445 0 0 0       if ($d->{build_dir} && $d->{build_dir} eq $dbd) {
1446 0           $CPAN::Frontend->mywarn(sprintf "Flushing cache for %s\n", $d->pretty_id);
1447 0           $d->fforce("");
1448 0           last SEARCH;
1449             }
1450             }
1451 0           delete $self->{is_tested}{$dbd};
1452             }
1453 0           return ();
1454             } else {
1455 0           return @sorted;
1456             }
1457             }
1458              
1459             #-> sub CPAN::set_perl5lib
1460             # Notes on max environment variable length:
1461             # - Win32 : XP or later, 8191; Win2000 or NT4, 2047
1462             {
1463             my $fh;
1464             sub set_perl5lib {
1465 0     0 0   my($self,$for) = @_;
1466 0 0         unless ($for) {
1467 0           (undef,undef,undef,$for) = caller(1);
1468 0           $for =~ s/.*://;
1469             }
1470 0   0       $self->{is_tested} ||= {};
1471 0 0         return unless %{$self->{is_tested}};
  0            
1472 0           my $env = $ENV{PERL5LIB};
1473 0 0         $env = $ENV{PERLLIB} unless defined $env;
1474 0           my @env;
1475 0 0 0       push @env, split /\Q$Config::Config{path_sep}\E/, $env if defined $env and length $env;
1476             #my @dirs = map {("$_/blib/arch", "$_/blib/lib")} keys %{$self->{is_tested}};
1477             #$CPAN::Frontend->myprint("Prepending @dirs to PERL5LIB.\n");
1478              
1479 0           my @dirs = map {("$_/blib/arch", "$_/blib/lib")} $self->_list_sorted_descending_is_tested;
  0            
1480 0 0         return if !@dirs;
1481              
1482 0 0         if (@dirs < 12) {
    0          
1483 0           $CPAN::Frontend->optprint('perl5lib', "Prepending @dirs to PERL5LIB for '$for'\n");
1484 0           $ENV{PERL5LIB} = join $Config::Config{path_sep}, @dirs, @env;
1485             } elsif (@dirs < 24 ) {
1486 0           my @d = map {my $cp = $_;
  0            
1487 0           $cp =~ s/^\Q$CPAN::Config->{build_dir}\E/%BUILDDIR%/;
1488 0           $cp
1489             } @dirs;
1490 0           $CPAN::Frontend->optprint('perl5lib', "Prepending @d to PERL5LIB; ".
1491             "%BUILDDIR%=$CPAN::Config->{build_dir} ".
1492             "for '$for'\n"
1493             );
1494 0           $ENV{PERL5LIB} = join $Config::Config{path_sep}, @dirs, @env;
1495             } else {
1496 0           my $cnt = keys %{$self->{is_tested}};
  0            
1497 0           my $newenv = join $Config::Config{path_sep}, @dirs, @env;
1498 0           $CPAN::Frontend->optprint('perl5lib', sprintf ("Prepending blib/arch and blib/lib of ".
1499             "%d build dirs to PERL5LIB, reaching size %d; ".
1500             "for '%s'\n", $cnt, length($newenv), $for)
1501             );
1502 0           $ENV{PERL5LIB} = $newenv;
1503             }
1504             }}
1505              
1506              
1507             1;
1508              
1509              
1510             __END__