File Coverage

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