File Coverage

blib/lib/CPAN.pm
Criterion Covered Total %
statement 245 783 31.2
branch 47 372 12.6
condition 23 154 14.9
subroutine 64 106 60.3
pod 13 27 48.1
total 392 1442 27.1


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   41492 use strict;
  12         22  
  12         857  
4             package CPAN;
5             $CPAN::VERSION = '2.07';
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   51 use File::Spec ();
  12         13  
  12         650  
11             BEGIN {
12 12 50   12   200 if (File::Spec->can("rel2abs")) {
13 12         27 for my $inc (@INC) {
14 135 50       1253 $inc = File::Spec->rel2abs($inc) unless ref $inc;
15             }
16             }
17             }
18 12     12   4422 use CPAN::Author;
  12         25  
  12         316  
19 12     12   5166 use CPAN::HandleConfig;
  12         23  
  12         356  
20 12     12   4290 use CPAN::Version;
  12         20  
  12         314  
21 12     12   4074 use CPAN::Bundle;
  12         21  
  12         378  
22 12     12   4463 use CPAN::CacheMgr;
  12         22  
  12         349  
23 12     12   4284 use CPAN::Complete;
  12         21  
  12         341  
24 12     12   53 use CPAN::Debug;
  12         15  
  12         174  
25 12     12   9974 use CPAN::Distribution;
  12         38  
  12         519  
26 12     12   5566 use CPAN::Distrostatus;
  12         55  
  12         291  
27 12     12   5321 use CPAN::FTP;
  12         30  
  12         424  
28 12     12   5286 use CPAN::Index 1.93; # https://rt.cpan.org/Ticket/Display.html?id=43349
  12         343  
  12         358  
29 12     12   66 use CPAN::InfoObj;
  12         16  
  12         187  
30 12     12   45 use CPAN::Module;
  12         16  
  12         180  
31 12     12   4324 use CPAN::Prompt;
  12         20  
  12         283  
32 12     12   3969 use CPAN::URL;
  12         19  
  12         362  
33 12     12   4038 use CPAN::Queue;
  12         24  
  12         296  
34 12     12   4448 use CPAN::Tarzip;
  12         29  
  12         338  
35 12     12   4350 use CPAN::DeferredCode;
  12         31  
  12         271  
36 12     12   6425 use CPAN::Shell;
  12         29  
  12         401  
37 12     12   5014 use CPAN::LWP::UserAgent;
  12         20  
  12         289  
38 12     12   4311 use CPAN::Exception::RecursiveDependency;
  12         21  
  12         301  
39 12     12   4309 use CPAN::Exception::yaml_not_installed;
  12         21  
  12         309  
40 12     12   4283 use CPAN::Exception::yaml_process_error;
  12         22  
  12         293  
41              
42 12     12   54 use Carp ();
  12         11  
  12         148  
43 12     12   40 use Config ();
  12         13  
  12         174  
44 12     12   40 use Cwd qw(chdir);
  12         14  
  12         616  
45 12     12   47 use DirHandle ();
  12         14  
  12         139  
46 12     12   42 use Exporter ();
  12         17  
  12         204  
47 12     12   8563 use ExtUtils::MakeMaker qw(prompt); # for some unknown reason,
  12         818916  
  12         850  
48             # 5.005_04 does not work without
49             # this
50 12     12   100 use File::Basename ();
  12         20  
  12         187  
51 12     12   5053 use File::Copy ();
  12         18929  
  12         277  
52 12     12   59 use File::Find;
  12         15  
  12         583  
53 12     12   56 use File::Path ();
  12         14  
  12         151  
54 12     12   4776 use FileHandle ();
  12         74788  
  12         407  
55 12     12   75 use Fcntl qw(:flock);
  12         18  
  12         1749  
56 12     12   6903 use Safe ();
  12         336185  
  12         635  
57 12     12   5407 use Sys::Hostname qw(hostname);
  12         10973  
  12         668  
58 12     12   5435 use Text::ParseWords ();
  12         11768  
  12         264  
59 12     12   5316 use Text::Wrap ();
  12         25677  
  12         485  
60              
61             # protect against "called too early"
62             sub find_perl ();
63             sub anycwd ();
64             sub _uniq;
65              
66 12     12   4909 no lib ".";
  12         5288  
  12         58  
67              
68             require Mac::BuildTools if $^O eq 'MacOS';
69             if ($ENV{PERL5_CPAN_IS_RUNNING} && $$ != $ENV{PERL5_CPAN_IS_RUNNING}) {
70             $ENV{PERL5_CPAN_IS_RUNNING_IN_RECURSION} ||= $ENV{PERL5_CPAN_IS_RUNNING};
71             my @rec = _uniq split(/,/, $ENV{PERL5_CPAN_IS_RUNNING_IN_RECURSION}), $$;
72             $ENV{PERL5_CPAN_IS_RUNNING_IN_RECURSION} = join ",", @rec;
73             # warn "# Note: Recursive call of CPAN.pm detected\n";
74             my $w = sprintf "# Note: CPAN.pm is running in process %d now", pop @rec;
75             my %sleep = (
76             5 => 30,
77             6 => 60,
78             7 => 120,
79             );
80             my $sleep = @rec > 7 ? 300 : ($sleep{scalar @rec}||0);
81             my $verbose = @rec >= 4;
82             while (@rec) {
83             $w .= sprintf " which has been called by process %d", pop @rec;
84             }
85             if ($sleep) {
86             $w .= ".\n\n# Sleeping $sleep seconds to protect other processes\n";
87             }
88             if ($verbose) {
89             warn $w;
90             }
91             local $| = 1;
92             while ($sleep > 0) {
93             printf "\r#%5d", --$sleep;
94             sleep 1;
95             }
96             print "\n";
97             }
98             $ENV{PERL5_CPAN_IS_RUNNING}=$$;
99             $ENV{PERL5_CPANPLUS_IS_RUNNING}=$$; # https://rt.cpan.org/Ticket/Display.html?id=23735
100              
101 12     12   16943 END { $CPAN::End++; &cleanup; }
  12         49  
102              
103             $CPAN::Signal ||= 0;
104             $CPAN::Frontend ||= "CPAN::Shell";
105             unless (@CPAN::Defaultsites) {
106             @CPAN::Defaultsites = map {
107             CPAN::URL->new(TEXT => $_, FROM => "DEF")
108             }
109             "http://www.perl.org/CPAN/",
110             "ftp://ftp.perl.org/pub/CPAN/";
111             }
112             # $CPAN::iCwd (i for initial)
113             $CPAN::iCwd ||= CPAN::anycwd();
114             $CPAN::Perl ||= CPAN::find_perl();
115             $CPAN::Defaultdocs ||= "http://search.cpan.org/perldoc?";
116             $CPAN::Defaultrecent ||= "http://search.cpan.org/uploads.rdf";
117             $CPAN::Defaultrecent ||= "http://cpan.uwinnipeg.ca/htdocs/cpan.xml";
118              
119             # our globals are getting a mess
120 12         15230 use vars qw(
121             $AUTOLOAD
122             $Be_Silent
123             $CONFIG_DIRTY
124             $Defaultdocs
125             $Echo_readline
126             $Frontend
127             $GOTOSHELL
128             $HAS_USABLE
129             $Have_warned
130             $MAX_RECURSION
131             $META
132             $RUN_DEGRADED
133             $Signal
134             $SQLite
135             $Suppress_readline
136             $VERSION
137             $autoload_recursion
138             $term
139             @Defaultsites
140             @EXPORT
141 12     12   4131 );
  12         19  
142              
143             $MAX_RECURSION = 32;
144              
145             @CPAN::ISA = qw(CPAN::Debug Exporter);
146              
147             # note that these functions live in CPAN::Shell and get executed via
148             # AUTOLOAD when called directly
149             @EXPORT = qw(
150             autobundle
151             bundle
152             clean
153             cvs_import
154             expand
155             force
156             fforce
157             get
158             install
159             install_tested
160             is_tested
161             make
162             mkmyconfig
163             notest
164             perldoc
165             readme
166             recent
167             recompile
168             report
169             shell
170             smoke
171             test
172             upgrade
173             );
174              
175             sub soft_chdir_with_alternatives ($);
176              
177             {
178             $autoload_recursion ||= 0;
179              
180             #-> sub CPAN::AUTOLOAD ;
181             sub AUTOLOAD { ## no critic
182 1     1   19 $autoload_recursion++;
183 1         3 my($l) = $AUTOLOAD;
184 1         11 $l =~ s/.*:://;
185 1 50       7 if ($CPAN::Signal) {
186 0         0 warn "Refusing to autoload '$l' while signal pending";
187 0         0 $autoload_recursion--;
188 0         0 return;
189             }
190 1 50       5 if ($autoload_recursion > 1) {
191 0         0 my $fullcommand = join " ", map { "'$_'" } $l, @_;
  0         0  
192 0         0 warn "Refusing to autoload $fullcommand in recursion\n";
193 0         0 $autoload_recursion--;
194 0         0 return;
195             }
196 1         2 my(%export);
197 1         40 @export{@EXPORT} = '';
198 1 50       20 CPAN::HandleConfig->load unless $CPAN::Config_loaded++;
199 1 50       5 if (exists $export{$l}) {
200 0         0 CPAN::Shell->$l(@_);
201             } else {
202 1         14 die(qq{Unknown CPAN command "$AUTOLOAD". }.
203             qq{Type ? for help.\n});
204             }
205 0         0 $autoload_recursion--;
206             }
207             }
208              
209             {
210             my $x = *SAVEOUT; # avoid warning
211             open($x,">&STDOUT") or die "dup failed";
212             my $redir = 0;
213             sub _redirect(@) {
214             #die if $redir;
215 0     0   0 local $_;
216 0         0 push(@_,undef);
217 0         0 while(defined($_=shift)) {
218 0 0       0 if (s/^\s*>//){
    0          
219 0 0       0 my ($m) = s/^>// ? ">" : "";
220 0         0 s/\s+//;
221 0 0       0 $_=shift unless length;
222 0 0       0 die "no dest" unless defined;
223 0 0       0 open(STDOUT,">$m$_") or die "open:$_:$!\n";
224 0         0 $redir=1;
225             } elsif ( s/^\s*\|\s*// ) {
226 0         0 my $pipe="| $_";
227 0         0 while(defined($_[0])){
228 0         0 $pipe .= ' ' . shift;
229             }
230 0 0       0 open(STDOUT,$pipe) or die "open:$pipe:$!\n";
231 0         0 $redir=1;
232             } else {
233 0         0 push(@_,$_);
234             }
235             }
236 0         0 return @_;
237             }
238             sub _unredirect {
239 0 0   0   0 return unless $redir;
240 0         0 $redir = 0;
241             ## redirect: unredirect and propagate errors. explicit close to wait for pipe.
242 0         0 close(STDOUT);
243 0         0 open(STDOUT,">&SAVEOUT");
244 0 0       0 die "$@" if "$@";
245             ## redirect: done
246             }
247             }
248              
249             sub _uniq {
250 0     0   0 my(@list) = @_;
251 0         0 my %seen;
252 0         0 return grep { !$seen{$_}++ } @list;
  0         0  
253             }
254              
255             #-> sub CPAN::shell ;
256             sub shell {
257 0     0 1 0 my($self) = @_;
258 0 0       0 $Suppress_readline = ! -t STDIN unless defined $Suppress_readline;
259 0 0       0 CPAN::HandleConfig->load unless $CPAN::Config_loaded++;
260              
261 0   0     0 my $oprompt = shift || CPAN::Prompt->new;
262 0         0 my $prompt = $oprompt;
263 0   0     0 my $commandline = shift || "";
264 0   0     0 $CPAN::CurrentCommandId ||= 1;
265              
266 0         0 local($^W) = 1;
267 0 0       0 unless ($Suppress_readline) {
268 0         0 require Term::ReadLine;
269 0 0 0     0 if (! $term
270             or
271             $term->ReadLine eq "Term::ReadLine::Stub"
272             ) {
273 0         0 $term = Term::ReadLine->new('CPAN Monitor');
274             }
275 0 0       0 if ($term->ReadLine eq "Term::ReadLine::Gnu") {
276 0         0 my $attribs = $term->Attribs;
277             $attribs->{attempted_completion_function} = sub {
278 0     0   0 &CPAN::Complete::gnu_cpl;
279             }
280 0         0 } else {
281 0         0 $readline::rl_completion_function =
282             $readline::rl_completion_function = 'CPAN::Complete::cpl';
283             }
284 0 0       0 if (my $histfile = $CPAN::Config->{'histfile'}) {{
285 0 0       0 unless ($term->can("AddHistory")) {
  0         0  
286 0         0 $CPAN::Frontend->mywarn("Terminal does not support AddHistory.\n");
287 0         0 last;
288             }
289 0         0 $META->readhist($term,$histfile);
290             }}
291 0         0 for ($CPAN::Config->{term_ornaments}) { # alias
292 0         0 local $Term::ReadLine::termcap_nowarn = 1;
293 0 0       0 $term->ornaments($_) if defined;
294             }
295             # $term->OUT is autoflushed anyway
296 0         0 my $odef = select STDERR;
297 0         0 $| = 1;
298 0         0 select STDOUT;
299 0         0 $| = 1;
300 0         0 select $odef;
301             }
302              
303 0         0 $META->checklock();
304 0 0       0 my @cwd = grep { defined $_ and length $_ }
  0 0       0  
305             CPAN::anycwd(),
306             File::Spec->can("tmpdir") ? File::Spec->tmpdir() : (),
307             File::Spec->rootdir();
308 0         0 my $try_detect_readline;
309 0 0       0 $try_detect_readline = $term->ReadLine eq "Term::ReadLine::Stub" if $term;
310 0 0       0 unless ($CPAN::Config->{inhibit_startup_message}) {
311 0 0       0 my $rl_avail = $Suppress_readline ? "suppressed" :
    0          
312             ($term->ReadLine ne "Term::ReadLine::Stub") ? "enabled" :
313             "available (maybe install Bundle::CPAN or Bundle::CPANxxl?)";
314 0         0 $CPAN::Frontend->myprint(
315             sprintf qq{
316             cpan shell -- CPAN exploration and modules installation (v%s)
317             Enter 'h' for help.
318              
319             },
320             $CPAN::VERSION,
321             $rl_avail
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   66 use strict;
  12         36  
  12         406  
358 12     12   50 use vars qw($import_done);
  12         21  
  12         13796  
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 (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   15 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     14 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         8 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   65 no strict 'refs';
  12         19  
  12         39911  
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 0 0       0 $CPAN::Frontend->mywarn(qq{CPAN::SQLite not installed, trying to work without\n})
616             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   399 if ($negative_cache->{time} && time < $negative_cache->{time} + 60) {
627             # need to cache the result, otherwise too slow
628 126         271 return $negative_cache->{fact};
629             } else {
630 1         3 $negative_cache = {}; # reset
631             }
632 1   33     4 my $ret = $CPAN::Config->{use_sqlite} && ($CPAN::SQLite || _init_sqlite());
633 1 50       3 return $ret if $ret; # fast anyway
634 1         2 $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 0         0 my $this_fingerprint = {
653             '$^X' => CPAN::find_perl,
654             sitearchexp => $Config::Config{sitearchexp},
655             '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 && $otherpid) {
713 0         0 chomp $otherpid;
714             }
715 0 0 0     0 if (defined $otherhost && $otherhost) {
716 0         0 chomp $otherhost;
717             }
718 0         0 my $thishost = hostname();
719 0 0 0     0 if (defined $otherhost && defined $thishost &&
    0 0        
    0 0        
      0        
      0        
720             $otherhost ne '' && $thishost ne '' &&
721             $otherhost ne $thishost) {
722 0         0 $CPAN::Frontend->mydie(sprintf("CPAN.pm panic: Lockfile '$lockfile'\n".
723             "reports other host $otherhost and other ".
724             "process $otherpid.\n".
725             "Cannot proceed.\n"));
726             } elsif ($RUN_DEGRADED) {
727 0         0 $CPAN::Frontend->mywarn("Running in downgraded mode (experimental)\n");
728             } elsif (defined $otherpid && $otherpid) {
729 0 0       0 return if $$ == $otherpid; # should never happen
730 0         0 $CPAN::Frontend->mywarn(
731             qq{
732             There seems to be running another CPAN process (pid $otherpid). Contacting...
733             });
734 5 0 0 5   2568 if (kill 0, $otherpid or $!{EPERM}) {
  5 0       5196  
  5         20003  
  0         0  
735 0         0 $CPAN::Frontend->mywarn(qq{Other job is running.\n});
736 0         0 my($ans) =
737             CPAN::Shell::colorable_makemaker_prompt
738             (qq{Shall I try to run in downgraded }.
739             qq{mode? (Y/n)},"y");
740 0 0       0 if ($ans =~ /^y/i) {
741 0         0 $CPAN::Frontend->mywarn("Running in downgraded mode (experimental).
742             Please report if something unexpected happens\n");
743 0         0 $RUN_DEGRADED = 1;
744 0         0 for ($CPAN::Config) {
745             # XXX
746             # $_->{build_dir_reuse} = 0; # 2006-11-17 akoenig Why was that?
747 0         0 $_->{commandnumber_in_prompt} = 0; # visibility
748 0         0 $_->{histfile} = ""; # who should win otherwise?
749 0         0 $_->{cache_metadata} = 0; # better would be a lock?
750 0         0 $_->{use_sqlite} = 0; # better would be a write lock!
751 0         0 $_->{auto_commit} = 0; # we are violent, do not persist
752 0         0 $_->{test_report} = 0; # Oliver Paukstadt had sent wrong reports in degraded mode
753             }
754             } else {
755 0         0 $CPAN::Frontend->mydie("
756             You may want to kill the other job and delete the lockfile. On UNIX try:
757             kill $otherpid
758             rm $lockfile
759             ");
760             }
761             } elsif (-w $lockfile) {
762 0         0 my($ans) =
763             CPAN::Shell::colorable_makemaker_prompt
764             (qq{Other job not responding. Shall I overwrite }.
765             qq{the lockfile '$lockfile'? (Y/n)},"y");
766 0 0       0 $CPAN::Frontend->myexit("Ok, bye\n")
767             unless $ans =~ /^y/i;
768             } else {
769 0         0 Carp::croak(
770             qq{Lockfile '$lockfile' not writable by you. }.
771             qq{Cannot proceed.\n}.
772             qq{ On UNIX try:\n}.
773             qq{ rm '$lockfile'\n}.
774             qq{ and then rerun us.\n}
775             );
776             }
777             } else {
778 0         0 $CPAN::Frontend->mydie(sprintf("CPAN.pm panic: Found invalid lockfile ".
779             "'$lockfile', please remove. Cannot proceed.\n"));
780             }
781             }
782 0         0 my $dotcpan = $CPAN::Config->{cpan_home};
783 0         0 eval { File::Path::mkpath($dotcpan);};
  0         0  
784 0 0       0 if ($@) {
785             # A special case at least for Jarkko.
786 0         0 my $firsterror = $@;
787 0         0 my $seconderror;
788             my $symlinkcpan;
789 0 0       0 if (-l $dotcpan) {
790 0         0 $symlinkcpan = readlink $dotcpan;
791 0 0       0 die "readlink $dotcpan failed: $!" unless defined $symlinkcpan;
792 0         0 eval { File::Path::mkpath($symlinkcpan); };
  0         0  
793 0 0       0 if ($@) {
794 0         0 $seconderror = $@;
795             } else {
796 0         0 $CPAN::Frontend->mywarn(qq{
797             Working directory $symlinkcpan created.
798             });
799             }
800             }
801 0 0       0 unless (-d $dotcpan) {
802 0         0 my $mess = qq{
803             Your configuration suggests "$dotcpan" as your
804             CPAN.pm working directory. I could not create this directory due
805             to this error: $firsterror\n};
806 0 0       0 $mess .= qq{
807             As "$dotcpan" is a symlink to "$symlinkcpan",
808             I tried to create that, but I failed with this error: $seconderror
809             } if $seconderror;
810 0         0 $mess .= qq{
811             Please make sure the directory exists and is writable.
812             };
813 0         0 $CPAN::Frontend->mywarn($mess);
814 0         0 return suggest_myconfig;
815             }
816             } # $@ after eval mkpath $dotcpan
817 0         0 if (0) { # to test what happens when a race condition occurs
818             for (reverse 1..10) {
819             print $_, "\n";
820             sleep 1;
821             }
822             }
823             # locking
824 0 0 0     0 if (!$RUN_DEGRADED && !$self->{LOCKFH}) {
825 0         0 my $fh;
826 0 0       0 unless ($fh = FileHandle->new("+>>$lockfile")) {
827 0         0 $CPAN::Frontend->mywarn(qq{
828              
829             Your configuration suggests that CPAN.pm should use a working
830             directory of
831             $CPAN::Config->{cpan_home}
832             Unfortunately we could not create the lock file
833             $lockfile
834             due to '$!'.
835              
836             Please make sure that the configuration variable
837             \$CPAN::Config->{cpan_home}
838             points to a directory where you can write a .lock file. You can set
839             this variable in either a CPAN/MyConfig.pm or a CPAN/Config.pm in your
840             \@INC path;
841             });
842 0         0 return suggest_myconfig;
843             }
844 0         0 my $sleep = 1;
845 0         0 while (!CPAN::_flock($fh, LOCK_EX|LOCK_NB)) {
846 0 0       0 if ($sleep>10) {
847 0         0 $CPAN::Frontend->mydie("Giving up\n");
848             }
849 0         0 $CPAN::Frontend->mysleep($sleep++);
850 0         0 $CPAN::Frontend->mywarn("Could not lock lockfile with flock: $!; retrying\n");
851             }
852              
853 0         0 seek $fh, 0, 0;
854 0         0 truncate $fh, 0;
855 0         0 $fh->autoflush(1);
856 0         0 $fh->print($$, "\n");
857 0         0 $fh->print(hostname(), "\n");
858 0         0 $self->{LOCK} = $lockfile;
859 0         0 $self->{LOCKFH} = $fh;
860             }
861             $SIG{TERM} = sub {
862 0     0   0 my $sig = shift;
863 0         0 &cleanup;
864 0         0 $CPAN::Frontend->mydie("Got SIG$sig, leaving");
865 0         0 };
866             $SIG{INT} = sub {
867             # no blocks!!!
868 0     0   0 my $sig = shift;
869 0 0       0 &cleanup if $Signal;
870 0 0       0 die "Got yet another signal" if $Signal > 1;
871 0 0       0 $CPAN::Frontend->mydie("Got another SIG$sig") if $Signal;
872 0         0 $CPAN::Frontend->mywarn("Caught SIG$sig, trying to continue\n");
873 0         0 $Signal++;
874 0         0 };
875              
876             # From: Larry Wall
877             # Subject: Re: deprecating SIGDIE
878             # To: perl5-porters@perl.org
879             # Date: Thu, 30 Sep 1999 14:58:40 -0700 (PDT)
880             #
881             # The original intent of __DIE__ was only to allow you to substitute one
882             # kind of death for another on an application-wide basis without respect
883             # to whether you were in an eval or not. As a global backstop, it should
884             # not be used any more lightly (or any more heavily :-) than class
885             # UNIVERSAL. Any attempt to build a general exception model on it should
886             # be politely squashed. Any bug that causes every eval {} to have to be
887             # modified should be not so politely squashed.
888             #
889             # Those are my current opinions. It is also my opinion that polite
890             # arguments degenerate to personal arguments far too frequently, and that
891             # when they do, it's because both people wanted it to, or at least didn't
892             # sufficiently want it not to.
893             #
894             # Larry
895              
896             # global backstop to cleanup if we should really die
897 0         0 $SIG{__DIE__} = \&cleanup;
898 0 0       0 $self->debug("Signal handler set.") if $CPAN::DEBUG;
899             }
900              
901             #-> sub CPAN::DESTROY ;
902             sub DESTROY {
903 0     0   0 &cleanup; # need an eval?
904             }
905              
906             #-> sub CPAN::anycwd ;
907             sub anycwd () {
908 12     12 1 16 my $getcwd;
909 12   100     64 $getcwd = $CPAN::Config->{'getcwd'} || 'cwd';
910 12         53 CPAN->$getcwd();
911             }
912              
913             #-> sub CPAN::cwd ;
914 12     12 1 35586 sub cwd {Cwd::cwd();}
915              
916             #-> sub CPAN::getcwd ;
917 0     0 1 0 sub getcwd {Cwd::getcwd();}
918              
919             #-> sub CPAN::fastcwd ;
920 0     0 1 0 sub fastcwd {Cwd::fastcwd();}
921              
922             #-> sub CPAN::getdcwd ;
923 0     0 1 0 sub getdcwd {Cwd::getdcwd();}
924              
925             #-> sub CPAN::backtickcwd ;
926 0     0 1 0 sub backtickcwd {my $cwd = `cwd`; chomp $cwd; $cwd}
  0         0  
  0         0  
927              
928             # Adapted from Probe::Perl
929             #-> sub CPAN::_perl_is_same
930             sub _perl_is_same {
931 0     0   0 my ($perl) = @_;
932 0   0     0 return MM->maybe_command($perl)
933             && `$perl -MConfig=myconfig -e print -e myconfig` eq Config->myconfig;
934             }
935              
936             # Adapted in part from Probe::Perl
937             #-> sub CPAN::find_perl ;
938             sub find_perl () {
939 12 50   12 0 498 if ( File::Spec->file_name_is_absolute($^X) ) {
940 12         97 return $^X;
941             }
942             else {
943 0         0 my $exe = $Config::Config{exe_ext};
944 0         0 my @candidates = (
945             File::Spec->catfile($CPAN::iCwd,$^X),
946             $Config::Config{'perlpath'},
947             );
948 0         0 for my $perl_name ($^X, 'perl', 'perl5', "perl$]") {
949 0         0 for my $path (File::Spec->path(), $Config::Config{'binexp'}) {
950 0 0 0     0 if ( defined($path) && length $path && -d $path ) {
      0        
951 0         0 my $perl = File::Spec->catfile($path,$perl_name);
952 0         0 push @candidates, $perl;
953             # try with extension if not provided already
954 0 0 0     0 if ($^O eq 'VMS') {
    0          
955             # VMS might have a file version at the end
956 0 0       0 push @candidates, $perl . $exe
957             unless $perl =~ m/$exe(;\d+)?$/i;
958             } elsif (defined $exe && length $exe) {
959 0 0       0 push @candidates, $perl . $exe
960             unless $perl =~ m/$exe$/i;
961             }
962             }
963             }
964             }
965 0         0 for my $perl ( @candidates ) {
966 0 0 0     0 if (MM->maybe_command($perl) && _perl_is_same($perl)) {
967 0         0 $^X = $perl;
968 0         0 return $perl;
969             }
970             }
971             }
972 0         0 return $^X; # default fall back
973             }
974              
975             #-> sub CPAN::exists ;
976             sub exists {
977 31     31 0 38 my($mgr,$class,$id) = @_;
978 31 50       52 CPAN::HandleConfig->load unless $CPAN::Config_loaded++;
979 31         77 CPAN::Index->reload;
980             ### Carp::croak "exists called without class argument" unless $class;
981 31   50     46 $id ||= "";
982 31 100       57 $id =~ s/:+/::/g if $class eq "CPAN::Module";
983 31         24 my $exists;
984 31 50       35 if (CPAN::_sqlite_running) {
985 0   0     0 $exists = (exists $META->{readonly}{$class}{$id} or
986             $CPAN::SQLite->set($class, $id));
987             } else {
988 31         84 $exists = exists $META->{readonly}{$class}{$id};
989             }
990 31   66     148 $exists ||= exists $META->{readwrite}{$class}{$id}; # unsafe meta access, ok
991             }
992              
993             #-> sub CPAN::delete ;
994             sub delete {
995 0     0 0 0 my($mgr,$class,$id) = @_;
996 0         0 delete $META->{readonly}{$class}{$id}; # unsafe meta access, ok
997 0         0 delete $META->{readwrite}{$class}{$id}; # unsafe meta access, ok
998             }
999              
1000             #-> sub CPAN::has_usable
1001             # has_inst is sometimes too optimistic, we should replace it with this
1002             # has_usable whenever a case is given
1003             sub has_usable {
1004 116     116 1 162 my($self,$mod,$message) = @_;
1005 116 100       434 return 1 if $HAS_USABLE->{$mod};
1006 4         21 my $has_inst = $self->has_inst($mod,$message);
1007 4 50       26 return unless $has_inst;
1008 4         6 my $usable;
1009             $usable = {
1010              
1011             #
1012             # these subroutines die if they believe the installed version is unusable;
1013             #
1014             'CPAN::Meta' => [
1015             sub {
1016 1     1   10 require CPAN::Meta;
1017 1 50       48 unless (CPAN::Version->vge(CPAN::Meta->VERSION, 2.110350)) {
1018 0         0 for ("Will not use CPAN::Meta, need version 2.110350\n") {
1019 0         0 $CPAN::Frontend->mywarn($_);
1020 0         0 die $_;
1021             }
1022             }
1023             },
1024             ],
1025              
1026             'CPAN::Meta::Requirements' => [
1027             sub {
1028 0     0   0 require CPAN::Meta::Requirements;
1029 0 0       0 unless (CPAN::Version->vge(CPAN::Meta::Requirements->VERSION, 2.120920)) {
1030 0         0 for ("Will not use CPAN::Meta::Requirements, need version 2.120920\n") {
1031 0         0 $CPAN::Frontend->mywarn($_);
1032 0         0 die $_;
1033             }
1034             }
1035             },
1036 0     0   0 ],
1037              
1038             LWP => [ # we frequently had "Can't locate object
1039             # method "new" via package "LWP::UserAgent" at
1040             # (eval 69) line 2006
1041             sub {require LWP},
1042 0     0   0 sub {require LWP::UserAgent},
1043 0     0   0 sub {require HTTP::Request},
1044 0     0   0 sub {require URI::URL;
1045 0 0       0 unless (CPAN::Version->vge(URI::URL::->VERSION,0.08)) {
1046 0         0 for ("Will not use URI::URL, need 0.08\n") {
1047 0         0 $CPAN::Frontend->mywarn($_);
1048 0         0 die $_;
1049             }
1050             }
1051             },
1052 0     0   0 ],
1053             'Net::FTP' => [
1054             sub {require Net::FTP},
1055 0     0   0 sub {require Net::Config},
1056             ],
1057             'HTTP::Tiny' => [
1058             sub {
1059 0     0   0 require HTTP::Tiny;
1060 0 0       0 unless (CPAN::Version->vge(HTTP::Tiny->VERSION, 0.005)) {
1061 0         0 for ("Will not use HTTP::Tiny, need version 0.005\n") {
1062 0         0 $CPAN::Frontend->mywarn($_);
1063 0         0 die $_;
1064             }
1065             }
1066             },
1067 0     0   0 ],
1068             'File::HomeDir' => [
1069             sub {require File::HomeDir;
1070 0 0       0 unless (CPAN::Version->vge(File::HomeDir::->VERSION, 0.52)) {
1071 0         0 for ("Will not use File::HomeDir, need 0.52\n") {
1072 0         0 $CPAN::Frontend->mywarn($_);
1073 0         0 die $_;
1074             }
1075             }
1076             },
1077 1     1   7 ],
1078             'Archive::Tar' => [
1079             sub {require Archive::Tar;
1080 1         3 my $demand = "1.50";
1081 1 50       23 unless (CPAN::Version->vge(Archive::Tar::->VERSION, $demand)) {
1082 0         0 my $atv = Archive::Tar->VERSION;
1083 0         0 for ("You have Archive::Tar $atv, but $demand or later is recommended. Please upgrade.\n") {
1084 0         0 $CPAN::Frontend->mywarn($_);
1085             # don't die, because we may need
1086             # Archive::Tar to upgrade
1087             }
1088              
1089             }
1090             },
1091 0     0   0 ],
1092             'File::Temp' => [
1093             # XXX we should probably delete from
1094             # %INC too so we can load after we
1095             # installed a new enough version --
1096             # I'm not sure.
1097             sub {require File::Temp;
1098 0 0       0 unless (CPAN::Version->vge(File::Temp::->VERSION,0.16)) {
1099 0         0 for ("Will not use File::Temp, need 0.16\n") {
1100 0         0 $CPAN::Frontend->mywarn($_);
1101 0         0 die $_;
1102             }
1103             }
1104             },
1105 4         202 ]
1106             };
1107 4 100       23 if ($usable->{$mod}) {
1108 2         5 for my $c (0..$#{$usable->{$mod}}) {
  2         14  
1109 2         6 my $code = $usable->{$mod}[$c];
1110 2         7 my $ret = eval { &$code() };
  2         9  
1111 2 50       11 $ret = "" unless defined $ret;
1112 2 50       11 if ($@) {
1113             # warn "DEBUG: c[$c]\$\@[$@]ret[$ret]";
1114 0         0 return;
1115             }
1116             }
1117             }
1118 4         212 return $HAS_USABLE->{$mod} = 1;
1119             }
1120              
1121             sub frontend {
1122 0     0 1 0 shift;
1123 0 0       0 $CPAN::Frontend = shift if @_;
1124 0         0 $CPAN::Frontend;
1125             }
1126              
1127             sub use_inst {
1128 8     8 1 14 my ($self, $module) = @_;
1129              
1130 8 50       27 unless ($self->has_inst($module)) {
1131 0         0 $self->frontend->mydie("$module not installed, cannot continue");
1132             }
1133             }
1134              
1135             #-> sub CPAN::has_inst
1136             sub has_inst {
1137 48     48 1 2018 my($self,$mod,$message) = @_;
1138 48 50       107 Carp::croak("CPAN->has_inst() called without an argument")
1139             unless defined $mod;
1140 15 100       34 my %dont = map { $_ => 1 } keys %{$CPAN::META->{dontload_hash}||{}},
  48 50       272  
  48         217  
1141 48 50       215 keys %{$CPAN::Config->{dontload_hash}||{}},
1142 48         52 @{$CPAN::Config->{dontload_list}||[]};
1143 48 100 66     288 if (defined $message && $message eq "no" # as far as I remember only used by Nox
      100        
1144             ||
1145             $dont{$mod}
1146             ) {
1147 9   100     41 $CPAN::META->{dontload_hash}{$mod}||=1; # unsafe meta access, ok
1148 9         30 return 0;
1149             }
1150 39         57 my $file = $mod;
1151 39         39 my $obj;
1152 39         140 $file =~ s|::|/|g;
1153 39         55 $file .= ".pm";
1154 39 100       104 if ($INC{$file}) {
    100          
    50          
    50          
    50          
1155             # checking %INC is wrong, because $INC{LWP} may be true
1156             # although $INC{"URI/URL.pm"} may have failed. But as
1157             # I really want to say "blah loaded OK", I have to somehow
1158             # cache results.
1159             ### warn "$file in %INC"; #debug
1160 26         97 return 1;
1161 13         7085 } elsif (eval { require $file }) {
1162             # eval is good: if we haven't yet read the database it's
1163             # perfect and if we have installed the module in the meantime,
1164             # it tries again. The second require is only a NOOP returning
1165             # 1 if we had success, otherwise it's retrying
1166              
1167 7         200448 my $mtime = (stat $INC{$file})[9];
1168             # privileged files loaded by has_inst; Note: we use $mtime
1169             # as a proxy for a checksum.
1170 7         36 $CPAN::Shell::reload->{$file} = $mtime;
1171 7         850 my $v = eval "\$$mod\::VERSION";
1172 7 50       44 $v = $v ? " (v$v)" : "";
1173 7         98 CPAN::Shell->optprint("load_module","CPAN: $mod loaded ok$v\n");
1174 7 50       37 if ($mod eq "CPAN::WAIT") {
1175 0         0 push @CPAN::Shell::ISA, 'CPAN::WAIT';
1176             }
1177 7         58 return 1;
1178             } elsif ($mod eq "Net::FTP") {
1179 0 0       0 $CPAN::Frontend->mywarn(qq{
1180             Please, install Net::FTP as soon as possible. CPAN.pm installs it for you
1181             if you just type
1182             install Bundle::libnet
1183              
1184             }) unless $Have_warned->{"Net::FTP"}++;
1185 0         0 $CPAN::Frontend->mysleep(3);
1186             } elsif ($mod eq "Digest::SHA") {
1187 0 0       0 if ($Have_warned->{"Digest::SHA"}++) {
1188 0         0 $CPAN::Frontend->mywarn(qq{CPAN: checksum security checks disabled }.
1189             qq{because Digest::SHA not installed.\n});
1190             } else {
1191 0         0 $CPAN::Frontend->mywarn(qq{
1192             CPAN: checksum security checks disabled because Digest::SHA not installed.
1193             Please consider installing the Digest::SHA module.
1194              
1195             });
1196 0         0 $CPAN::Frontend->mysleep(2);
1197             }
1198             } elsif ($mod eq "Module::Signature") {
1199             # NOT prefs_lookup, we are not a distro
1200 0         0 my $check_sigs = $CPAN::Config->{check_sigs};
1201 0 0       0 if (not $check_sigs) {
    0          
1202             # they do not want us:-(
1203             } elsif (not $Have_warned->{"Module::Signature"}++) {
1204             # No point in complaining unless the user can
1205             # reasonably install and use it.
1206 0 0 0     0 if (eval { require Crypt::OpenPGP; 1 } ||
  0   0     0  
  0         0  
1207             (
1208             defined $CPAN::Config->{'gpg'}
1209             &&
1210             $CPAN::Config->{'gpg'} =~ /\S/
1211             )
1212             ) {
1213 0         0 $CPAN::Frontend->mywarn(qq{
1214             CPAN: Module::Signature security checks disabled because Module::Signature
1215             not installed. Please consider installing the Module::Signature module.
1216             You may also need to be able to connect over the Internet to the public
1217             key servers like pool.sks-keyservers.net or pgp.mit.edu.
1218              
1219             });
1220 0         0 $CPAN::Frontend->mysleep(2);
1221             }
1222             }
1223             } else {
1224 6         9 delete $INC{$file}; # if it inc'd LWP but failed during, say, URI
1225             }
1226 6         37 return 0;
1227             }
1228              
1229             #-> sub CPAN::instance ;
1230             sub instance {
1231 43     43 1 50 my($mgr,$class,$id) = @_;
1232 43         94 CPAN::Index->reload;
1233 43   50     68 $id ||= "";
1234             # unsafe meta access, ok?
1235 43 100       105 return $META->{readwrite}{$class}{$id} if exists $META->{readwrite}{$class}{$id};
1236 39   33     237 $META->{readwrite}{$class}{$id} ||= $class->new(ID => $id);
1237             }
1238              
1239             #-> sub CPAN::new ;
1240             sub new {
1241 12     12 0 173 bless {}, shift;
1242             }
1243              
1244             #-> sub CPAN::_exit_messages ;
1245             sub _exit_messages {
1246 0     0   0 my ($self) = @_;
1247 0   0     0 $self->{exit_messages} ||= [];
1248             }
1249              
1250             #-> sub CPAN::cleanup ;
1251             sub cleanup {
1252             # warn "cleanup called with arg[@_] End[$CPAN::End] Signal[$Signal]";
1253 12     12 0 71 local $SIG{__DIE__} = '';
1254 12         28 my($message) = @_;
1255 12         26 my $i = 0;
1256 12         24 my $ineval = 0;
1257 12         19 my($subroutine);
1258 12         113 while ((undef,undef,undef,$subroutine) = caller(++$i)) {
1259 24 100       127 $ineval = 1, last if
1260             $subroutine eq '(eval)';
1261             }
1262 12 50 33     119 return if $ineval && !$CPAN::End;
1263 12 50       124 return unless defined $META->{LOCK};
1264 0 0         return unless -f $META->{LOCK};
1265 0           $META->savehist;
1266 0   0       $META->{cachemgr} ||= CPAN::CacheMgr->new('atexit');
1267 0           close $META->{LOCKFH};
1268 0           unlink $META->{LOCK};
1269             # require Carp;
1270             # Carp::cluck("DEBUGGING");
1271 0 0         if ( $CPAN::CONFIG_DIRTY ) {
1272 0           $CPAN::Frontend->mywarn("Warning: Configuration not saved.\n");
1273             }
1274 0           $CPAN::Frontend->myprint("Lockfile removed.\n");
1275 0           for my $msg ( @{ $META->_exit_messages } ) {
  0            
1276 0           $CPAN::Frontend->myprint($msg);
1277             }
1278             }
1279              
1280             #-> sub CPAN::readhist
1281             sub readhist {
1282 0     0 0   my($self,$term,$histfile) = @_;
1283 0   0       my $histsize = $CPAN::Config->{'histsize'} || 100;
1284 0 0         $term->Attribs->{'MaxHistorySize'} = $histsize if (defined($term->Attribs->{'MaxHistorySize'}));
1285 0           my($fh) = FileHandle->new;
1286 0 0         open $fh, "<$histfile" or return;
1287 0           local $/ = "\n";
1288 0           while (<$fh>) {
1289 0           chomp;
1290 0           $term->AddHistory($_);
1291             }
1292 0           close $fh;
1293             }
1294              
1295             #-> sub CPAN::savehist
1296             sub savehist {
1297 0     0 0   my($self) = @_;
1298 0           my($histfile,$histsize);
1299 0 0         unless ($histfile = $CPAN::Config->{'histfile'}) {
1300 0           $CPAN::Frontend->mywarn("No history written (no histfile specified).\n");
1301 0           return;
1302             }
1303 0   0       $histsize = $CPAN::Config->{'histsize'} || 100;
1304 0 0         if ($CPAN::term) {
1305 0 0         unless ($CPAN::term->can("GetHistory")) {
1306 0           $CPAN::Frontend->mywarn("Terminal does not support GetHistory.\n");
1307 0           return;
1308             }
1309             } else {
1310 0           return;
1311             }
1312 0           my @h = $CPAN::term->GetHistory;
1313 0 0         splice @h, 0, @h-$histsize if @h>$histsize;
1314 0           my($fh) = FileHandle->new;
1315 0 0         open $fh, ">$histfile" or $CPAN::Frontend->mydie("Couldn't open >$histfile: $!");
1316 0           local $\ = local $, = "\n";
1317 0           print $fh @h;
1318 0           close $fh;
1319             }
1320              
1321             #-> sub CPAN::is_tested
1322             sub is_tested {
1323 0     0 1   my($self,$what,$when) = @_;
1324 0 0         unless ($what) {
1325 0           Carp::cluck("DEBUG: empty what");
1326 0           return;
1327             }
1328 0           $self->{is_tested}{$what} = $when;
1329             }
1330              
1331             #-> sub CPAN::reset_tested
1332             # forget all distributions tested -- resets what gets included in PERL5LIB
1333             sub reset_tested {
1334 0     0 0   my ($self) = @_;
1335 0           $self->{is_tested} = {};
1336             }
1337              
1338             #-> sub CPAN::is_installed
1339             # unsets the is_tested flag: as soon as the thing is installed, it is
1340             # not needed in set_perl5lib anymore
1341             sub is_installed {
1342 0     0 0   my($self,$what) = @_;
1343 0           delete $self->{is_tested}{$what};
1344             }
1345              
1346             sub _list_sorted_descending_is_tested {
1347 0     0     my($self) = @_;
1348 0           my $foul = 0;
1349 0   0       my @sorted = sort
      0        
1350             { ($self->{is_tested}{$b}||0) <=> ($self->{is_tested}{$a}||0) }
1351             grep
1352 0 0         { if ($foul){ 0 } elsif (-e) { 1 } else { $foul = $_; 0 } }
  0 0          
  0            
  0            
  0            
  0            
1353 0           keys %{$self->{is_tested}};
1354 0 0         if ($foul) {
1355 0           $CPAN::Frontend->mywarn("Lost build_dir detected ($foul), giving up all cached test results of currently running session.\n");
1356 0           for my $dbd (keys %{$self->{is_tested}}) { # distro-build-dir
  0            
1357 0           SEARCH: for my $d ($CPAN::META->all_objects("CPAN::Distribution")) {
1358 0 0 0       if ($d->{build_dir} && $d->{build_dir} eq $dbd) {
1359 0           $CPAN::Frontend->mywarn(sprintf "Flushing cache for %s\n", $d->pretty_id);
1360 0           $d->fforce("");
1361 0           last SEARCH;
1362             }
1363             }
1364 0           delete $self->{is_tested}{$dbd};
1365             }
1366 0           return ();
1367             } else {
1368 0           return @sorted;
1369             }
1370             }
1371              
1372             #-> sub CPAN::set_perl5lib
1373             # Notes on max environment variable length:
1374             # - Win32 : XP or later, 8191; Win2000 or NT4, 2047
1375             {
1376             my $fh;
1377             sub set_perl5lib {
1378 0     0 0   my($self,$for) = @_;
1379 0 0         unless ($for) {
1380 0           (undef,undef,undef,$for) = caller(1);
1381 0           $for =~ s/.*://;
1382             }
1383 0   0       $self->{is_tested} ||= {};
1384 0 0         return unless %{$self->{is_tested}};
  0            
1385 0           my $env = $ENV{PERL5LIB};
1386 0 0         $env = $ENV{PERLLIB} unless defined $env;
1387 0           my @env;
1388 0 0 0       push @env, split /\Q$Config::Config{path_sep}\E/, $env if defined $env and length $env;
1389             #my @dirs = map {("$_/blib/arch", "$_/blib/lib")} keys %{$self->{is_tested}};
1390             #$CPAN::Frontend->myprint("Prepending @dirs to PERL5LIB.\n");
1391              
1392 0           my @dirs = map {("$_/blib/arch", "$_/blib/lib")} $self->_list_sorted_descending_is_tested;
  0            
1393 0 0         return if !@dirs;
1394              
1395 0 0         if (@dirs < 12) {
    0          
1396 0           $CPAN::Frontend->optprint('perl5lib', "Prepending @dirs to PERL5LIB for '$for'\n");
1397 0           $ENV{PERL5LIB} = join $Config::Config{path_sep}, @dirs, @env;
1398             } elsif (@dirs < 24 ) {
1399 0           my @d = map {my $cp = $_;
  0            
1400 0           $cp =~ s/^\Q$CPAN::Config->{build_dir}\E/%BUILDDIR%/;
1401 0           $cp
1402             } @dirs;
1403 0           $CPAN::Frontend->optprint('perl5lib', "Prepending @d to PERL5LIB; ".
1404             "%BUILDDIR%=$CPAN::Config->{build_dir} ".
1405             "for '$for'\n"
1406             );
1407 0           $ENV{PERL5LIB} = join $Config::Config{path_sep}, @dirs, @env;
1408             } else {
1409 0           my $cnt = keys %{$self->{is_tested}};
  0            
1410 0           $CPAN::Frontend->optprint('perl5lib', "Prepending blib/arch and blib/lib of ".
1411             "$cnt build dirs to PERL5LIB; ".
1412             "for '$for'\n"
1413             );
1414 0           $ENV{PERL5LIB} = join $Config::Config{path_sep}, @dirs, @env;
1415             }
1416             }}
1417              
1418              
1419             1;
1420              
1421              
1422             __END__