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   34450 use strict;
  12         18  
  12         693  
4             package CPAN;
5             $CPAN::VERSION = '2.13';
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   49 use File::Spec ();
  12         61  
  12         749  
11             BEGIN {
12 12 50   12   175 if (File::Spec->can("rel2abs")) {
13 12         22 for my $inc (@INC) {
14 135 50       962 $inc = File::Spec->rel2abs($inc) unless ref $inc;
15             }
16             }
17 12         441 $SIG{WINCH} = 'IGNORE';
18             }
19 12     12   4014 use CPAN::Author;
  12         17  
  12         272  
20 12     12   4600 use CPAN::HandleConfig;
  12         17  
  12         334  
21 12     12   4087 use CPAN::Version;
  12         19  
  12         281  
22 12     12   4026 use CPAN::Bundle;
  12         19  
  12         273  
23 12     12   3992 use CPAN::CacheMgr;
  12         19  
  12         306  
24 12     12   3898 use CPAN::Complete;
  12         21  
  12         289  
25 12     12   48 use CPAN::Debug;
  12         11  
  12         224  
26 12     12   9507 use CPAN::Distribution;
  12         25  
  12         410  
27 12     12   4702 use CPAN::Distrostatus;
  12         19  
  12         258  
28 12     12   5056 use CPAN::FTP;
  12         18  
  12         360  
29 12     12   4789 use CPAN::Index 1.93; # https://rt.cpan.org/Ticket/Display.html?id=43349
  12         281  
  12         305  
30 12     12   57 use CPAN::InfoObj;
  12         11  
  12         177  
31 12     12   37 use CPAN::Module;
  12         16  
  12         169  
32 12     12   3703 use CPAN::Prompt;
  12         21  
  12         261  
33 12     12   3676 use CPAN::URL;
  12         84  
  12         256  
34 12     12   3866 use CPAN::Queue;
  12         20  
  12         283  
35 12     12   4486 use CPAN::Tarzip;
  12         20  
  12         306  
36 12     12   3724 use CPAN::DeferredCode;
  12         21  
  12         261  
37 12     12   6209 use CPAN::Shell;
  12         16  
  12         355  
38 12     12   4337 use CPAN::LWP::UserAgent;
  12         18  
  12         265  
39 12     12   4239 use CPAN::Exception::RecursiveDependency;
  12         18  
  12         268  
40 12     12   3703 use CPAN::Exception::yaml_not_installed;
  12         19  
  12         260  
41 12     12   3849 use CPAN::Exception::yaml_process_error;
  12         16  
  12         243  
42              
43 12     12   44 use Carp ();
  12         14  
  12         127  
44 12     12   32 use Config ();
  12         8  
  12         153  
45 12     12   26 use Cwd qw(chdir);
  12         12  
  12         456  
46 12     12   38 use DirHandle ();
  12         9  
  12         121  
47 12     12   31 use Exporter ();
  12         11  
  12         183  
48 12     12   7764 use ExtUtils::MakeMaker qw(prompt); # for some unknown reason,
  12         827796  
  12         651  
49             # 5.005_04 does not work without
50             # this
51 12     12   66 use File::Basename ();
  12         12  
  12         143  
52 12     12   4587 use File::Copy ();
  12         16583  
  12         245  
53 12     12   55 use File::Find;
  12         14  
  12         532  
54 12     12   49 use File::Path ();
  12         16  
  12         161  
55 12     12   4506 use FileHandle ();
  12         66986  
  12         289  
56 12     12   54 use Fcntl qw(:flock);
  12         17  
  12         1287  
57 12     12   5801 use Safe ();
  12         283317  
  12         466  
58 12     12   4700 use Sys::Hostname qw(hostname);
  12         9207  
  12         632  
59 12     12   4656 use Text::ParseWords ();
  12         10148  
  12         245  
60 12     12   4955 use Text::Wrap ();
  12         21714  
  12         455  
61              
62             # protect against "called too early"
63             sub find_perl ();
64             sub anycwd ();
65             sub _uniq;
66              
67 12     12   4193 no lib ".";
  12         4619  
  12         53  
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   11718 END { $CPAN::End++; &cleanup; }
  12         41  
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         12539 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   3452 );
  12         15  
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   10 $autoload_recursion++;
184 1         2 my($l) = $AUTOLOAD;
185 1         6 $l =~ s/.*:://;
186 1 50       4 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       3 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         2 my(%export);
198 1         29 @export{@EXPORT} = '';
199 1 50       14 CPAN::HandleConfig->load unless $CPAN::Config_loaded++;
200 1 50       3 if (exists $export{$l}) {
201 0         0 CPAN::Shell->$l(@_);
202             } else {
203 1         11 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   58 use strict;
  12         13  
  12         255  
358 12     12   37 use vars qw($import_done);
  12         12  
  12         11238  
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   14 my $yaml_module = $CPAN::Config->{yaml_module} || "YAML";
521 3 50 33     10 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     15 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         7 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   54 no strict 'refs';
  12         14  
  12         34471  
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   350 if ($negative_cache->{time} && time < $negative_cache->{time} + 60) {
627             # need to cache the result, otherwise too slow
628 126         225 return $negative_cache->{fact};
629             } else {
630 1         2 $negative_cache = {}; # reset
631             }
632 1   33     3 my $ret = $CPAN::Config->{use_sqlite} && ($CPAN::SQLite || _init_sqlite());
633 1 50       2 return $ret if $ret; # fast anyway
634 1         2 $negative_cache->{time} = time;
635 1         3 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   2066 if (kill 0, $otherpid or $!{EPERM}) {
  5 0       4425  
  5         16155  
  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 13 my $getcwd;
922 12   100     56 $getcwd = $CPAN::Config->{'getcwd'} || 'cwd';
923 12         52 CPAN->$getcwd();
924             }
925              
926             #-> sub CPAN::cwd ;
927 12     12 1 30063 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 446 if ( File::Spec->file_name_is_absolute($^X) ) {
953 12         72 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 35 my($mgr,$class,$id) = @_;
991 31 50       61 CPAN::HandleConfig->load unless $CPAN::Config_loaded++;
992 31         72 CPAN::Index->reload;
993             ### Carp::croak "exists called without class argument" unless $class;
994 31   50     49 $id ||= "";
995 31 100       53 $id =~ s/:+/::/g if $class eq "CPAN::Module";
996 31         23 my $exists;
997 31 50       31 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         52 $exists = exists $META->{readonly}{$class}{$id};
1002             }
1003 31   66     157 $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 119 my($self,$mod,$message) = @_;
1018 116 100       308 return 1 if $HAS_USABLE->{$mod};
1019 4         14 my $has_inst = $self->has_inst($mod,$message);
1020 4 50       19 return unless $has_inst;
1021 4         5 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   4 require CPAN::Meta;
1030 1 50       16 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   7 sub {require Archive::Tar;
1093 1         1 my $demand = "1.50";
1094 1 50       20 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         123 ]
1119             };
1120 4 100       14 if ($usable->{$mod}) {
1121 2         3 for my $c (0..$#{$usable->{$mod}}) {
  2         11  
1122 2         5 my $code = $usable->{$mod}[$c];
1123 2         3 my $ret = eval { &$code() };
  2         5  
1124 2 50       8 $ret = "" unless defined $ret;
1125 2 50       6 if ($@) {
1126             # warn "DEBUG: c[$c]\$\@[$@]ret[$ret]";
1127 0         0 return;
1128             }
1129             }
1130             }
1131 4         135 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 10 my ($self, $module) = @_;
1142              
1143 8 50       15 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 1109 my($self,$mod,$message) = @_;
1151 48 50       88 Carp::croak("CPAN->has_inst() called without an argument")
1152             unless defined $mod;
1153 15 100       28 my %dont = map { $_ => 1 } keys %{$CPAN::META->{dontload_hash}||{}},
  48         214  
1154 48 50       178 keys %{$CPAN::Config->{dontload_hash}||{}},
1155 48 50       43 @{$CPAN::Config->{dontload_list}||[]};
  48         178  
1156 48 100 66     207 if (defined $message && $message eq "no" # as far as I remember only used by Nox
      66        
1157             ||
1158             $dont{$mod}
1159             ) {
1160 9   100     36 $CPAN::META->{dontload_hash}{$mod}||=1; # unsafe meta access, ok
1161 9         25 return 0;
1162             }
1163 39         44 my $file = $mod;
1164 39         26 my $obj;
1165 39         111 $file =~ s|::|/|g;
1166 39         43 $file .= ".pm";
1167 39 100       80 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         84 return 1;
1174 13         6573 } 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         147917 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         28 $CPAN::Shell::reload->{$file} = $mtime;
1184 7         724 my $v = eval "\$$mod\::VERSION";
1185 7 50       35 $v = $v ? " (v$v)" : "";
1186 7         84 CPAN::Shell->optprint("load_module","CPAN: $mod loaded ok$v\n");
1187 7 50       26 if ($mod eq "CPAN::WAIT") {
1188 0         0 push @CPAN::Shell::ISA, 'CPAN::WAIT';
1189             }
1190 7         41 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         9 delete $INC{$file}; # if it inc'd LWP but failed during, say, URI
1238             }
1239 6         48 return 0;
1240             }
1241              
1242             #-> sub CPAN::instance ;
1243             sub instance {
1244 43     43 1 50 my($mgr,$class,$id) = @_;
1245 43         83 CPAN::Index->reload;
1246 43   50     55 $id ||= "";
1247             # unsafe meta access, ok?
1248 43 100       87 return $META->{readwrite}{$class}{$id} if exists $META->{readwrite}{$class}{$id};
1249 39   33     215 $META->{readwrite}{$class}{$id} ||= $class->new(ID => $id);
1250             }
1251              
1252             #-> sub CPAN::new ;
1253             sub new {
1254 12     12 0 116 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 57 local $SIG{__DIE__} = '';
1267 12         26 my($message) = @_;
1268 12         25 my $i = 0;
1269 12         18 my $ineval = 0;
1270 12         17 my($subroutine);
1271 12         101 while ((undef,undef,undef,$subroutine) = caller(++$i)) {
1272 24 100       113 $ineval = 1, last if
1273             $subroutine eq '(eval)';
1274             }
1275 12 50 33     97 return if $ineval && !$CPAN::End;
1276 12 50       101 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__