File Coverage

blib/lib/CPAN.pm
Criterion Covered Total %
statement 250 802 31.1
branch 50 386 12.9
condition 22 160 13.7
subroutine 64 107 59.8
pod 13 27 48.1
total 399 1482 26.9


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   35790 use strict;
  12         16  
  12         702  
4             package CPAN;
5             $CPAN::VERSION = '2.17';
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   46 use File::Spec ();
  12         15  
  12         818  
11             BEGIN {
12 12 50   12   173 if (File::Spec->can("rel2abs")) {
13 12         31 for my $inc (@INC) {
14 135 50       1015 $inc = File::Spec->rel2abs($inc) unless ref $inc;
15             }
16             }
17 12 50       507 $SIG{WINCH} = 'IGNORE' if exists $SIG{WINCH};
18             }
19 12     12   4344 use CPAN::Author;
  12         18  
  12         302  
20 12     12   4994 use CPAN::HandleConfig;
  12         21  
  12         361  
21 12     12   4446 use CPAN::Version;
  12         18  
  12         277  
22 12     12   4119 use CPAN::Bundle;
  12         21  
  12         292  
23 12     12   4579 use CPAN::CacheMgr;
  12         24  
  12         309  
24 12     12   4264 use CPAN::Complete;
  12         19  
  12         310  
25 12     12   53 use CPAN::Debug;
  12         12  
  12         236  
26 12     12   9901 use CPAN::Distribution;
  12         30  
  12         429  
27 12     12   5206 use CPAN::Distrostatus;
  12         18  
  12         271  
28 12     12   5236 use CPAN::FTP;
  12         22  
  12         397  
29 12     12   5040 use CPAN::Index 1.93; # https://rt.cpan.org/Ticket/Display.html?id=43349
  12         315  
  12         318  
30 12     12   59 use CPAN::InfoObj;
  12         14  
  12         251  
31 12     12   40 use CPAN::Module;
  12         14  
  12         217  
32 12     12   3926 use CPAN::Prompt;
  12         22  
  12         275  
33 12     12   3683 use CPAN::URL;
  12         81  
  12         266  
34 12     12   4133 use CPAN::Queue;
  12         20  
  12         272  
35 12     12   4270 use CPAN::Tarzip;
  12         24  
  12         339  
36 12     12   3988 use CPAN::DeferredCode;
  12         21  
  12         259  
37 12     12   6453 use CPAN::Shell;
  12         22  
  12         382  
38 12     12   4977 use CPAN::LWP::UserAgent;
  12         19  
  12         298  
39 12     12   4230 use CPAN::Exception::RecursiveDependency;
  12         18  
  12         379  
40 12     12   3928 use CPAN::Exception::yaml_not_installed;
  12         17  
  12         282  
41 12     12   3914 use CPAN::Exception::yaml_process_error;
  12         19  
  12         251  
42              
43 12     12   43 use Carp ();
  12         12  
  12         134  
44 12     12   31 use Config ();
  12         11  
  12         161  
45 12     12   37 use Cwd qw(chdir);
  12         13  
  12         570  
46 12     12   51 use DirHandle ();
  12         12  
  12         156  
47 12     12   33 use Exporter ();
  12         13  
  12         191  
48 12     12   7859 use ExtUtils::MakeMaker qw(prompt); # for some unknown reason,
  12         849196  
  12         727  
49             # 5.005_04 does not work without
50             # this
51 12     12   80 use File::Basename ();
  12         18  
  12         147  
52 12     12   4403 use File::Copy ();
  12         16924  
  12         237  
53 12     12   55 use File::Find;
  12         23  
  12         529  
54 12     12   62 use File::Path ();
  12         18  
  12         132  
55 12     12   4566 use FileHandle ();
  12         66499  
  12         315  
56 12     12   60 use Fcntl qw(:flock);
  12         15  
  12         1495  
57 12     12   5787 use Safe ();
  12         287421  
  12         549  
58 12     12   4719 use Sys::Hostname qw(hostname);
  12         9821  
  12         663  
59 12     12   4884 use Text::ParseWords ();
  12         10502  
  12         241  
60 12     12   4548 use Text::Wrap ();
  12         22391  
  12         456  
61              
62             # protect against "called too early"
63             sub find_perl ();
64             sub anycwd ();
65             sub _uniq;
66              
67 12     12   4241 no lib ".";
  12         4762  
  12         60  
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   14011 END { $CPAN::End++; &cleanup; }
  12         46  
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         12351 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   3574 );
  12         18  
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   11 $autoload_recursion++;
184 1         2 my($l) = $AUTOLOAD;
185 1         6 $l =~ s/.*:://;
186 1 50       6 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       5 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         26 @export{@EXPORT} = '';
199 1 50       13 CPAN::HandleConfig->load unless $CPAN::Config_loaded++;
200 1 50       2 if (exists $export{$l}) {
201 0         0 CPAN::Shell->$l(@_);
202             } else {
203 1         9 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   59 use strict;
  12         15  
  12         244  
358 12     12   38 use vars qw($import_done);
  12         18  
  12         11627  
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   35 my $yaml_module = $CPAN::Config->{yaml_module} || "YAML";
521 3 50 33     8 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     12 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   65 no strict 'refs';
  12         16  
  12         34836  
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   323 if ($negative_cache->{time} && time < $negative_cache->{time} + 60) {
627             # need to cache the result, otherwise too slow
628 126         236 return $negative_cache->{fact};
629             } else {
630 1         2 $negative_cache = {}; # reset
631             }
632 1   33     4 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   2175 if (kill 0, $otherpid or $!{EPERM}) {
  5 0       4544  
  5         16930  
  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 20 my $getcwd;
922 12   100     59 $getcwd = $CPAN::Config->{'getcwd'} || 'cwd';
923 12         56 CPAN->$getcwd();
924             }
925              
926             #-> sub CPAN::cwd ;
927 12     12 1 34347 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 470 if ( File::Spec->file_name_is_absolute($^X) ) {
953 12         78 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       63 CPAN::HandleConfig->load unless $CPAN::Config_loaded++;
992 31         63 CPAN::Index->reload;
993             ### Carp::croak "exists called without class argument" unless $class;
994 31   50     59 $id ||= "";
995 31 100       56 $id =~ s/:+/::/g if $class eq "CPAN::Module";
996 31         26 my $exists;
997 31 50       33 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         40 $exists = exists $META->{readonly}{$class}{$id};
1002             }
1003 31   66     129 $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 150 my($self,$mod,$message) = @_;
1018 116 100       360 return 1 if $HAS_USABLE->{$mod};
1019 4         16 my $has_inst = $self->has_inst($mod,$message);
1020 4 50       20 return unless $has_inst;
1021 4         4 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   7 require CPAN::Meta;
1030 1 50       21 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             sub {
1068 0   0 0   0 my $var = $CPAN::Config->{ftp_proxy} || $ENV{ftp_proxy};
1069 0 0 0     0 if ($var and $var =~ /^http:/i) {
1070             # rt #110833
1071 0         0 for ("Net::FTP cannot handle http proxy") {
1072 0         0 $CPAN::Frontend->mywarn($_);
1073 0         0 die $_;
1074             }
1075             }
1076             },
1077 0     0   0 sub {require Net::FTP},
1078 0     0   0 sub {require Net::Config},
1079             ],
1080             'HTTP::Tiny' => [
1081             sub {
1082 0     0   0 require HTTP::Tiny;
1083 0 0       0 unless (CPAN::Version->vge(HTTP::Tiny->VERSION, 0.005)) {
1084 0         0 for ("Will not use HTTP::Tiny, need version 0.005\n") {
1085 0         0 $CPAN::Frontend->mywarn($_);
1086 0         0 die $_;
1087             }
1088             }
1089             },
1090             ],
1091             'File::HomeDir' => [
1092 0     0   0 sub {require File::HomeDir;
1093 0 0       0 unless (CPAN::Version->vge(File::HomeDir::->VERSION, 0.52)) {
1094 0         0 for ("Will not use File::HomeDir, need 0.52\n") {
1095 0         0 $CPAN::Frontend->mywarn($_);
1096 0         0 die $_;
1097             }
1098             }
1099             },
1100             ],
1101             'Archive::Tar' => [
1102 1     1   5 sub {require Archive::Tar;
1103 1         4 my $demand = "1.50";
1104 1 50       21 unless (CPAN::Version->vge(Archive::Tar::->VERSION, $demand)) {
1105 0         0 my $atv = Archive::Tar->VERSION;
1106 0         0 for ("You have Archive::Tar $atv, but $demand or later is recommended. Please upgrade.\n") {
1107 0         0 $CPAN::Frontend->mywarn($_);
1108             # don't die, because we may need
1109             # Archive::Tar to upgrade
1110             }
1111              
1112             }
1113             },
1114             ],
1115             'File::Temp' => [
1116             # XXX we should probably delete from
1117             # %INC too so we can load after we
1118             # installed a new enough version --
1119             # I'm not sure.
1120 0     0   0 sub {require File::Temp;
1121 0 0       0 unless (CPAN::Version->vge(File::Temp::->VERSION,0.16)) {
1122 0         0 for ("Will not use File::Temp, need 0.16\n") {
1123 0         0 $CPAN::Frontend->mywarn($_);
1124 0         0 die $_;
1125             }
1126             }
1127             },
1128 4         149 ]
1129             };
1130 4 100       18 if ($usable->{$mod}) {
1131 2         12 local @INC = @INC;
1132 2 50       7 pop @INC if $INC[-1] eq '.';
1133 2         4 for my $c (0..$#{$usable->{$mod}}) {
  2         13  
1134 2         4 my $code = $usable->{$mod}[$c];
1135 2         4 my $ret = eval { &$code() };
  2         4  
1136 2 50       8 $ret = "" unless defined $ret;
1137 2 50       8 if ($@) {
1138             # warn "DEBUG: c[$c]\$\@[$@]ret[$ret]";
1139 0         0 return;
1140             }
1141             }
1142             }
1143 4         154 return $HAS_USABLE->{$mod} = 1;
1144             }
1145              
1146             sub frontend {
1147 0     0 1 0 shift;
1148 0 0       0 $CPAN::Frontend = shift if @_;
1149 0         0 $CPAN::Frontend;
1150             }
1151              
1152             sub use_inst {
1153 8     8 1 14 my ($self, $module) = @_;
1154              
1155 8 50       30 unless ($self->has_inst($module)) {
1156 0         0 $self->frontend->mydie("$module not installed, cannot continue");
1157             }
1158             }
1159              
1160             #-> sub CPAN::has_inst
1161             sub has_inst {
1162 48     48 1 1598 my($self,$mod,$message) = @_;
1163 48 50       101 Carp::croak("CPAN->has_inst() called without an argument")
1164             unless defined $mod;
1165 15 100       26 my %dont = map { $_ => 1 } keys %{$CPAN::META->{dontload_hash}||{}},
  48         227  
1166 48 50       178 keys %{$CPAN::Config->{dontload_hash}||{}},
1167 48 50       47 @{$CPAN::Config->{dontload_list}||[]};
  48         179  
1168 48 100 66     229 if (defined $message && $message eq "no" # as far as I remember only used by Nox
      66        
1169             ||
1170             $dont{$mod}
1171             ) {
1172 9   100     35 $CPAN::META->{dontload_hash}{$mod}||=1; # unsafe meta access, ok
1173 9         23 return 0;
1174             }
1175 39         190 local @INC = @INC;
1176 39 50       84 pop @INC if $INC[-1] eq '.';
1177 39         47 my $file = $mod;
1178 39         34 my $obj;
1179 39         113 $file =~ s|::|/|g;
1180 39         47 $file .= ".pm";
1181 39 100       80 if ($INC{$file}) {
    100          
    50          
    50          
    50          
1182             # checking %INC is wrong, because $INC{LWP} may be true
1183             # although $INC{"URI/URL.pm"} may have failed. But as
1184             # I really want to say "blah loaded OK", I have to somehow
1185             # cache results.
1186             ### warn "$file in %INC"; #debug
1187 26         105 return 1;
1188 13         6595 } elsif (eval { require $file }) {
1189             # eval is good: if we haven't yet read the database it's
1190             # perfect and if we have installed the module in the meantime,
1191             # it tries again. The second require is only a NOOP returning
1192             # 1 if we had success, otherwise it's retrying
1193              
1194 7         148595 my $mtime = (stat $INC{$file})[9];
1195             # privileged files loaded by has_inst; Note: we use $mtime
1196             # as a proxy for a checksum.
1197 7         28 $CPAN::Shell::reload->{$file} = $mtime;
1198 7         686 my $v = eval "\$$mod\::VERSION";
1199 7 50       40 $v = $v ? " (v$v)" : "";
1200 7         86 CPAN::Shell->optprint("load_module","CPAN: $mod loaded ok$v\n");
1201 7 50       28 if ($mod eq "CPAN::WAIT") {
1202 0         0 push @CPAN::Shell::ISA, 'CPAN::WAIT';
1203             }
1204 7         50 return 1;
1205             } elsif ($mod eq "Net::FTP") {
1206             $CPAN::Frontend->mywarn(qq{
1207             Please, install Net::FTP as soon as possible. CPAN.pm installs it for you
1208             if you just type
1209             install Bundle::libnet
1210              
1211 0 0       0 }) unless $Have_warned->{"Net::FTP"}++;
1212 0         0 $CPAN::Frontend->mysleep(3);
1213             } elsif ($mod eq "Digest::SHA") {
1214 0 0       0 if ($Have_warned->{"Digest::SHA"}++) {
1215 0         0 $CPAN::Frontend->mywarn(qq{CPAN: checksum security checks disabled }.
1216             qq{because Digest::SHA not installed.\n});
1217             } else {
1218 0         0 $CPAN::Frontend->mywarn(qq{
1219             CPAN: checksum security checks disabled because Digest::SHA not installed.
1220             Please consider installing the Digest::SHA module.
1221              
1222             });
1223 0         0 $CPAN::Frontend->mysleep(2);
1224             }
1225             } elsif ($mod eq "Module::Signature") {
1226             # NOT prefs_lookup, we are not a distro
1227 0         0 my $check_sigs = $CPAN::Config->{check_sigs};
1228 0 0       0 if (not $check_sigs) {
    0          
1229             # they do not want us:-(
1230             } elsif (not $Have_warned->{"Module::Signature"}++) {
1231             # No point in complaining unless the user can
1232             # reasonably install and use it.
1233 0 0 0     0 if (eval { require Crypt::OpenPGP; 1 } ||
  0   0     0  
  0         0  
1234             (
1235             defined $CPAN::Config->{'gpg'}
1236             &&
1237             $CPAN::Config->{'gpg'} =~ /\S/
1238             )
1239             ) {
1240 0         0 $CPAN::Frontend->mywarn(qq{
1241             CPAN: Module::Signature security checks disabled because Module::Signature
1242             not installed. Please consider installing the Module::Signature module.
1243             You may also need to be able to connect over the Internet to the public
1244             key servers like pool.sks-keyservers.net or pgp.mit.edu.
1245              
1246             });
1247 0         0 $CPAN::Frontend->mysleep(2);
1248             }
1249             }
1250             } else {
1251 6         9 delete $INC{$file}; # if it inc'd LWP but failed during, say, URI
1252             }
1253 6         40 return 0;
1254             }
1255              
1256             #-> sub CPAN::instance ;
1257             sub instance {
1258 43     43 1 45 my($mgr,$class,$id) = @_;
1259 43         95 CPAN::Index->reload;
1260 43   50     47 $id ||= "";
1261             # unsafe meta access, ok?
1262 43 100       81 return $META->{readwrite}{$class}{$id} if exists $META->{readwrite}{$class}{$id};
1263 39   33     198 $META->{readwrite}{$class}{$id} ||= $class->new(ID => $id);
1264             }
1265              
1266             #-> sub CPAN::new ;
1267             sub new {
1268 12     12 0 135 bless {}, shift;
1269             }
1270              
1271             #-> sub CPAN::_exit_messages ;
1272             sub _exit_messages {
1273 0     0   0 my ($self) = @_;
1274 0   0     0 $self->{exit_messages} ||= [];
1275             }
1276              
1277             #-> sub CPAN::cleanup ;
1278             sub cleanup {
1279             # warn "cleanup called with arg[@_] End[$CPAN::End] Signal[$Signal]";
1280 12     12 0 66 local $SIG{__DIE__} = '';
1281 12         26 my($message) = @_;
1282 12         21 my $i = 0;
1283 12         27 my $ineval = 0;
1284 12         19 my($subroutine);
1285 12         112 while ((undef,undef,undef,$subroutine) = caller(++$i)) {
1286 24 100       133 $ineval = 1, last if
1287             $subroutine eq '(eval)';
1288             }
1289 12 50 33     101 return if $ineval && !$CPAN::End;
1290 12 50       114 return unless defined $META->{LOCK};
1291 0 0         return unless -f $META->{LOCK};
1292 0           $META->savehist;
1293 0   0       $META->{cachemgr} ||= CPAN::CacheMgr->new('atexit');
1294 0           close $META->{LOCKFH};
1295 0           unlink $META->{LOCK};
1296             # require Carp;
1297             # Carp::cluck("DEBUGGING");
1298 0 0         if ( $CPAN::CONFIG_DIRTY ) {
1299 0           $CPAN::Frontend->mywarn("Warning: Configuration not saved.\n");
1300             }
1301 0           $CPAN::Frontend->myprint("Lockfile removed.\n");
1302 0           for my $msg ( @{ $META->_exit_messages } ) {
  0            
1303 0           $CPAN::Frontend->myprint($msg);
1304             }
1305             }
1306              
1307             #-> sub CPAN::readhist
1308             sub readhist {
1309 0     0 0   my($self,$term,$histfile) = @_;
1310 0   0       my $histsize = $CPAN::Config->{'histsize'} || 100;
1311 0 0         $term->Attribs->{'MaxHistorySize'} = $histsize if (defined($term->Attribs->{'MaxHistorySize'}));
1312 0           my($fh) = FileHandle->new;
1313 0 0         open $fh, "<$histfile" or return;
1314 0           local $/ = "\n";
1315 0           while (<$fh>) {
1316 0           chomp;
1317 0           $term->AddHistory($_);
1318             }
1319 0           close $fh;
1320             }
1321              
1322             #-> sub CPAN::savehist
1323             sub savehist {
1324 0     0 0   my($self) = @_;
1325 0           my($histfile,$histsize);
1326 0 0         unless ($histfile = $CPAN::Config->{'histfile'}) {
1327 0           $CPAN::Frontend->mywarn("No history written (no histfile specified).\n");
1328 0           return;
1329             }
1330 0   0       $histsize = $CPAN::Config->{'histsize'} || 100;
1331 0 0         if ($CPAN::term) {
1332 0 0         unless ($CPAN::term->can("GetHistory")) {
1333 0           $CPAN::Frontend->mywarn("Terminal does not support GetHistory.\n");
1334 0           return;
1335             }
1336             } else {
1337 0           return;
1338             }
1339 0           my @h = $CPAN::term->GetHistory;
1340 0 0         splice @h, 0, @h-$histsize if @h>$histsize;
1341 0           my($fh) = FileHandle->new;
1342 0 0         open $fh, ">$histfile" or $CPAN::Frontend->mydie("Couldn't open >$histfile: $!");
1343 0           local $\ = local $, = "\n";
1344 0           print $fh @h;
1345 0           close $fh;
1346             }
1347              
1348             #-> sub CPAN::is_tested
1349             sub is_tested {
1350 0     0 1   my($self,$what,$when) = @_;
1351 0 0         unless ($what) {
1352 0           Carp::cluck("DEBUG: empty what");
1353 0           return;
1354             }
1355 0           $self->{is_tested}{$what} = $when;
1356             }
1357              
1358             #-> sub CPAN::reset_tested
1359             # forget all distributions tested -- resets what gets included in PERL5LIB
1360             sub reset_tested {
1361 0     0 0   my ($self) = @_;
1362 0           $self->{is_tested} = {};
1363             }
1364              
1365             #-> sub CPAN::is_installed
1366             # unsets the is_tested flag: as soon as the thing is installed, it is
1367             # not needed in set_perl5lib anymore
1368             sub is_installed {
1369 0     0 0   my($self,$what) = @_;
1370 0           delete $self->{is_tested}{$what};
1371             }
1372              
1373             sub _list_sorted_descending_is_tested {
1374 0     0     my($self) = @_;
1375 0           my $foul = 0;
1376             my @sorted = sort
1377 0   0       { ($self->{is_tested}{$b}||0) <=> ($self->{is_tested}{$a}||0) }
      0        
1378             grep
1379 0 0         { if ($foul){ 0 } elsif (-e) { 1 } else { $foul = $_; 0 } }
  0 0          
  0            
  0            
  0            
1380 0           keys %{$self->{is_tested}};
  0            
1381 0 0         if ($foul) {
1382 0           $CPAN::Frontend->mywarn("Lost build_dir detected ($foul), giving up all cached test results of currently running session.\n");
1383 0           for my $dbd (sort keys %{$self->{is_tested}}) { # distro-build-dir
  0            
1384 0           SEARCH: for my $d (sort { $a->id cmp $b->id } $CPAN::META->all_objects("CPAN::Distribution")) {
  0            
1385 0 0 0       if ($d->{build_dir} && $d->{build_dir} eq $dbd) {
1386 0           $CPAN::Frontend->mywarn(sprintf "Flushing cache for %s\n", $d->pretty_id);
1387 0           $d->fforce("");
1388 0           last SEARCH;
1389             }
1390             }
1391 0           delete $self->{is_tested}{$dbd};
1392             }
1393 0           return ();
1394             } else {
1395 0           return @sorted;
1396             }
1397             }
1398              
1399             #-> sub CPAN::set_perl5lib
1400             # Notes on max environment variable length:
1401             # - Win32 : XP or later, 8191; Win2000 or NT4, 2047
1402             {
1403             my $fh;
1404             sub set_perl5lib {
1405 0     0 0   my($self,$for) = @_;
1406 0 0         unless ($for) {
1407 0           (undef,undef,undef,$for) = caller(1);
1408 0           $for =~ s/.*://;
1409             }
1410 0   0       $self->{is_tested} ||= {};
1411 0 0         return unless %{$self->{is_tested}};
  0            
1412 0           my $env = $ENV{PERL5LIB};
1413 0 0         $env = $ENV{PERLLIB} unless defined $env;
1414 0           my @env;
1415 0 0 0       push @env, split /\Q$Config::Config{path_sep}\E/, $env if defined $env and length $env;
1416             #my @dirs = map {("$_/blib/arch", "$_/blib/lib")} keys %{$self->{is_tested}};
1417             #$CPAN::Frontend->myprint("Prepending @dirs to PERL5LIB.\n");
1418              
1419 0           my @dirs = map {("$_/blib/arch", "$_/blib/lib")} $self->_list_sorted_descending_is_tested;
  0            
1420 0 0         return if !@dirs;
1421              
1422 0 0         if (@dirs < 12) {
    0          
1423 0           $CPAN::Frontend->optprint('perl5lib', "Prepending @dirs to PERL5LIB for '$for'\n");
1424 0           $ENV{PERL5LIB} = join $Config::Config{path_sep}, @dirs, @env;
1425             } elsif (@dirs < 24 ) {
1426 0           my @d = map {my $cp = $_;
  0            
1427 0           $cp =~ s/^\Q$CPAN::Config->{build_dir}\E/%BUILDDIR%/;
1428 0           $cp
1429             } @dirs;
1430 0           $CPAN::Frontend->optprint('perl5lib', "Prepending @d to PERL5LIB; ".
1431             "%BUILDDIR%=$CPAN::Config->{build_dir} ".
1432             "for '$for'\n"
1433             );
1434 0           $ENV{PERL5LIB} = join $Config::Config{path_sep}, @dirs, @env;
1435             } else {
1436 0           my $cnt = keys %{$self->{is_tested}};
  0            
1437 0           $CPAN::Frontend->optprint('perl5lib', "Prepending blib/arch and blib/lib of ".
1438             "$cnt build dirs to PERL5LIB; ".
1439             "for '$for'\n"
1440             );
1441 0           $ENV{PERL5LIB} = join $Config::Config{path_sep}, @dirs, @env;
1442             }
1443             }}
1444              
1445              
1446             1;
1447              
1448              
1449             __END__