File Coverage

lib/CPAN.pm
Criterion Covered Total %
statement 1928 3691 52.2
branch 787 2106 37.4
condition 213 647 32.9
subroutine 238 318 74.8
pod n/a
total 3166 6762 46.8


<
line stmt bran cond sub pod time code
1             # -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*-
2 6     6   178 use strict;
  6         96  
  6         177  
3             package CPAN;
4             $CPAN::VERSION = '1.8802';
5             $CPAN::VERSION = eval $CPAN::VERSION;
6              
7 6     6   258 use CPAN::HandleConfig;
  6         61  
  6         169  
8 6     6   295 use CPAN::Version;
  6         67  
  6         140  
9 6     6   232 use CPAN::Debug;
  6         85  
  6         146  
10 6     6   220 use CPAN::Tarzip;
  6         62  
  6         355  
11 6     6   129 use Carp ();
  6         123  
  6         188  
12 6     6   91 use Config ();
  6         90  
  6         143  
13 6     6   96 use Cwd ();
  6         86  
  6         57  
14 6     6   298 use DirHandle ();
  6         61  
  6         64  
15 6     6   105 use Exporter ();
  6         89  
  6         60  
16 6     6   208 use ExtUtils::MakeMaker qw(prompt); # for some unknown reason,
  6         63  
  6         302  
17             # 5.005_04 does not work without
18             # this
19 6     6   219 use File::Basename ();
  6         53  
  6         57  
20 6     6   186 use File::Copy ();
  6         60  
  6         62  
21 6     6   105 use File::Find;
  6         53  
  6         129  
22 6     6   103 use File::Path ();
  6         55  
  6         54  
23 6     6   1580 use File::Spec ();
  6         84  
  6         61  
24 6     6   211 use FileHandle ();
  6         59  
  6         59  
25 6     6   200 use Safe ();
  6         127  
  6         66  
26 6     6   294 use Sys::Hostname qw(hostname);
  6         64  
  6         149  
27 6     6   228 use Text::ParseWords ();
  6         62  
  6         64  
28 6     6   247 use Text::Wrap ();
  6         63  
  6         66  
29              
30             # we need to run chdir all over and we would get at wrong libraries
31             # there
32             BEGIN {
33 6 50   6   224     if (File::Spec->can("rel2abs")) {
34 6         69         for my $inc (@INC) {
35 111         6069             $inc = File::Spec->rel2abs($inc);
36                     }
37                 }
38             }
39 6     6   598 no lib ".";
  6         88  
  6         364  
40              
41             require Mac::BuildTools if $^O eq 'MacOS';
42              
43             END { $CPAN::End++; &cleanup; }
44              
45             $CPAN::Signal ||= 0;
46             $CPAN::Frontend ||= "CPAN::Shell";
47             unless (@CPAN::Defaultsites){
48                 @CPAN::Defaultsites = map {
49                     CPAN::URL->new(TEXT => $_, FROM => "DEF")
50                 }
51                     "http://www.perl.org/CPAN/",
52                         "ftp://ftp.perl.org/pub/CPAN/";
53             }
54             # $CPAN::iCwd (i for initial) is going to be initialized during find_perl
55             $CPAN::Perl ||= CPAN::find_perl();
56             $CPAN::Defaultdocs ||= "http://search.cpan.org/perldoc?";
57             $CPAN::Defaultrecent ||= "http://search.cpan.org/recent";
58              
59              
60 6         455 use vars qw($VERSION @EXPORT $AUTOLOAD $DEBUG $META $HAS_USABLE $term
61             $Signal $Suppress_readline $Frontend
62             @Defaultsites $Have_warned $Defaultdocs $Defaultrecent
63 6     6   185 $Be_Silent );
  6         59  
64              
65             @CPAN::ISA = qw(CPAN::Debug Exporter);
66              
67             # note that these functions live in CPAN::Shell and get executed via
68             # AUTOLOAD when called directly
69             @EXPORT = qw(
70             autobundle
71             bundle
72             clean
73             cvs_import
74             expand
75             force
76             get
77             install
78             make
79             mkmyconfig
80             notest
81             perldoc
82             readme
83             recent
84             recompile
85             shell
86             test
87             upgrade
88             );
89              
90             sub soft_chdir_with_alternatives ($);
91              
92             #-> sub CPAN::AUTOLOAD ;
93             sub AUTOLOAD {
94 1     1   66     my($l) = $AUTOLOAD;
95 1         36     $l =~ s/.*:://;
96 1         10     my(%EXPORT);
97 1         128     @EXPORT{@EXPORT} = '';
98 1 50       92     CPAN::HandleConfig->load unless $CPAN::Config_loaded++;
99 1 50       13     if (exists $EXPORT{$l}){
100 0         0 CPAN::Shell->$l(@_);
101                 } else {
102 1         34 die(qq{Unknown CPAN command "$AUTOLOAD". }.
103                         qq{Type ? for help.\n});
104                 }
105             }
106              
107             #-> sub CPAN::shell ;
108             sub shell {
109 1     1   11     my($self) = @_;
110 1 50       27     $Suppress_readline = ! -t STDIN unless defined $Suppress_readline;
111 1 50       65     CPAN::HandleConfig->load unless $CPAN::Config_loaded++;
112              
113 1   33     25     my $oprompt = shift || CPAN::Prompt->new;
114 1         14     my $prompt = $oprompt;
115 1   50     19     my $commandline = shift || "";
116 1   50     12     $CPAN::CurrentCommandId ||= 1;
117              
118 1         14     local($^W) = 1;
119 1 50       12     unless ($Suppress_readline) {
120 1         46 require Term::ReadLine;
121 1 50 33     18         if (! $term
122                         or
123                         $term->ReadLine eq "Term::ReadLine::Stub"
124                        ) {
125 1         22             $term = Term::ReadLine->new('CPAN Monitor');
126                     }
127 1 50       14 if ($term->ReadLine eq "Term::ReadLine::Gnu") {
128 0         0 my $attribs = $term->Attribs;
129             $attribs->{attempted_completion_function} = sub {
130 0     0   0 &CPAN::Complete::gnu_cpl;
131             }
132 0         0 } else {
133 1         34 $readline::rl_completion_function =
134             $readline::rl_completion_function = 'CPAN::Complete::cpl';
135             }
136 1 50       17         if (my $histfile = $CPAN::Config->{'histfile'}) {{
137 1 50       9             unless ($term->can("AddHistory")) {
  1         43  
138 0         0                 $CPAN::Frontend->mywarn("Terminal does not support AddHistory.\n");
139 0         0                 last;
140                         }
141 1         45             my($fh) = FileHandle->new;
142 1 50       14             open $fh, "<$histfile" or last;
143 0         0             local $/ = "\n";
144 0         0             while (<$fh>) {
145 0         0                 chomp;
146 0         0                 $term->AddHistory($_);
147                         }
148 0         0             close $fh;
149                     }}
150 1         21         for ($CPAN::Config->{term_ornaments}) { # alias
151 1         10             local $Term::ReadLine::termcap_nowarn = 1;
152 1 50       22             $term->ornaments($_) if defined;
153                     }
154             # $term->OUT is autoflushed anyway
155 1         16 my $odef = select STDERR;
156 1         13 $| = 1;
157 1         11 select STDOUT;
158 1         9 $| = 1;
159 1         14 select $odef;
160                 }
161              
162             # no strict; # I do not recall why no strict was here (2000-09-03)
163 1         31     $META->checklock();
164 1 50       20     my @cwd = (
165                            CPAN::anycwd(),
166                            File::Spec->can("tmpdir") ? File::Spec->tmpdir() : (),
167                            File::Spec->rootdir(),
168                           );
169 1         11010     my $try_detect_readline;
170 1 50       81     $try_detect_readline = $term->ReadLine eq "Term::ReadLine::Stub" if $term;
171 1 50       35     my $rl_avail = $Suppress_readline ? "suppressed" :
    50          
172             ($term->ReadLine ne "Term::ReadLine::Stub") ? "enabled" :
173             "available (try 'install Bundle::CPAN')";
174              
175 1 50       15     unless ($CPAN::Config->{'inhibit_startup_message'}){
176 1         265         $CPAN::Frontend->myprint(
177                                              sprintf qq{
178             cpan shell -- CPAN exploration and modules installation (v%s)
179             ReadLine support %s
180            
181             },
182                                              $CPAN::VERSION,
183                                              $rl_avail
184                                             )
185                 }
186 1         12     my($continuation) = "";
187 1         9     my $last_term_ornaments;
188 1         9   SHELLCOMMAND: while () {
189 125 50       1416 if ($Suppress_readline) {
190 0         0 print $prompt;
191 0 0       0 last SHELLCOMMAND unless defined ($_ = <> );
192 0         0 chomp;
193             } else {
194             last SHELLCOMMAND unless
195 125 50       2286                 defined ($_ = $term->readline($prompt, $commandline));
196             }
197 125 50       1341 $_ = "$continuation$_" if $continuation;
198 125         1903 s/^\s+//;
199 125 100       2114 next SHELLCOMMAND if /^$/;
200 124 50       1859 $_ = 'h' if /^\s*\?/;
201 124 100       6009 if (/^(?:q(?:uit)?|bye|exit)$/i) {
    50          
    100          
    50          
202 1         12 last SHELLCOMMAND;
203             } elsif (s/\\$//s) {
204 0         0 chomp;
205 0         0 $continuation = $_;
206 0         0 $prompt = " > ";
207             } elsif (/^\!/) {
208 5         51 s/^\!//;
209 5         63 my($eval) = $_;
210             package CPAN::Eval;
211 6     6   166             use strict;
  6         72  
  6         2925  
212 6     6   944 use vars qw($import_done);
  6         57  
  6         141  
213 5 100       143 CPAN->import(':DEFAULT') unless $import_done++;
214 5 50       1937 CPAN->debug("eval[$eval]") if $CPAN::DEBUG;
215 5         531 eval($eval);
216 5 50       106 warn $@ if $@;
217 5         48 $continuation = "";
218 5         55 $prompt = $oprompt;
219             } elsif (/./) {
220 118         1377 my(@line);
221 118 50       1238 if ($] < 5.00322) { # parsewords had a bug until recently
222 0         0 @line = split;
223             } else {
224 118         1138 eval { @line = Text::ParseWords::shellwords($_) };
  118         2436  
225 118 50       35034 warn($@), next SHELLCOMMAND if $@;
226 118 50       1687                 warn("Text::Parsewords could not parse the line [$_]"),
227                                 next SHELLCOMMAND unless @line;
228             }
229 118 50       1403 $CPAN::META->debug("line[".join("|",@line)."]") if $CPAN::DEBUG;
230 118         1331 my $command = shift @line;
231 118         1625 eval { CPAN::Shell->$command(@line) };
  118         2886  
232 118 100       5003 warn $@ if $@;
233 118 100       3380             if ($command =~ /^(make|test|install|force|notest|clean|upgrade)$/) {
234 17         547                 CPAN::Shell->failed($CPAN::CurrentCommandId,1);
235                         }
236 118         2537             soft_chdir_with_alternatives(\@cwd);
237 118         1580 $CPAN::Frontend->myprint("\n");
238 118         1515 $continuation = "";
239 118         5729             $CPAN::CurrentCommandId++;
240 118         4350 $prompt = $oprompt;
241             }
242                 } continue {
243 124         1895       $commandline = ""; # I do want to be able to pass a default to
244             # shell, but on the second command I see no
245             # use in that
246 124         2064       $Signal=0;
247 124         2418       CPAN::Queue->nullify_queue;
248 124 50       1498       if ($try_detect_readline) {
249 0 0 0     0 if ($CPAN::META->has_inst("Term::ReadLine::Gnu")
250             ||
251             $CPAN::META->has_inst("Term::ReadLine::Perl")
252             ) {
253 0         0 delete $INC{"Term/ReadLine.pm"};
254 0         0 my $redef = 0;
255 0         0 local($SIG{__WARN__}) = CPAN::Shell::paintdots_onreload(\$redef);
256 0         0 require Term::ReadLine;
257 0         0 $CPAN::Frontend->myprint("\n$redef subroutines in ".
258             "Term::ReadLine redefined\n");
259 0         0             @_ = ($oprompt,"");
260 0         0 goto &shell;
261             }
262                   }
263 124 50 33     7263       if ($term and $term->can("ornaments")) {
264 124         1676           for ($CPAN::Config->{term_ornaments}) { # alias
265 124 50       1726               if (defined $_) {
266 124 100 100     2677                   if (not defined $last_term_ornaments
267                                   or $_ != $last_term_ornaments
268                                  ) {
269 3         77                       local $Term::ReadLine::termcap_nowarn = 1;
270 3         128                       $term->ornaments($_);
271 3         68                       $last_term_ornaments = $_;
272                               }
273                           } else {
274 0         0                   undef $last_term_ornaments;
275                           }
276                       }
277                   }
278                 }
279 1         14     soft_chdir_with_alternatives(\@cwd);
280             }
281              
282             sub soft_chdir_with_alternatives ($) {
283 119     119   1399     my($cwd) = @_;
284 119         6328     while (not chdir $cwd->[0]) {
285 0 0       0         if (@$cwd>1) {
286 0         0             $CPAN::Frontend->mywarn(qq{Could not chdir to "$cwd->[0]": $!
287             Trying to chdir to "$cwd->[1]" instead.
288             });
289 0         0             shift @$cwd;
290                     } else {
291 0         0             $CPAN::Frontend->mydie(qq{Could not chdir to "$cwd->[0]": $!});
292                     }
293                 }
294             }
295              
296             # CPAN::_yaml_loadfile
297             sub _yaml_loadfile {
298 0     0   0     my($self,$local_file) = @_;
299 0   0     0     my $yaml_module = $CPAN::Config->{yaml_module} || "YAML";
300 0 0       0     CPAN->debug("local_file[$local_file]") if $CPAN::DEBUG;
301 0 0       0     if ($CPAN::META->has_inst($yaml_module)) {
302 0         0         my $code = UNIVERSAL::can($yaml_module, "LoadFile");
303 0         0         my @yaml;
304 0         0         eval { @yaml = $code->($local_file); };
  0         0  
305 0 0       0         CPAN->debug(sprintf "parts[%d]", scalar @yaml) if $CPAN::DEBUG;
306 0 0       0         if ($@) {
307 0         0             $CPAN::Frontend->mydie("Alert: While trying to parse YAML file\n".
308                                                " $local_file\n".
309                                                "with $yaml_module the following error was encountered:\n".
310                                                " $@\n"
311                                               );
312                     }
313 0         0         return \@yaml;
314                 } else {
315 0         0         $CPAN::Frontend->mywarn("'$yaml_module' not installed, cannot parse '$local_file'\n");
316                 }
317 0         0     return +[];
318             }
319              
320             package CPAN::CacheMgr;
321 6     6   186 use strict;
  6         74  
  6         577  
322             @CPAN::CacheMgr::ISA = qw(CPAN::InfoObj CPAN);
323 6     6   94 use File::Find;
  6         56  
  6         577  
324              
325             package CPAN::FTP;
326 6     6   105 use strict;
  6         55  
  6         82  
327 6     6   87 use vars qw($Ua $Thesite $ThesiteURL $Themethod);
  6         54  
  6         89  
328             @CPAN::FTP::ISA = qw(CPAN::Debug);
329              
330             package CPAN::LWP::UserAgent;
331 6     6   97 use strict;
  6         56  
  6         74  
332 6     6   89 use vars qw(@ISA $USER $PASSWD $SETUPDONE);
  6         370  
  6         75  
333             # we delay requiring LWP::UserAgent and setting up inheritance until we need it
334              
335             package CPAN::Complete;
336 6     6   92 use strict;
  6         57  
  6         517  
337             @CPAN::Complete::ISA = qw(CPAN::Debug);
338             @CPAN::Complete::COMMANDS = sort qw(
339             ! a b d h i m o q r u
340             autobundle
341             clean
342             cvs_import
343             dump
344             force
345             install
346             look
347             ls
348             make
349             mkmyconfig
350             notest
351             perldoc
352             readme
353             recent
354             recompile
355             reload
356             scripts
357             test
358             upgrade
359             );
360              
361             package CPAN::Index;
362 6     6   90 use strict;
  6         55  
  6         568  
363 6     6   98 use vars qw($LAST_TIME $DATE_OF_02 $DATE_OF_03);
  6         81  
  6         78  
364             @CPAN::Index::ISA = qw(CPAN::Debug);
365             $LAST_TIME ||= 0;
366             $DATE_OF_03 ||= 0;
367             # use constant PROTOCOL => "2.0"; # outcommented to avoid warning on upgrade from 1.57
368 1799     1799   25267 sub PROTOCOL { 2.0 }
369              
370             package CPAN::InfoObj;
371 6     6   164 use strict;
  6         89  
  6         74  
372             @CPAN::InfoObj::ISA = qw(CPAN::Debug);
373              
374             package CPAN::Author;
375 6     6   98 use strict;
  6         93  
  6         75  
376             @CPAN::Author::ISA = qw(CPAN::InfoObj);
377              
378             package CPAN::Distribution;
379 6     6   91 use strict;
  6         95  
  6         117  
380             @CPAN::Distribution::ISA = qw(CPAN::InfoObj);
381              
382             package CPAN::Bundle;
383 6     6   91 use strict;
  6         55  
  6         75  
384             @CPAN::Bundle::ISA = qw(CPAN::Module);
385              
386             package CPAN::Module;
387 6     6   787 use strict;
  6         69  
  6         73  
388             @CPAN::Module::ISA = qw(CPAN::InfoObj);
389              
390             package CPAN::Exception::RecursiveDependency;
391 6     6   93 use strict;
  6         55  
  6         76  
392 6     6   509 use overload '""' => "as_string";
  6         62  
  6         112  
393              
394             sub new {
395 1     1   124     my($class) = shift;
396 1         11     my($deps) = shift;
397 1         10     my @deps;
398 1         9     my %seen;
399 1         11     for my $dep (@$deps) {
400 4         38         push @deps, $dep;
401 4 100       97         last if $seen{$dep}++;
402                 }
403 1         123     bless { deps => \@deps }, $class;
404             }
405              
406             sub as_string {
407 1     1   44     my($self) = shift;
408 1         17     "\nRecursive dependency detected:\n " .
409 1         10         join("\n => ", @{$self->{deps}}) .
410                         ".\nCannot continue.\n";
411             }
412              
413 6     6   118 package CPAN::Prompt; use overload '""' => "as_string";
  6         59  
  6         82  
414 6     6   115 use vars qw($prompt);
  6         106  
  6         100  
415             $prompt = "cpan> ";
416             $CPAN::CurrentCommandId ||= 0;
417             sub new {
418 1     1   12     bless {}, shift;
419             }
420             sub as_string {
421 18961 100   18961   335554     if ($CPAN::Config->{commandnumber_in_prompt}) {
422 0         0         sprintf "cpan[%d]> ", $CPAN::CurrentCommandId;
423                 } else {
424 337         6784         "cpan> ";
425                 }
426             }
427              
428 6     6   99 package CPAN::URL; use overload '""' => "as_string", fallback => 1;
  6         57  
  6         137  
429             # accessors: TEXT(the url string), FROM(DEF=>defaultlist,USER=>urllist),
430             # planned are things like age or quality
431             sub new {
432 46     46   1032     my($class,%args) = @_;
433 46         3341     bless {
434                        %args
435                       }, $class;
436             }
437             sub as_string {
438 52     52   599     my($self) = @_;
439 52         1562     $self->text;
440             }
441             sub text {
442 52     52   589     my($self,$set) = @_;
443 52 50       544     if (defined $set) {
444 0         0         $self->{TEXT} = $set;
445                 }
446 52         636     $self->{TEXT};
447             }
448              
449             package CPAN::Distrostatus;
450 6         110 use overload '""' => "as_string",
451 6     6   129     fallback => 1;
  6         54  
452             sub new {
453 29     29   4038     my($class,$arg) = @_;
454 29         16750     bless {
455                        TEXT => $arg,
456                        FAILED => substr($arg,0,2) eq "NO",
457                        COMMANDID => $CPAN::CurrentCommandId,
458                       }, $class;
459             }
460 32     32   657 sub commandid { shift->{COMMANDID} }
461 192     192   2847 sub failed { shift->{FAILED} }
462             sub text {
463 41     41   475     my($self,$set) = @_;
464 41 50       478     if (defined $set) {
465 0         0         $self->{TEXT} = $set;
466                 }
467 41         1862     $self->{TEXT};
468             }
469             sub as_string {
470 30     30   932     my($self) = @_;
471 30         875     $self->text;
472             }
473              
474             package CPAN::Shell;
475 6     6   155 use strict;
  6         122  
  6         192  
476 6     6   104 use vars qw($AUTOLOAD @ISA $COLOR_REGISTERED $ADVANCED_QUERY);
  6         59  
  6         92  
477             @CPAN::Shell::ISA = qw(CPAN::Debug);
478             $COLOR_REGISTERED ||= 0;
479              
480             #-> sub CPAN::Shell::AUTOLOAD ;
481             sub AUTOLOAD {
482 2     2   22     my($autoload) = $AUTOLOAD;
483 2         34     my $class = shift(@_);
484             # warn "autoload[$autoload] class[$class]";
485 2         26     $autoload =~ s/.*:://;
486 2 50       37     if ($autoload =~ /^w/) {
487 0 0       0 if ($CPAN::META->has_inst('CPAN::WAIT')) {
488 0         0 CPAN::WAIT->$autoload(@_);
489             } else {
490 0         0 $CPAN::Frontend->mywarn(qq{
491             Commands starting with "w" require CPAN::WAIT to be installed.
492             Please consider installing CPAN::WAIT to use the fulltext index.
493             For this you just need to type
494             install CPAN::WAIT
495             });
496             }
497                 } else {
498 2         72 $CPAN::Frontend->mywarn(qq{Unknown shell command '$autoload @_'. }.
499             qq{Type ? for help.
500             });
501                 }
502             }
503              
504             package CPAN::Queue;
505 6     6   694 use strict;
  6         76  
  6         145  
506              
507             # One use of the queue is to determine if we should or shouldn't
508             # announce the availability of a new CPAN module
509              
510             # Now we try to use it for dependency tracking. For that to happen
511             # we need to draw a dependency tree and do the leaves first. This can
512             # easily be reached by running CPAN.pm recursively, but we don't want
513             # to waste memory and run into deep recursion. So what we can do is
514             # this:
515              
516             # CPAN::Queue is the package where the queue is maintained. Dependencies
517             # often have high priority and must be brought to the head of the queue,
518             # possibly by jumping the queue if they are already there. My first code
519             # attempt tried to be extremely correct. Whenever a module needed
520             # immediate treatment, I either unshifted it to the front of the queue,
521             # or, if it was already in the queue, I spliced and let it bypass the
522             # others. This became a too correct model that made it impossible to put
523             # an item more than once into the queue. Why would you need that? Well,
524             # you need temporary duplicates as the manager of the queue is a loop
525             # that
526             #
527             # (1) looks at the first item in the queue without shifting it off
528             #
529             # (2) cares for the item
530             #
531             # (3) removes the item from the queue, *even if its agenda failed and
532             # even if the item isn't the first in the queue anymore* (that way
533             # protecting against never ending queues)
534             #
535             # So if an item has prerequisites, the installation fails now, but we
536             # want to retry later. That's easy if we have it twice in the queue.
537             #
538             # I also expect insane dependency situations where an item gets more
539             # than two lives in the queue. Simplest example is triggered by 'install
540             # Foo Foo Foo'. People make this kind of mistakes and I don't want to
541             # get in the way. I wanted the queue manager to be a dumb servant, not
542             # one that knows everything.
543             #
544             # Who would I tell in this model that the user wants to be asked before
545             # processing? I can't attach that information to the module object,
546             # because not modules are installed but distributions. So I'd have to
547             # tell the distribution object that it should ask the user before
548             # processing. Where would the question be triggered then? Most probably
549             # in CPAN::Distribution::rematein.
550             # Hope that makes sense, my head is a bit off:-) -- AK
551              
552 6     6   125 use vars qw{ @All };
  6         82  
  6         82  
553              
554             # CPAN::Queue::new ;
555             sub new {
556 24     24   327   my($class,$s) = @_;
557 24         539   my $self = bless { qmod => $s }, $class;
558 24         266   push @All, $self;
559 24         252   return $self;
560             }
561              
562             # CPAN::Queue::first ;
563             sub first {
564 51     51   730   my $obj = $All[0];
565 51         1383   $obj->{qmod};
566             }
567              
568             # CPAN::Queue::delete_first ;
569             sub delete_first {
570 23     23   995   my($class,$what) = @_;
571 23         841   my $i;
572 23         350   for my $i (0..$#All) {
573 13 50       463     if ( $All[$i]->{qmod} eq $what ) {
574 13         342       splice @All, $i, 1;
575 13         738       return;
576                 }
577               }
578             }
579              
580             # CPAN::Queue::jumpqueue ;
581             sub jumpqueue {
582 0     0   0     my $class = shift;
583 0         0     my @what = @_;
584 0         0     CPAN->debug(sprintf("before jumpqueue All[%s] what[%s]",
585 0 0       0                         join(",",map {$_->{qmod}} @All),
586                                     join(",",@what)
587                                    )) if $CPAN::DEBUG;
588 0         0   WHAT: for my $what (reverse @what) {
589 0         0         my $jumped = 0;
590                     for (my $i=0; $i<$#All;$i++) { #prevent deep recursion
591 0 0       0             CPAN->debug("i[$All[$i]]what[$what]") if $CPAN::DEBUG;
592 0 0       0             if ($All[$i]->{qmod} eq $what){
593 0         0                 $jumped++;
594 0 0       0                 if ($jumped > 100) { # one's OK if e.g. just
595             # processing now; more are OK if
596             # user typed it several times
597 0         0                     $CPAN::Frontend->mywarn(
598             qq{Object [$what] queued more than 100 times, ignoring}
599             );
600 0         0                     next WHAT;
601                             }
602                         }
603 0         0         }
604 0         0         my $obj = bless { qmod => $what }, $class;
605 0         0         unshift @All, $obj;
606                 }
607 0         0     CPAN->debug(sprintf("after jumpqueue All[%s] what[%s]",
608 0 0       0                         join(",",map {$_->{qmod}} @All),
609                                     join(",",@what)
610                                    )) if $CPAN::DEBUG;
611             }
612              
613             # CPAN::Queue::exists ;
614             sub exists {
615 0     0   0   my($self,$what) = @_;
616 0         0   my @all = map { $_->{qmod} } @All;
  0         0  
617 0         0   my $exists = grep { $_->{qmod} eq $what } @All;
  0         0  
618             # warn "in exists what[$what] all[@all] exists[$exists]";
619 0         0   $exists;
620             }
621              
622             # CPAN::Queue::delete ;
623             sub delete {
624 10     10   171   my($self,$mod) = @_;
625 10         236   @All = grep { $_->{qmod} ne $mod } @All;
  0         0  
626             }
627              
628             # CPAN::Queue::nullify_queue ;
629             sub nullify_queue {
630 124     124   1647   @All = ();
631             }
632              
633              
634              
635             package CPAN;
636 6     6   140 use strict;
  6         70  
  6         94  
637              
638             $META ||= CPAN->new; # In case we re-eval ourselves we need the ||
639              
640             # from here on only subs.
641             ################################################################################
642              
643             sub suggest_myconfig () {
644 0 0   0   0   SUGGEST_MYCONFIG: if(!$INC{'CPAN/MyConfig.pm'}) {
645 0         0         $CPAN::Frontend->myprint("You don't seem to have a user ".
646                                              "configuration (MyConfig.pm) yet.\n");
647 0         0         my $new = CPAN::Shell::colorable_makemaker_prompt("Do you want to create a ".
648                                                           "user configuration now? (Y/n)",
649                                                           "yes");
650 0 0       0         if($new =~ m{^y}i) {
651 0         0             CPAN::Shell->mkmyconfig();
652 0         0             return &checklock;
653                     } else {
654 0         0             $CPAN::Frontend->mydie("OK, giving up.");
655                     }
656                 }
657             }
658              
659             #-> sub CPAN::all_objects ;
660             sub all_objects {
661 34     34   2510     my($mgr,$class) = @_;
662 34 50       459     CPAN::HandleConfig->load unless $CPAN::Config_loaded++;
663 34 50       499     CPAN->debug("mgr[$mgr] class[$class]") if $CPAN::DEBUG;
664 34         559     CPAN::Index->reload;
665 34         836     values %{ $META->{readwrite}{$class} }; # unsafe meta access, ok
  0         0  
666             }
667              
668             # Called by shell, not in batch mode. In batch mode I see no risk in
669             # having many processes updating something as installations are
670             # continually checked at runtime. In shell mode I suspect it is
671             # unintentional to open more than one shell at a time
672              
673             #-> sub CPAN::checklock ;
674             sub checklock {
675 1     1   11     my($self) = @_;
676 1         26     my $lockfile = File::Spec->catfile($CPAN::Config->{cpan_home},".lock");
677 1 50 33     31     if (-f $lockfile && -M _ > 0) {
678 0 0       0 my $fh = FileHandle->new($lockfile) or
679                         $CPAN::Frontend->mydie("Could not open lockfile '$lockfile': $!");
680 0         0 my $otherpid = <$fh>;
681 0         0 my $otherhost = <$fh>;
682 0         0 $fh->close;
683 0 0 0     0 if (defined $otherpid && $otherpid) {
684 0         0 chomp $otherpid;
685                     }
686 0 0 0     0 if (defined $otherhost && $otherhost) {
687 0         0 chomp $otherhost;
688             }
689 0         0 my $thishost = hostname();
690 0 0 0     0 if (defined $otherhost && defined $thishost &&
    0 0        
      0        
      0        
      0        
691             $otherhost ne '' && $thishost ne '' &&
692             $otherhost ne $thishost) {
693 0         0             $CPAN::Frontend->mydie(sprintf("CPAN.pm panic: Lockfile '$lockfile'\n".
694                                                        "reports other host $otherhost and other ".
695                                                        "process $otherpid.\n".
696                                                        "Cannot proceed.\n"));
697             }
698             elsif (defined $otherpid && $otherpid) {
699 0 0       0 return if $$ == $otherpid; # should never happen
700 0         0 $CPAN::Frontend->mywarn(
701             qq{
702             There seems to be running another CPAN process (pid $otherpid). Contacting...
703             });
704 0 0       0 if (kill 0, $otherpid) {
    0          
705 0         0 $CPAN::Frontend->mydie(qq{Other job is running.
706             You may want to kill it and delete the lockfile, maybe. On UNIX try:
707             kill $otherpid
708             rm $lockfile
709             });
710             } elsif (-w $lockfile) {
711 0         0 my($ans) =
712             CPAN::Shell::colorable_makemaker_prompt
713             (qq{Other job not responding. Shall I overwrite }.
714             qq{the lockfile '$lockfile'? (Y/n)},"y");
715 0 0       0 $CPAN::Frontend->myexit("Ok, bye\n")
716             unless $ans =~ /^y/i;
717             } else {
718 0         0 Carp::croak(
719             qq{Lockfile '$lockfile' not writeable by you. }.
720             qq{Cannot proceed.\n}.
721             qq{ On UNIX try:\n}.
722             qq{ rm '$lockfile'\n}.
723             qq{ and then rerun us.\n}
724             );
725             }
726             } else {
727 0         0             $CPAN::Frontend->mydie(sprintf("CPAN.pm panic: Lockfile '$lockfile'\n".
728                                                        "reports other process with ID ".
729                                                        "$otherpid. Cannot proceed.\n"));
730                     }
731                 }
732 1         10     my $dotcpan = $CPAN::Config->{cpan_home};
733 1         9     eval { File::Path::mkpath($dotcpan);};
  1         13  
734 1 50       178     if ($@) {
735             # A special case at least for Jarkko.
736 0         0         my $firsterror = $@;
737 0         0         my $seconderror;
738 0         0         my $symlinkcpan;
739 0 0       0         if (-l $dotcpan) {
740 0         0             $symlinkcpan = readlink $dotcpan;
741 0 0       0             die "readlink $dotcpan failed: $!" unless defined $symlinkcpan;
742 0         0             eval { File::Path::mkpath($symlinkcpan); };
  0         0  
743 0 0       0             if ($@) {
744 0         0                 $seconderror = $@;
745                         } else {
746 0         0                 $CPAN::Frontend->mywarn(qq{
747             Working directory $symlinkcpan created.
748             });
749                         }
750                     }
751 0 0       0         unless (-d $dotcpan) {
752 0         0             my $mess = qq{
753             Your configuration suggests "$dotcpan" as your
754             CPAN.pm working directory. I could not create this directory due
755             to this error: $firsterror\n};
756 0 0       0             $mess .= qq{
757             As "$dotcpan" is a symlink to "$symlinkcpan",
758             I tried to create that, but I failed with this error: $seconderror
759             } if $seconderror;
760 0         0             $mess .= qq{
761             Please make sure the directory exists and is writable.
762             };
763 0         0             $CPAN::Frontend->myprint($mess);
764 0         0             return suggest_myconfig;
765                     }
766                 } # $@ after eval mkpath $dotcpan
767 1         10     my $fh;
768 1 50       29     unless ($fh = FileHandle->new(">$lockfile")) {
769 0 0       0 if ($! =~ /Permission/) {
770 0         0 $CPAN::Frontend->myprint(qq{
771            
772             Your configuration suggests that CPAN.pm should use a working
773             directory of
774             $CPAN::Config->{cpan_home}
775             Unfortunately we could not create the lock file
776             $lockfile
777             due to permission problems.
778            
779             Please make sure that the configuration variable
780             \$CPAN::Config->{cpan_home}
781             points to a directory where you can write a .lock file. You can set
782             this variable in either a CPAN/MyConfig.pm or a CPAN/Config.pm in your
783             \@INC path;
784             });
785 0         0             return suggest_myconfig;
786             }
787                 }
788 1         2594     $fh->print($$, "\n");
789 1         83     $fh->print(hostname(), "\n");
790 1         47     $self->{LOCK} = $lockfile;
791 1         26     $fh->close;
792                 $SIG{TERM} = sub {
793 0     0   0       &cleanup;
794 0         0       $CPAN::Frontend->mydie("Got SIGTERM, leaving");
795 1         270     };
796                 $SIG{INT} = sub {
797             # no blocks!!!
798 0 0   0   0       &cleanup if $Signal;
799 0 0       0       $CPAN::Frontend->mydie("Got another SIGINT") if $Signal;
800 0         0       $CPAN::Frontend->myprint("Caught SIGINT\n");
801 0         0       $Signal++;
802 1         23     };
803              
804             # From: Larry Wall <larry@wall.org>
805             # Subject: Re: deprecating SIGDIE
806             # To: perl5-porters@perl.org
807             # Date: Thu, 30 Sep 1999 14:58:40 -0700 (PDT)
808             #
809             # The original intent of __DIE__ was only to allow you to substitute one
810             # kind of death for another on an application-wide basis without respect
811             # to whether you were in an eval or not. As a global backstop, it should
812             # not be used any more lightly (or any more heavily :-) than class
813             # UNIVERSAL. Any attempt to build a general exception model on it should
814             # be politely squashed. Any bug that causes every eval {} to have to be
815             # modified should be not so politely squashed.
816             #
817             # Those are my current opinions. It is also my optinion that polite
818             # arguments degenerate to personal arguments far too frequently, and that
819             # when they do, it's because both people wanted it to, or at least didn't
820             # sufficiently want it not to.
821             #
822             # Larry
823              
824             # global backstop to cleanup if we should really die
825 1         14     $SIG{__DIE__} = \&cleanup;
826 1 50       17     $self->debug("Signal handler set.") if $CPAN::DEBUG;
827             }
828              
829             #-> sub CPAN::DESTROY ;
830             sub DESTROY {
831 0     0   0     &cleanup; # need an eval?
832             }
833              
834             #-> sub CPAN::anycwd ;
835             sub anycwd () {
836 19     19   224     my $getcwd;
837 19   100     5889     $getcwd = $CPAN::Config->{'getcwd'} || 'cwd';
838 19         415     CPAN->$getcwd();
839             }
840              
841             #-> sub CPAN::cwd ;
842 19     19   445 sub cwd {Cwd::cwd();}
843              
844             #-> sub CPAN::getcwd ;
845 0     0   0 sub getcwd {Cwd::getcwd();}
846              
847             #-> sub CPAN::fastcwd ;
848 0     0   0 sub fastcwd {Cwd::fastcwd();}
849              
850             #-> sub CPAN::backtickcwd ;
851 0     0   0 sub backtickcwd {my $cwd = `cwd`; chomp $cwd; $cwd}
  0         0  
  0         0  
852              
853             #-> sub CPAN::find_perl ;
854             sub find_perl {
855 6 50   6   469     my($perl) = File::Spec->file_name_is_absolute($^X) ? $^X : "";
856 6         331     my $pwd = $CPAN::iCwd = CPAN::anycwd();
857 6         110288     my $candidate = File::Spec->catfile($pwd,$^X);
858 6 50 0     2093     $perl ||= $candidate if MM->maybe_command($candidate);
859              
860 6 50       614     unless ($perl) {
861 0         0 my ($component,$perl_name);
862 0         0       DIST_PERLNAME: foreach $perl_name ($^X, 'perl', 'perl5', "perl$]") {
863 0         0 PATH_COMPONENT: foreach $component (File::Spec->path(),
864             $Config::Config{'binexp'}) {
865 0 0 0     0 next unless defined($component) && $component;
866 0         0 my($abs) = File::Spec->catfile($component,$perl_name);
867 0 0       0 if (MM->maybe_command($abs)) {
868 0         0 $perl = $abs;
869 0         0 last DIST_PERLNAME;
870             }
871             }
872             }
873                 }
874              
875 6         317     return $perl;
876             }
877              
878              
879             #-> sub CPAN::exists ;
880             sub exists {
881 636     636   9669     my($mgr,$class,$id) = @_;
882 636 50       9121     CPAN::HandleConfig->load unless $CPAN::Config_loaded++;
883 636         12380     CPAN::Index->reload;
884             ### Carp::croak "exists called without class argument" unless $class;
885 636   50     7703     $id ||= "";
886 636 100       14862     $id =~ s/:+/::/g if $class eq "CPAN::Module";
887 636 100       12664     exists $META->{readonly}{$class}{$id} or
888                     exists $META->{readwrite}{$class}{$id}; # unsafe meta access, ok
889             }
890              
891             #-> sub CPAN::delete ;
892             sub delete {
893 0     0   0   my($mgr,$class,$id) = @_;
894 0         0   delete $META->{readonly}{$class}{$id}; # unsafe meta access, ok
895 0         0   delete $META->{readwrite}{$class}{$id}; # unsafe meta access, ok
896             }
897              
898             #-> sub CPAN::has_usable
899             # has_inst is sometimes too optimistic, we should replace it with this
900             # has_usable whenever a case is given
901             sub has_usable {
902 41     41   964     my($self,$mod,$message) = @_;
903 41 100       1133     return 1 if $HAS_USABLE->{$mod};
904 4         89     my $has_inst = $self->has_inst($mod,$message);
905 4 50       47     return unless $has_inst;
906 4         34     my $usable;
907 0     0   0     $usable = {
908                            LWP => [ # we frequently had "Can't locate object
909             # method "new" via package "LWP::UserAgent" at
910             # (eval 69) line 2006
911                                    sub {require LWP},
912 0     0   0                        sub {require LWP::UserAgent},
913 0     0   0                        sub {require HTTP::Request},
914 0     0   0                        sub {require URI::URL},
915 0     0   0                       ],
916                            'Net::FTP' => [
917                                         sub {require Net::FTP},
918 0     0   0                             sub {require Net::Config},
919 0     0   0                            ],
920                            'File::HomeDir' => [
921                                                sub {require File::HomeDir;
922 0 0       0                                         unless (File::HomeDir->VERSION >= 0.52){
923 0         0                                             for ("Will not use File::HomeDir, need 0.52\n") {
924 0         0                                                 $CPAN::Frontend->mywarn($_);
925 0         0                                                 die $_;
926                                                         }
927                                                     }
928                                                 },
929 4         74                                   ],
930                           };
931 4 50       51     if ($usable->{$mod}) {
932 0         0         for my $c (0..$#{$usable->{$mod}}) {
  0         0  
933 0         0             my $code = $usable->{$mod}[$c];
934 0         0             my $ret = eval { &$code() };
  0         0  
935 0 0       0             $ret = "" unless defined $ret;
936 0 0       0             if ($@) {
937             # warn "DEBUG: c[$c]\$\@[$@]ret[$ret]";
938 0         0                 return;
939                         }
940                     }
941                 }
942 4         84     return $HAS_USABLE->{$mod} = 1;
943             }
944              
945             #-> sub CPAN::has_inst
946             sub has_inst {
947 129     129   5354     my($self,$mod,$message) = @_;
948 129 50       2152     Carp::croak("CPAN->has_inst() called without an argument")
949             unless defined $mod;
950 15 100       686     my %dont = map { $_ => 1 } keys %{$CPAN::META->{dontload_hash}||{}},
  19 50       373  
  19         274  
951 19 50       389         keys %{$CPAN::Config->{dontload_hash}||{}},
952 129         6962             @{$CPAN::Config->{dontload_list}||[]};
953 129 100 66     3531     if (defined $message && $message eq "no" # afair only used by Nox
      100        
954                     ||
955                     $dont{$mod}
956                    ) {
957 9   100     142       $CPAN::META->{dontload_hash}{$mod}||=1; # unsafe meta access, ok
958 9         194       return 0;
959                 }
960 120         4596     my $file = $mod;
961 120         1041     my $obj;
962 120         2236     $file =~ s|::|/|g;
963 120         2899     $file .= ".pm";
964 120 100       3056     if ($INC{$file}) {
    50          
    0          
    0          
    0          
965             # checking %INC is wrong, because $INC{LWP} may be true
966             # although $INC{"URI/URL.pm"} may have failed. But as
967             # I really want to say "bla loaded OK", I have to somehow
968             # cache results.
969             ### warn "$file in %INC"; #debug
970 6         79 return 1;
971 13         1612     } elsif (eval { require $file }) {
972             # eval is good: if we haven't yet read the database it's
973             # perfect and if we have installed the module in the meantime,
974             # it tries again. The second require is only a NOOP returning
975             # 1 if we had success, otherwise it's retrying
976              
977 13         854 $CPAN::Frontend->myprint("CPAN: $mod loaded ok\n");
978 13 50       245 if ($mod eq "CPAN::WAIT") {
979 0         0 push @CPAN::Shell::ISA, 'CPAN::WAIT';
980             }
981 13         257 return 1;
982                 } elsif ($mod eq "Net::FTP") {
983 0 0       0 $CPAN::Frontend->mywarn(qq{
984             Please, install Net::FTP as soon as possible. CPAN.pm installs it for you
985             if you just type
986             install Bundle::libnet
987            
988             }) unless $Have_warned->{"Net::FTP"}++;
989 0         0 $CPAN::Frontend->mysleep(3);
990                 } elsif ($mod eq "Digest::SHA"){
991 0 0       0         if ($Have_warned->{"Digest::SHA"}++) {
992 0         0             $CPAN::Frontend->myprint(qq{CPAN: checksum security checks disabled}.
993                                                  qq{because Digest::SHA not installed.\n});
994                     } else {
995 0         0             $CPAN::Frontend->mywarn(qq{
996             CPAN: checksum security checks disabled because Digest::SHA not installed.
997             Please consider installing the Digest::SHA module.
998            
999             });
1000 0         0             $CPAN::Frontend->mysleep(2);
1001                     }
1002                 } elsif ($mod eq "Module::Signature"){
1003 0 0       0         if (not $CPAN::Config->{check_sigs}) {
    0          
1004             # they do not want us:-(
1005                     } elsif (not $Have_warned->{"Module::Signature"}++) {
1006             # No point in complaining unless the user can
1007             # reasonably install and use it.
1008 0 0 0     0 if (eval { require Crypt::OpenPGP; 1 } ||
  0   0     0  
  0         0  
1009             (
1010                              defined $CPAN::Config->{'gpg'}
1011                              &&
1012                              $CPAN::Config->{'gpg'} =~ /\S/
1013                             )
1014                            ) {
1015 0         0 $CPAN::Frontend->mywarn(qq{
1016             CPAN: Module::Signature security checks disabled because Module::Signature
1017             not installed. Please consider installing the Module::Signature module.
1018             You may also need to be able to connect over the Internet to the public
1019             keyservers like pgp.mit.edu (port 11371).
1020            
1021             });
1022 0         0 $CPAN::Frontend->mysleep(2);
1023             }
1024             }
1025                 } else {
1026 0         0 delete $INC{$file}; # if it inc'd LWP but failed during, say, URI
1027                 }
1028 0         0     return 0;
1029             }
1030              
1031             #-> sub CPAN::instance ;
1032             sub instance {
1033 1067     1067   15583     my($mgr,$class,$id) = @_;
1034 1067         24103     CPAN::Index->reload;
1035 1067   50     10740     $id ||= "";
1036             # unsafe meta access, ok?
1037 1067 100       18732     return $META->{readwrite}{$class}{$id} if exists $META->{readwrite}{$class}{$id};
1038 53   33     1449     $META->{readwrite}{$class}{$id} ||= $class->new(ID => $id);
1039             }
1040              
1041             #-> sub CPAN::new ;
1042             sub new {
1043 6     6   939     bless {}, shift;
1044             }
1045              
1046             #-> sub CPAN::cleanup ;
1047             sub cleanup {
1048             # warn "cleanup called with arg[@_] End[$CPAN::End] Signal[$Signal]";
1049 8     8   160   local $SIG{__DIE__} = '';
1050 8         87   my($message) = @_;
1051 8         86   my $i = 0;
1052 8         74   my $ineval = 0;
1053 8         105   my($subroutine);
1054 8         235   while ((undef,undef,undef,$subroutine) = caller(++$i)) {
1055 24 100       483       $ineval = 1, last if
1056             $subroutine eq '(eval)';
1057               }
1058 8 100 66     311   return if $ineval && !$CPAN::End;
1059 7 100       156   return unless defined $META->{LOCK};
1060 1 50       46   return unless -f $META->{LOCK};
1061 1         26   $META->savehist;
1062 1         108   unlink $META->{LOCK};
1063             # require Carp;
1064             # Carp::cluck("DEBUGGING");
1065 1         20   $CPAN::Frontend->myprint("Lockfile removed.\n");
1066             }
1067              
1068             #-> sub CPAN::savehist
1069             sub savehist {
1070 1     1   60     my($self) = @_;
1071 1         10     my($histfile,$histsize);
1072 1 50       14     unless ($histfile = $CPAN::Config->{'histfile'}){
1073 0         0         $CPAN::Frontend->mywarn("No history written (no histfile specified).\n");
1074 0         0         return;
1075                 }
1076 1   50     14     $histsize = $CPAN::Config->{'histsize'} || 100;
1077 1 50       13     if ($CPAN::term){
1078 1 50       18         unless ($CPAN::term->can("GetHistory")) {
1079 0         0             $CPAN::Frontend->mywarn("Terminal does not support GetHistory.\n");
1080 0         0             return;
1081                     }
1082                 } else {
1083 0         0         return;
1084                 }
1085 1         32     my @h = $CPAN::term->GetHistory;
1086 1 50       24     splice @h, 0, @h-$histsize if @h>$histsize;
1087 1         22     my($fh) = FileHandle->new;
1088 1 50       250     open $fh, ">$histfile" or $CPAN::Frontend->mydie("Couldn't open >$histfile: $!");
1089 1         16     local $\ = local $, = "\n";
1090 1         144     print $fh @h;
1091 1         14     close $fh;
1092             }
1093              
1094             sub is_tested {
1095 7     7   1269     my($self,$what) = @_;
1096 7         475     $self->{is_tested}{$what} = 1;
1097             }
1098              
1099             # unsets the is_tested flag: as soon as the thing is installed, it is
1100             # not needed in set_perl5lib anymore
1101             sub is_installed {
1102 0     0   0     my($self,$what) = @_;
1103 0         0     delete $self->{is_tested}{$what};
1104             }
1105              
1106             sub set_perl5lib {
1107 9     9   107     my($self) = @_;
1108 9   100     202     $self->{is_tested} ||= {};
1109 9 100       177     return unless %{$self->{is_tested}};
  0         0  
1110 8         270     my $env = $ENV{PERL5LIB};
1111 8 50       89     $env = $ENV{PERLLIB} unless defined $env;
1112 8         68     my @env;
1113 8 50 33     664     push @env, $env if defined $env and length $env;
1114 8         609     my @dirs = map {("$_/blib/arch", "$_/blib/lib")} keys %{$self->{is_tested}};
  0         0  
  0         0  
1115 8         797     $CPAN::Frontend->myprint("Prepending @dirs to PERL5LIB.\n");
1116 8         600     $ENV{PERL5LIB} = join $Config::Config{path_sep}, @dirs, @env;
1117             }
1118              
1119             package CPAN::CacheMgr;
1120 6     6   165 use strict;
  6         73  
  6         133  
1121              
1122             #-> sub CPAN::CacheMgr::as_string ;
1123             sub as_string {
1124 0     0   0     eval { require Data::Dumper };
  0         0  
1125 0 0       0     if ($@) {
1126 0         0 return shift->SUPER::as_string;
1127                 } else {
1128 0         0 return Data::Dumper::Dumper(shift);
1129                 }
1130             }
1131              
1132             #-> sub CPAN::CacheMgr::cachesize ;
1133             sub cachesize {
1134 0     0   0     shift->{DU};
1135             }
1136              
1137             #-> sub CPAN::CacheMgr::tidyup ;
1138             sub tidyup {
1139 1     1   37   my($self) = @_;
1140 1 50       159   return unless -d $self->{ID};
1141 1         57   while ($self->{DU} > $self->{'MAX'} ) {
1142 0         0     my($toremove) = shift @{$self->{FIFO}};
  0         0  
1143 0         0     $CPAN::Frontend->myprint(sprintf(
1144             "Deleting from cache".
1145             ": $toremove (%.1f>%.1f MB)\n",
1146             $self->{DU}, $self->{'MAX'})
1147             );
1148 0 0       0     return if $CPAN::Signal;
1149 0         0     $self->force_clean_cache($toremove);
1150 0 0       0     return if $CPAN::Signal;
1151               }
1152             }
1153              
1154             #-> sub CPAN::CacheMgr::dir ;
1155             sub dir {
1156 7     7   114     shift->{ID};
1157             }
1158              
1159             #-> sub CPAN::CacheMgr::entries ;
1160             sub entries {
1161 1     1   12     my($self,$dir) = @_;
1162 1 50       13     return unless defined $dir;
1163 1 50       13     $self->debug("reading dir[$dir]") if $CPAN::DEBUG;
1164 1   33     13     $dir ||= $self->{ID};
1165 1         13     my($cwd) = CPAN::anycwd();
1166 1 50       14375     chdir $dir or Carp::croak("Can't chdir to $dir: $!");
1167 1 50       246     my $dh = DirHandle->new(File::Spec->curdir)
1168                     or Carp::croak("Couldn't opendir $dir: $!");
1169 1         398     my(@entries);
1170 1         61     for ($dh->read) {
1171 2 50 66     191 next if $_ eq "." || $_ eq "..";
1172 0 0       0 if (-f $_) {
    0          
1173 0         0 push @entries, File::Spec->catfile($dir,$_);
1174             } elsif (-d _) {
1175 0         0 push @entries, File::Spec->catdir($dir,$_);
1176             } else {
1177 0         0 $CPAN::Frontend->mywarn("Warning: weird direntry in $dir: $_\n");
1178             }
1179                 }
1180 1 50       717     chdir $cwd or Carp::croak("Can't chdir to $cwd: $!");
1181 1         37     sort { -M $b <=> -M $a} @entries;
  0         0  
1182             }
1183              
1184             #-> sub CPAN::CacheMgr::disk_usage ;
1185             sub disk_usage {
1186 0     0   0     my($self,$dir) = @_;
1187 0 0       0     return if exists $self->{SIZE}{$dir};
1188 0 0       0     return if $CPAN::Signal;
1189 0         0     my($Du) = 0;
1190 0 0       0     if (-e $dir) {
1191 0 0       0         unless (-x $dir) {
1192 0 0       0             unless (chmod 0755, $dir) {
1193 0         0                 $CPAN::Frontend->mywarn("I have neither the -x permission nor the ".
1194                                                     "permission to change the permission; cannot ".
1195                                                     "estimate disk usage of '$dir'\n");
1196 0         0                 $CPAN::Frontend->mysleep(5);
1197 0         0                 return;
1198                         }
1199                     }
1200                 } else {
1201 0         0         $CPAN::Frontend->mywarn("Directory '$dir' has gone. Cannot continue.\n");
1202 0         0         $CPAN::Frontend->mysleep(2);
1203 0         0         return;
1204                 }
1205                 find(
1206                      sub {
1207 0 0   0   0            $File::Find::prune++ if $CPAN::Signal;
1208 0 0       0            return if -l $_;
1209 0 0       0            if ($^O eq 'MacOS') {
1210 0         0              require Mac::Files;
1211 0         0              my $cat = Mac::Files::FSpGetCatInfo($_);
1212 0 0       0              $Du += $cat->ioFlLgLen() + $cat->ioFlRLgLen() if $cat;
1213                        } else {
1214 0 0       0              if (-d _) {
1215 0 0       0                unless (-x _) {
1216 0 0       0                  unless (chmod 0755, $_) {
1217 0         0                    $CPAN::Frontend->mywarn("I have neither the -x permission nor ".
1218                                                        "the permission to change the permission; ".
1219                                                        "can only partially estimate disk usage ".
1220                                                        "of '$_'\n");
1221 0         0                    $CPAN::Frontend->mysleep(5);
1222 0         0                    return;
1223                              }
1224                            }
1225                          } else {
1226 0         0                $Du += (-s _);
1227                          }
1228                        }
1229                      },
1230 0         0          $dir
1231                     );
1232 0 0       0     return if $CPAN::Signal;
1233 0         0     $self->{SIZE}{$dir} = $Du/1024/1024;
1234 0         0     push @{$self->{FIFO}}, $dir;
  0         0  
1235 0 0       0     $self->debug("measured $dir is $Du") if $CPAN::DEBUG;
1236 0         0     $self->{DU} += $Du/1024/1024;
1237 0         0     $self->{DU};
1238             }
1239              
1240             #-> sub CPAN::CacheMgr::force_clean_cache ;
1241             sub force_clean_cache {
1242 0     0   0     my($self,$dir) = @_;
1243 0 0       0     return unless -e $dir;
1244 0 0       0     $self->debug("have to rmtree $dir, will free $self->{SIZE}{$dir}")
1245             if $CPAN::DEBUG;
1246 0         0     File::Path::rmtree($dir);
1247 0         0     $self->{DU} -= $self->{SIZE}{$dir};
1248 0         0     delete $self->{SIZE}{$dir};
1249             }
1250              
1251             #-> sub CPAN::CacheMgr::new ;
1252             sub new {
1253 1     1   11     my $class = shift;
1254 1         17     my $time = time;
1255 1         9     my($debug,$t2);
1256 1         10     $debug = "";
1257 1