source: trunk/essentials/dev-lang/perl/lib/CPAN.pm@ 3221

Last change on this file since 3221 was 3181, checked in by bird, 19 years ago

perl 5.8.8
File size: 218.5 KB
Line 
1# -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*-
2package CPAN;
3$VERSION = '1.76_02';
4$VERSION = eval $VERSION;
5# $Id: CPAN.pm,v 1.412 2003/07/31 14:53:04 k Exp $
6
7# only used during development:
8$Revision = "";
9# $Revision = "[".substr(q$Revision: 1.412 $, 10)."]";
10
11use Carp ();
12use Config ();
13use Cwd ();
14use DirHandle;
15use Exporter ();
16use ExtUtils::MakeMaker (); # $SelfLoader::DEBUG=1;
17use File::Basename ();
18use File::Copy ();
19use File::Find;
20use File::Path ();
21use FileHandle ();
22use Safe ();
23use Text::ParseWords ();
24use Text::Wrap;
25use File::Spec;
26use Sys::Hostname;
27no lib "."; # we need to run chdir all over and we would get at wrong
28 # libraries there
29
30require Mac::BuildTools if $^O eq 'MacOS';
31
32END { $End++; &cleanup; }
33
34%CPAN::DEBUG = qw[
35 CPAN 1
36 Index 2
37 InfoObj 4
38 Author 8
39 Distribution 16
40 Bundle 32
41 Module 64
42 CacheMgr 128
43 Complete 256
44 FTP 512
45 Shell 1024
46 Eval 2048
47 Config 4096
48 Tarzip 8192
49 Version 16384
50 Queue 32768
51];
52
53$CPAN::DEBUG ||= 0;
54$CPAN::Signal ||= 0;
55$CPAN::Frontend ||= "CPAN::Shell";
56$CPAN::Defaultsite ||= "ftp://ftp.perl.org/pub/CPAN";
57
58package CPAN;
59use strict qw(vars);
60
61use vars qw($VERSION @EXPORT $AUTOLOAD $DEBUG $META $HAS_USABLE $term
62 $Revision $Signal $End $Suppress_readline $Frontend
63 $Defaultsite $Have_warned);
64
65@CPAN::ISA = qw(CPAN::Debug Exporter);
66
67@EXPORT = qw(
68 autobundle bundle expand force get cvs_import
69 install make readme recompile shell test clean
70 );
71
72#-> sub CPAN::AUTOLOAD ;
73sub AUTOLOAD {
74 my($l) = $AUTOLOAD;
75 $l =~ s/.*:://;
76 my(%EXPORT);
77 @EXPORT{@EXPORT} = '';
78 CPAN::Config->load unless $CPAN::Config_loaded++;
79 if (exists $EXPORT{$l}){
80 CPAN::Shell->$l(@_);
81 } else {
82 $CPAN::Frontend->mywarn(qq{Unknown command "$AUTOLOAD". }.
83 qq{Type ? for help.
84});
85 }
86}
87
88#-> sub CPAN::shell ;
89sub shell {
90 my($self) = @_;
91 $Suppress_readline = ! -t STDIN unless defined $Suppress_readline;
92 CPAN::Config->load unless $CPAN::Config_loaded++;
93
94 my $oprompt = shift || "cpan> ";
95 my $prompt = $oprompt;
96 my $commandline = shift || "";
97
98 local($^W) = 1;
99 unless ($Suppress_readline) {
100 require Term::ReadLine;
101 if (! $term
102 or
103 $term->ReadLine eq "Term::ReadLine::Stub"
104 ) {
105 $term = Term::ReadLine->new('CPAN Monitor');
106 }
107 if ($term->ReadLine eq "Term::ReadLine::Gnu") {
108 my $attribs = $term->Attribs;
109 $attribs->{attempted_completion_function} = sub {
110 &CPAN::Complete::gnu_cpl;
111 }
112 } else {
113 $readline::rl_completion_function =
114 $readline::rl_completion_function = 'CPAN::Complete::cpl';
115 }
116 if (my $histfile = $CPAN::Config->{'histfile'}) {{
117 unless ($term->can("AddHistory")) {
118 $CPAN::Frontend->mywarn("Terminal does not support AddHistory.\n");
119 last;
120 }
121 my($fh) = FileHandle->new;
122 open $fh, "<$histfile" or last;
123 local $/ = "\n";
124 while (<$fh>) {
125 chomp;
126 $term->AddHistory($_);
127 }
128 close $fh;
129 }}
130 # $term->OUT is autoflushed anyway
131 my $odef = select STDERR;
132 $| = 1;
133 select STDOUT;
134 $| = 1;
135 select $odef;
136 }
137
138 # no strict; # I do not recall why no strict was here (2000-09-03)
139 $META->checklock();
140 my $cwd = CPAN::anycwd();
141 my $try_detect_readline;
142 $try_detect_readline = $term->ReadLine eq "Term::ReadLine::Stub" if $term;
143 my $rl_avail = $Suppress_readline ? "suppressed" :
144 ($term->ReadLine ne "Term::ReadLine::Stub") ? "enabled" :
145 "available (try 'install Bundle::CPAN')";
146
147 $CPAN::Frontend->myprint(
148 sprintf qq{
149cpan shell -- CPAN exploration and modules installation (v%s%s)
150ReadLine support %s
151
152},
153 $CPAN::VERSION,
154 $CPAN::Revision,
155 $rl_avail
156 )
157 unless $CPAN::Config->{'inhibit_startup_message'} ;
158 my($continuation) = "";
159 SHELLCOMMAND: while () {
160 if ($Suppress_readline) {
161 print $prompt;
162 last SHELLCOMMAND unless defined ($_ = <> );
163 chomp;
164 } else {
165 last SHELLCOMMAND unless
166 defined ($_ = $term->readline($prompt, $commandline));
167 }
168 $_ = "$continuation$_" if $continuation;
169 s/^\s+//;
170 next SHELLCOMMAND if /^$/;
171 $_ = 'h' if /^\s*\?/;
172 if (/^(?:q(?:uit)?|bye|exit)$/i) {
173 last SHELLCOMMAND;
174 } elsif (s/\\$//s) {
175 chomp;
176 $continuation = $_;
177 $prompt = " > ";
178 } elsif (/^\!/) {
179 s/^\!//;
180 my($eval) = $_;
181 package CPAN::Eval;
182 use vars qw($import_done);
183 CPAN->import(':DEFAULT') unless $import_done++;
184 CPAN->debug("eval[$eval]") if $CPAN::DEBUG;
185 eval($eval);
186 warn $@ if $@;
187 $continuation = "";
188 $prompt = $oprompt;
189 } elsif (/./) {
190 my(@line);
191 if ($] < 5.00322) { # parsewords had a bug until recently
192 @line = split;
193 } else {
194 eval { @line = Text::ParseWords::shellwords($_) };
195 warn($@), next SHELLCOMMAND if $@;
196 warn("Text::Parsewords could not parse the line [$_]"),
197 next SHELLCOMMAND unless @line;
198 }
199 $CPAN::META->debug("line[".join("|",@line)."]") if $CPAN::DEBUG;
200 my $command = shift @line;
201 eval { CPAN::Shell->$command(@line) };
202 warn $@ if $@;
203 chdir $cwd or $CPAN::Frontend->mydie(qq{Could not chdir to "$cwd": $!});
204 $CPAN::Frontend->myprint("\n");
205 $continuation = "";
206 $prompt = $oprompt;
207 }
208 } continue {
209 $commandline = ""; # I do want to be able to pass a default to
210 # shell, but on the second command I see no
211 # use in that
212 $Signal=0;
213 CPAN::Queue->nullify_queue;
214 if ($try_detect_readline) {
215 if ($CPAN::META->has_inst("Term::ReadLine::Gnu")
216 ||
217 $CPAN::META->has_inst("Term::ReadLine::Perl")
218 ) {
219 delete $INC{"Term/ReadLine.pm"};
220 my $redef = 0;
221 local($SIG{__WARN__}) = CPAN::Shell::paintdots_onreload(\$redef);
222 require Term::ReadLine;
223 $CPAN::Frontend->myprint("\n$redef subroutines in ".
224 "Term::ReadLine redefined\n");
225 @_ = ($oprompt,"");
226 goto &shell;
227 }
228 }
229 }
230 chdir $cwd or $CPAN::Frontend->mydie(qq{Could not chdir to "$cwd": $!});
231}
232
233package CPAN::CacheMgr;
234@CPAN::CacheMgr::ISA = qw(CPAN::InfoObj CPAN);
235use File::Find;
236
237package CPAN::Config;
238use vars qw(%can $dot_cpan);
239
240%can = (
241 'commit' => "Commit changes to disk",
242 'defaults' => "Reload defaults from disk",
243 'init' => "Interactive setting of all options",
244);
245
246package CPAN::FTP;
247use vars qw($Ua $Thesite $Themethod);
248@CPAN::FTP::ISA = qw(CPAN::Debug);
249
250package CPAN::LWP::UserAgent;
251use vars qw(@ISA $USER $PASSWD $SETUPDONE);
252# we delay requiring LWP::UserAgent and setting up inheritence until we need it
253
254package CPAN::Complete;
255@CPAN::Complete::ISA = qw(CPAN::Debug);
256@CPAN::Complete::COMMANDS = sort qw(
257 ! a b d h i m o q r u autobundle clean dump
258 make test install force readme reload look
259 cvs_import ls
260) unless @CPAN::Complete::COMMANDS;
261
262package CPAN::Index;
263use vars qw($LAST_TIME $DATE_OF_02 $DATE_OF_03);
264@CPAN::Index::ISA = qw(CPAN::Debug);
265$LAST_TIME ||= 0;
266$DATE_OF_03 ||= 0;
267# use constant PROTOCOL => "2.0"; # outcommented to avoid warning on upgrade from 1.57
268sub PROTOCOL { 2.0 }
269
270package CPAN::InfoObj;
271@CPAN::InfoObj::ISA = qw(CPAN::Debug);
272
273package CPAN::Author;
274@CPAN::Author::ISA = qw(CPAN::InfoObj);
275
276package CPAN::Distribution;
277@CPAN::Distribution::ISA = qw(CPAN::InfoObj);
278
279package CPAN::Bundle;
280@CPAN::Bundle::ISA = qw(CPAN::Module);
281
282package CPAN::Module;
283@CPAN::Module::ISA = qw(CPAN::InfoObj);
284
285package CPAN::Exception::RecursiveDependency;
286use overload '""' => "as_string";
287
288sub new {
289 my($class) = shift;
290 my($deps) = shift;
291 my @deps;
292 my %seen;
293 for my $dep (@$deps) {
294 push @deps, $dep;
295 last if $seen{$dep}++;
296 }
297 bless { deps => \@deps }, $class;
298}
299
300sub as_string {
301 my($self) = shift;
302 "\nRecursive dependency detected:\n " .
303 join("\n => ", @{$self->{deps}}) .
304 ".\nCannot continue.\n";
305}
306
307package CPAN::Shell;
308use vars qw($AUTOLOAD @ISA $COLOR_REGISTERED $ADVANCED_QUERY $PRINT_ORNAMENTING);
309@CPAN::Shell::ISA = qw(CPAN::Debug);
310$COLOR_REGISTERED ||= 0;
311$PRINT_ORNAMENTING ||= 0;
312
313#-> sub CPAN::Shell::AUTOLOAD ;
314sub AUTOLOAD {
315 my($autoload) = $AUTOLOAD;
316 my $class = shift(@_);
317 # warn "autoload[$autoload] class[$class]";
318 $autoload =~ s/.*:://;
319 if ($autoload =~ /^w/) {
320 if ($CPAN::META->has_inst('CPAN::WAIT')) {
321 CPAN::WAIT->$autoload(@_);
322 } else {
323 $CPAN::Frontend->mywarn(qq{
324Commands starting with "w" require CPAN::WAIT to be installed.
325Please consider installing CPAN::WAIT to use the fulltext index.
326For this you just need to type
327 install CPAN::WAIT
328});
329 }
330 } else {
331 $CPAN::Frontend->mywarn(qq{Unknown command '$autoload'. }.
332 qq{Type ? for help.
333});
334 }
335}
336
337package CPAN::Tarzip;
338use vars qw($AUTOLOAD @ISA $BUGHUNTING);
339@CPAN::Tarzip::ISA = qw(CPAN::Debug);
340$BUGHUNTING = 0; # released code must have turned off
341
342package CPAN::Queue;
343
344# One use of the queue is to determine if we should or shouldn't
345# announce the availability of a new CPAN module
346
347# Now we try to use it for dependency tracking. For that to happen
348# we need to draw a dependency tree and do the leaves first. This can
349# easily be reached by running CPAN.pm recursively, but we don't want
350# to waste memory and run into deep recursion. So what we can do is
351# this:
352
353# CPAN::Queue is the package where the queue is maintained. Dependencies
354# often have high priority and must be brought to the head of the queue,
355# possibly by jumping the queue if they are already there. My first code
356# attempt tried to be extremely correct. Whenever a module needed
357# immediate treatment, I either unshifted it to the front of the queue,
358# or, if it was already in the queue, I spliced and let it bypass the
359# others. This became a too correct model that made it impossible to put
360# an item more than once into the queue. Why would you need that? Well,
361# you need temporary duplicates as the manager of the queue is a loop
362# that
363#
364# (1) looks at the first item in the queue without shifting it off
365#
366# (2) cares for the item
367#
368# (3) removes the item from the queue, *even if its agenda failed and
369# even if the item isn't the first in the queue anymore* (that way
370# protecting against never ending queues)
371#
372# So if an item has prerequisites, the installation fails now, but we
373# want to retry later. That's easy if we have it twice in the queue.
374#
375# I also expect insane dependency situations where an item gets more
376# than two lives in the queue. Simplest example is triggered by 'install
377# Foo Foo Foo'. People make this kind of mistakes and I don't want to
378# get in the way. I wanted the queue manager to be a dumb servant, not
379# one that knows everything.
380#
381# Who would I tell in this model that the user wants to be asked before
382# processing? I can't attach that information to the module object,
383# because not modules are installed but distributions. So I'd have to
384# tell the distribution object that it should ask the user before
385# processing. Where would the question be triggered then? Most probably
386# in CPAN::Distribution::rematein.
387# Hope that makes sense, my head is a bit off:-) -- AK
388
389use vars qw{ @All };
390
391# CPAN::Queue::new ;
392sub new {
393 my($class,$s) = @_;
394 my $self = bless { qmod => $s }, $class;
395 push @All, $self;
396 return $self;
397}
398
399# CPAN::Queue::first ;
400sub first {
401 my $obj = $All[0];
402 $obj->{qmod};
403}
404
405# CPAN::Queue::delete_first ;
406sub delete_first {
407 my($class,$what) = @_;
408 my $i;
409 for my $i (0..$#All) {
410 if ( $All[$i]->{qmod} eq $what ) {
411 splice @All, $i, 1;
412 return;
413 }
414 }
415}
416
417# CPAN::Queue::jumpqueue ;
418sub jumpqueue {
419 my $class = shift;
420 my @what = @_;
421 CPAN->debug(sprintf("before jumpqueue All[%s] what[%s]",
422 join(",",map {$_->{qmod}} @All),
423 join(",",@what)
424 )) if $CPAN::DEBUG;
425 WHAT: for my $what (reverse @what) {
426 my $jumped = 0;
427 for (my $i=0; $i<$#All;$i++) { #prevent deep recursion
428 CPAN->debug("i[$All[$i]]what[$what]") if $CPAN::DEBUG;
429 if ($All[$i]->{qmod} eq $what){
430 $jumped++;
431 if ($jumped > 100) { # one's OK if e.g. just
432 # processing now; more are OK if
433 # user typed it several times
434 $CPAN::Frontend->mywarn(
435qq{Object [$what] queued more than 100 times, ignoring}
436 );
437 next WHAT;
438 }
439 }
440 }
441 my $obj = bless { qmod => $what }, $class;
442 unshift @All, $obj;
443 }
444 CPAN->debug(sprintf("after jumpqueue All[%s] what[%s]",
445 join(",",map {$_->{qmod}} @All),
446 join(",",@what)
447 )) if $CPAN::DEBUG;
448}
449
450# CPAN::Queue::exists ;
451sub exists {
452 my($self,$what) = @_;
453 my @all = map { $_->{qmod} } @All;
454 my $exists = grep { $_->{qmod} eq $what } @All;
455 # warn "in exists what[$what] all[@all] exists[$exists]";
456 $exists;
457}
458
459# CPAN::Queue::delete ;
460sub delete {
461 my($self,$mod) = @_;
462 @All = grep { $_->{qmod} ne $mod } @All;
463}
464
465# CPAN::Queue::nullify_queue ;
466sub nullify_queue {
467 @All = ();
468}
469
470
471
472package CPAN;
473
474$META ||= CPAN->new; # In case we re-eval ourselves we need the ||
475
476# from here on only subs.
477################################################################################
478
479#-> sub CPAN::all_objects ;
480sub all_objects {
481 my($mgr,$class) = @_;
482 CPAN::Config->load unless $CPAN::Config_loaded++;
483 CPAN->debug("mgr[$mgr] class[$class]") if $CPAN::DEBUG;
484 CPAN::Index->reload;
485 values %{ $META->{readwrite}{$class} }; # unsafe meta access, ok
486}
487*all = \&all_objects;
488
489# Called by shell, not in batch mode. In batch mode I see no risk in
490# having many processes updating something as installations are
491# continually checked at runtime. In shell mode I suspect it is
492# unintentional to open more than one shell at a time
493
494#-> sub CPAN::checklock ;
495sub checklock {
496 my($self) = @_;
497 my $lockfile = File::Spec->catfile($CPAN::Config->{cpan_home},".lock");
498 if (-f $lockfile && -M _ > 0) {
499 my $fh = FileHandle->new($lockfile) or
500 $CPAN::Frontend->mydie("Could not open $lockfile: $!");
501 my $otherpid = <$fh>;
502 my $otherhost = <$fh>;
503 $fh->close;
504 if (defined $otherpid && $otherpid) {
505 chomp $otherpid;
506 }
507 if (defined $otherhost && $otherhost) {
508 chomp $otherhost;
509 }
510 my $thishost = hostname();
511 if (defined $otherhost && defined $thishost &&
512 $otherhost ne '' && $thishost ne '' &&
513 $otherhost ne $thishost) {
514 $CPAN::Frontend->mydie(sprintf("CPAN.pm panic: Lockfile $lockfile\n".
515 "reports other host $otherhost and other process $otherpid.\n".
516 "Cannot proceed.\n"));
517 }
518 elsif (defined $otherpid && $otherpid) {
519 return if $$ == $otherpid; # should never happen
520 $CPAN::Frontend->mywarn(
521 qq{
522There seems to be running another CPAN process (pid $otherpid). Contacting...
523});
524 if (kill 0, $otherpid) {
525 $CPAN::Frontend->mydie(qq{Other job is running.
526You may want to kill it and delete the lockfile, maybe. On UNIX try:
527 kill $otherpid
528 rm $lockfile
529});
530 } elsif (-w $lockfile) {
531 my($ans) =
532 ExtUtils::MakeMaker::prompt
533 (qq{Other job not responding. Shall I overwrite }.
534 qq{the lockfile? (Y/N)},"y");
535 $CPAN::Frontend->myexit("Ok, bye\n")
536 unless $ans =~ /^y/i;
537 } else {
538 Carp::croak(
539 qq{Lockfile $lockfile not writeable by you. }.
540 qq{Cannot proceed.\n}.
541 qq{ On UNIX try:\n}.
542 qq{ rm $lockfile\n}.
543 qq{ and then rerun us.\n}
544 );
545 }
546 } else {
547 $CPAN::Frontend->mydie(sprintf("CPAN.pm panic: Lockfile $lockfile\n".
548 "reports other process with ID ".
549 "$otherpid. Cannot proceed.\n"));
550 }
551 }
552 my $dotcpan = $CPAN::Config->{cpan_home};
553 eval { File::Path::mkpath($dotcpan);};
554 if ($@) {
555 # A special case at least for Jarkko.
556 my $firsterror = $@;
557 my $seconderror;
558 my $symlinkcpan;
559 if (-l $dotcpan) {
560 $symlinkcpan = readlink $dotcpan;
561 die "readlink $dotcpan failed: $!" unless defined $symlinkcpan;
562 eval { File::Path::mkpath($symlinkcpan); };
563 if ($@) {
564 $seconderror = $@;
565 } else {
566 $CPAN::Frontend->mywarn(qq{
567Working directory $symlinkcpan created.
568});
569 }
570 }
571 unless (-d $dotcpan) {
572 my $diemess = qq{
573Your configuration suggests "$dotcpan" as your
574CPAN.pm working directory. I could not create this directory due
575to this error: $firsterror\n};
576 $diemess .= qq{
577As "$dotcpan" is a symlink to "$symlinkcpan",
578I tried to create that, but I failed with this error: $seconderror
579} if $seconderror;
580 $diemess .= qq{
581Please make sure the directory exists and is writable.
582};
583 $CPAN::Frontend->mydie($diemess);
584 }
585 }
586 my $fh;
587 unless ($fh = FileHandle->new(">$lockfile")) {
588 if ($! =~ /Permission/) {
589 my $incc = $INC{'CPAN/Config.pm'};
590 my $myincc = File::Spec->catfile($ENV{HOME},'.cpan','CPAN','MyConfig.pm');
591 $CPAN::Frontend->myprint(qq{
592
593Your configuration suggests that CPAN.pm should use a working
594directory of
595 $CPAN::Config->{cpan_home}
596Unfortunately we could not create the lock file
597 $lockfile
598due to permission problems.
599
600Please make sure that the configuration variable
601 \$CPAN::Config->{cpan_home}
602points to a directory where you can write a .lock file. You can set
603this variable in either
604 $incc
605or
606 $myincc
607
608});
609 }
610 $CPAN::Frontend->mydie("Could not open >$lockfile: $!");
611 }
612 $fh->print($$, "\n");
613 $fh->print(hostname(), "\n");
614 $self->{LOCK} = $lockfile;
615 $fh->close;
616 $SIG{TERM} = sub {
617 &cleanup;
618 $CPAN::Frontend->mydie("Got SIGTERM, leaving");
619 };
620 $SIG{INT} = sub {
621 # no blocks!!!
622 &cleanup if $Signal;
623 $CPAN::Frontend->mydie("Got another SIGINT") if $Signal;
624 print "Caught SIGINT\n";
625 $Signal++;
626 };
627
628# From: Larry Wall <[email protected]>
629# Subject: Re: deprecating SIGDIE
630# To: [email protected]
631# Date: Thu, 30 Sep 1999 14:58:40 -0700 (PDT)
632#
633# The original intent of __DIE__ was only to allow you to substitute one
634# kind of death for another on an application-wide basis without respect
635# to whether you were in an eval or not. As a global backstop, it should
636# not be used any more lightly (or any more heavily :-) than class
637# UNIVERSAL. Any attempt to build a general exception model on it should
638# be politely squashed. Any bug that causes every eval {} to have to be
639# modified should be not so politely squashed.
640#
641# Those are my current opinions. It is also my optinion that polite
642# arguments degenerate to personal arguments far too frequently, and that
643# when they do, it's because both people wanted it to, or at least didn't
644# sufficiently want it not to.
645#
646# Larry
647
648 # global backstop to cleanup if we should really die
649 $SIG{__DIE__} = \&cleanup;
650 $self->debug("Signal handler set.") if $CPAN::DEBUG;
651}
652
653#-> sub CPAN::DESTROY ;
654sub DESTROY {
655 &cleanup; # need an eval?
656}
657
658#-> sub CPAN::anycwd ;
659sub anycwd () {
660 my $getcwd;
661 $getcwd = $CPAN::Config->{'getcwd'} || 'cwd';
662 CPAN->$getcwd();
663}
664
665#-> sub CPAN::cwd ;
666sub cwd {Cwd::cwd();}
667
668#-> sub CPAN::getcwd ;
669sub getcwd {Cwd::getcwd();}
670
671#-> sub CPAN::exists ;
672sub exists {
673 my($mgr,$class,$id) = @_;
674 CPAN::Config->load unless $CPAN::Config_loaded++;
675 CPAN::Index->reload;
676 ### Carp::croak "exists called without class argument" unless $class;
677 $id ||= "";
678 exists $META->{readonly}{$class}{$id} or
679 exists $META->{readwrite}{$class}{$id}; # unsafe meta access, ok
680}
681
682#-> sub CPAN::delete ;
683sub delete {
684 my($mgr,$class,$id) = @_;
685 delete $META->{readonly}{$class}{$id}; # unsafe meta access, ok
686 delete $META->{readwrite}{$class}{$id}; # unsafe meta access, ok
687}
688
689#-> sub CPAN::has_usable
690# has_inst is sometimes too optimistic, we should replace it with this
691# has_usable whenever a case is given
692sub has_usable {
693 my($self,$mod,$message) = @_;
694 return 1 if $HAS_USABLE->{$mod};
695 my $has_inst = $self->has_inst($mod,$message);
696 return unless $has_inst;
697 my $usable;
698 $usable = {
699 LWP => [ # we frequently had "Can't locate object
700 # method "new" via package "LWP::UserAgent" at
701 # (eval 69) line 2006
702 sub {require LWP},
703 sub {require LWP::UserAgent},
704 sub {require HTTP::Request},
705 sub {require URI::URL},
706 ],
707 Net::FTP => [
708 sub {require Net::FTP},
709 sub {require Net::Config},
710 ]
711 };
712 if ($usable->{$mod}) {
713 for my $c (0..$#{$usable->{$mod}}) {
714 my $code = $usable->{$mod}[$c];
715 my $ret = eval { &$code() };
716 if ($@) {
717 warn "DEBUG: c[$c]\$\@[$@]ret[$ret]";
718 return;
719 }
720 }
721 }
722 return $HAS_USABLE->{$mod} = 1;
723}
724
725#-> sub CPAN::has_inst
726sub has_inst {
727 my($self,$mod,$message) = @_;
728 Carp::croak("CPAN->has_inst() called without an argument")
729 unless defined $mod;
730 if (defined $message && $message eq "no"
731 ||
732 exists $CPAN::META->{dontload_hash}{$mod} # unsafe meta access, ok
733 ||
734 exists $CPAN::Config->{dontload_hash}{$mod}
735 ) {
736 $CPAN::META->{dontload_hash}{$mod}||=1; # unsafe meta access, ok
737 return 0;
738 }
739 my $file = $mod;
740 my $obj;
741 $file =~ s|::|/|g;
742 $file .= ".pm";
743 if ($INC{$file}) {
744 # checking %INC is wrong, because $INC{LWP} may be true
745 # although $INC{"URI/URL.pm"} may have failed. But as
746 # I really want to say "bla loaded OK", I have to somehow
747 # cache results.
748 ### warn "$file in %INC"; #debug
749 return 1;
750 } elsif (eval { require $file }) {
751 # eval is good: if we haven't yet read the database it's
752 # perfect and if we have installed the module in the meantime,
753 # it tries again. The second require is only a NOOP returning
754 # 1 if we had success, otherwise it's retrying
755
756 $CPAN::Frontend->myprint("CPAN: $mod loaded ok\n");
757 if ($mod eq "CPAN::WAIT") {
758 push @CPAN::Shell::ISA, CPAN::WAIT;
759 }
760 return 1;
761 } elsif ($mod eq "Net::FTP") {
762 $CPAN::Frontend->mywarn(qq{
763 Please, install Net::FTP as soon as possible. CPAN.pm installs it for you
764 if you just type
765 install Bundle::libnet
766
767}) unless $Have_warned->{"Net::FTP"}++;
768 sleep 3;
769 } elsif ($mod eq "Digest::MD5"){
770 $CPAN::Frontend->myprint(qq{
771 CPAN: MD5 security checks disabled because Digest::MD5 not installed.
772 Please consider installing the Digest::MD5 module.
773
774});
775 sleep 2;
776 } else {
777 delete $INC{$file}; # if it inc'd LWP but failed during, say, URI
778 }
779 return 0;
780}
781
782#-> sub CPAN::instance ;
783sub instance {
784 my($mgr,$class,$id) = @_;
785 CPAN::Index->reload;
786 $id ||= "";
787 # unsafe meta access, ok?
788 return $META->{readwrite}{$class}{$id} if exists $META->{readwrite}{$class}{$id};
789 $META->{readwrite}{$class}{$id} ||= $class->new(ID => $id);
790}
791
792#-> sub CPAN::new ;
793sub new {
794 bless {}, shift;
795}
796
797#-> sub CPAN::cleanup ;
798sub cleanup {
799 # warn "cleanup called with arg[@_] End[$End] Signal[$Signal]";
800 local $SIG{__DIE__} = '';
801 my($message) = @_;
802 my $i = 0;
803 my $ineval = 0;
804 my($subroutine);
805 while ((undef,undef,undef,$subroutine) = caller(++$i)) {
806 $ineval = 1, last if
807 $subroutine eq '(eval)';
808 }
809 return if $ineval && !$End;
810 return unless defined $META->{LOCK};
811 return unless -f $META->{LOCK};
812 $META->savehist;
813 unlink $META->{LOCK};
814 # require Carp;
815 # Carp::cluck("DEBUGGING");
816 $CPAN::Frontend->mywarn("Lockfile removed.\n");
817}
818
819#-> sub CPAN::savehist
820sub savehist {
821 my($self) = @_;
822 my($histfile,$histsize);
823 unless ($histfile = $CPAN::Config->{'histfile'}){
824 $CPAN::Frontend->mywarn("No history written (no histfile specified).\n");
825 return;
826 }
827 $histsize = $CPAN::Config->{'histsize'} || 100;
828 if ($CPAN::term){
829 unless ($CPAN::term->can("GetHistory")) {
830 $CPAN::Frontend->mywarn("Terminal does not support GetHistory.\n");
831 return;
832 }
833 } else {
834 return;
835 }
836 my @h = $CPAN::term->GetHistory;
837 splice @h, 0, @h-$histsize if @h>$histsize;
838 my($fh) = FileHandle->new;
839 open $fh, ">$histfile" or $CPAN::Frontend->mydie("Couldn't open >$histfile: $!");
840 local $\ = local $, = "\n";
841 print $fh @h;
842 close $fh;
843}
844
845sub is_tested {
846 my($self,$what) = @_;
847 $self->{is_tested}{$what} = 1;
848}
849
850sub is_installed {
851 my($self,$what) = @_;
852 delete $self->{is_tested}{$what};
853}
854
855sub set_perl5lib {
856 my($self) = @_;
857 $self->{is_tested} ||= {};
858 return unless %{$self->{is_tested}};
859 my $env = $ENV{PERL5LIB};
860 $env = $ENV{PERLLIB} unless defined $env;
861 my @env;
862 push @env, $env if defined $env and length $env;
863 my @dirs = map {("$_/blib/arch", "$_/blib/lib")} keys %{$self->{is_tested}};
864 $CPAN::Frontend->myprint("Prepending @dirs to PERL5LIB.\n");
865 $ENV{PERL5LIB} = join $Config::Config{path_sep}, @dirs, @env;
866}
867
868package CPAN::CacheMgr;
869
870#-> sub CPAN::CacheMgr::as_string ;
871sub as_string {
872 eval { require Data::Dumper };
873 if ($@) {
874 return shift->SUPER::as_string;
875 } else {
876 return Data::Dumper::Dumper(shift);
877 }
878}
879
880#-> sub CPAN::CacheMgr::cachesize ;
881sub cachesize {
882 shift->{DU};
883}
884
885#-> sub CPAN::CacheMgr::tidyup ;
886sub tidyup {
887 my($self) = @_;
888 return unless -d $self->{ID};
889 while ($self->{DU} > $self->{'MAX'} ) {
890 my($toremove) = shift @{$self->{FIFO}};
891 $CPAN::Frontend->myprint(sprintf(
892 "Deleting from cache".
893 ": $toremove (%.1f>%.1f MB)\n",
894 $self->{DU}, $self->{'MAX'})
895 );
896 return if $CPAN::Signal;
897 $self->force_clean_cache($toremove);
898 return if $CPAN::Signal;
899 }
900}
901
902#-> sub CPAN::CacheMgr::dir ;
903sub dir {
904 shift->{ID};
905}
906
907#-> sub CPAN::CacheMgr::entries ;
908sub entries {
909 my($self,$dir) = @_;
910 return unless defined $dir;
911 $self->debug("reading dir[$dir]") if $CPAN::DEBUG;
912 $dir ||= $self->{ID};
913 my($cwd) = CPAN::anycwd();
914 chdir $dir or Carp::croak("Can't chdir to $dir: $!");
915 my $dh = DirHandle->new(File::Spec->curdir)
916 or Carp::croak("Couldn't opendir $dir: $!");
917 my(@entries);
918 for ($dh->read) {
919 next if $_ eq "." || $_ eq "..";
920 if (-f $_) {
921 push @entries, File::Spec->catfile($dir,$_);
922 } elsif (-d _) {
923 push @entries, File::Spec->catdir($dir,$_);
924 } else {
925 $CPAN::Frontend->mywarn("Warning: weird direntry in $dir: $_\n");
926 }
927 }
928 chdir $cwd or Carp::croak("Can't chdir to $cwd: $!");
929 sort { -M $b <=> -M $a} @entries;
930}
931
932#-> sub CPAN::CacheMgr::disk_usage ;
933sub disk_usage {
934 my($self,$dir) = @_;
935 return if exists $self->{SIZE}{$dir};
936 return if $CPAN::Signal;
937 my($Du) = 0;
938 find(
939 sub {
940 $File::Find::prune++ if $CPAN::Signal;
941 return if -l $_;
942 if ($^O eq 'MacOS') {
943 require Mac::Files;
944 my $cat = Mac::Files::FSpGetCatInfo($_);
945 $Du += $cat->ioFlLgLen() + $cat->ioFlRLgLen() if $cat;
946 } else {
947 $Du += (-s _);
948 }
949 },
950 $dir
951 );
952 return if $CPAN::Signal;
953 $self->{SIZE}{$dir} = $Du/1024/1024;
954 push @{$self->{FIFO}}, $dir;
955 $self->debug("measured $dir is $Du") if $CPAN::DEBUG;
956 $self->{DU} += $Du/1024/1024;
957 $self->{DU};
958}
959
960#-> sub CPAN::CacheMgr::force_clean_cache ;
961sub force_clean_cache {
962 my($self,$dir) = @_;
963 return unless -e $dir;
964 $self->debug("have to rmtree $dir, will free $self->{SIZE}{$dir}")
965 if $CPAN::DEBUG;
966 File::Path::rmtree($dir);
967 $self->{DU} -= $self->{SIZE}{$dir};
968 delete $self->{SIZE}{$dir};
969}
970
971#-> sub CPAN::CacheMgr::new ;
972sub new {
973 my $class = shift;
974 my $time = time;
975 my($debug,$t2);
976 $debug = "";
977 my $self = {
978 ID => $CPAN::Config->{'build_dir'},
979 MAX => $CPAN::Config->{'build_cache'},
980 SCAN => $CPAN::Config->{'scan_cache'} || 'atstart',
981 DU => 0
982 };
983 File::Path::mkpath($self->{ID});
984 my $dh = DirHandle->new($self->{ID});
985 bless $self, $class;
986 $self->scan_cache;
987 $t2 = time;
988 $debug .= "timing of CacheMgr->new: ".($t2 - $time);
989 $time = $t2;
990 CPAN->debug($debug) if $CPAN::DEBUG;
991 $self;
992}
993
994#-> sub CPAN::CacheMgr::scan_cache ;
995sub scan_cache {
996 my $self = shift;
997 return if $self->{SCAN} eq 'never';
998 $CPAN::Frontend->mydie("Unknown scan_cache argument: $self->{SCAN}")
999 unless $self->{SCAN} eq 'atstart';
1000 $CPAN::Frontend->myprint(
1001 sprintf("Scanning cache %s for sizes\n",
1002 $self->{ID}));
1003 my $e;
1004 for $e ($self->entries($self->{ID})) {
1005 next if $e eq ".." || $e eq ".";
1006 $self->disk_usage($e);
1007 return if $CPAN::Signal;
1008 }
1009 $self->tidyup;
1010}
1011
1012package CPAN::Debug;
1013
1014#-> sub CPAN::Debug::debug ;
1015sub debug {
1016 my($self,$arg) = @_;
1017 my($caller,$func,$line,@rest) = caller(1); # caller(0) eg
1018 # Complete, caller(1)
1019 # eg readline
1020 ($caller) = caller(0);
1021 $caller =~ s/.*:://;
1022 $arg = "" unless defined $arg;
1023 my $rest = join "|", map { defined $_ ? $_ : "UNDEF" } @rest;
1024 if ($CPAN::DEBUG{$caller} & $CPAN::DEBUG){
1025 if ($arg and ref $arg) {
1026 eval { require Data::Dumper };
1027 if ($@) {
1028 $CPAN::Frontend->myprint($arg->as_string);
1029 } else {
1030 $CPAN::Frontend->myprint(Data::Dumper::Dumper($arg));
1031 }
1032 } else {
1033 $CPAN::Frontend->myprint("Debug($caller:$func,$line,[$rest]): $arg\n");
1034 }
1035 }
1036}
1037
1038package CPAN::Config;
1039
1040#-> sub CPAN::Config::edit ;
1041# returns true on successful action
1042sub edit {
1043 my($self,@args) = @_;
1044 return unless @args;
1045 CPAN->debug("self[$self]args[".join(" | ",@args)."]");
1046 my($o,$str,$func,$args,$key_exists);
1047 $o = shift @args;
1048 if($can{$o}) {
1049 $self->$o(@args);
1050 return 1;
1051 } else {
1052 CPAN->debug("o[$o]") if $CPAN::DEBUG;
1053 if ($o =~ /list$/) {
1054 $func = shift @args;
1055 $func ||= "";
1056 CPAN->debug("func[$func]") if $CPAN::DEBUG;
1057 my $changed;
1058 # Let's avoid eval, it's easier to comprehend without.
1059 if ($func eq "push") {
1060 push @{$CPAN::Config->{$o}}, @args;
1061 $changed = 1;
1062 } elsif ($func eq "pop") {
1063 pop @{$CPAN::Config->{$o}};
1064 $changed = 1;
1065 } elsif ($func eq "shift") {
1066 shift @{$CPAN::Config->{$o}};
1067 $changed = 1;
1068 } elsif ($func eq "unshift") {
1069 unshift @{$CPAN::Config->{$o}}, @args;
1070 $changed = 1;
1071 } elsif ($func eq "splice") {
1072 splice @{$CPAN::Config->{$o}}, @args;
1073 $changed = 1;
1074 } elsif (@args) {
1075 $CPAN::Config->{$o} = [@args];
1076 $changed = 1;
1077 } else {
1078 $self->prettyprint($o);
1079 }
1080 if ($o eq "urllist" && $changed) {
1081 # reset the cached values
1082 undef $CPAN::FTP::Thesite;
1083 undef $CPAN::FTP::Themethod;
1084 }
1085 return $changed;
1086 } else {
1087 $CPAN::Config->{$o} = $args[0] if defined $args[0];
1088 $self->prettyprint($o);
1089 }
1090 }
1091}
1092
1093sub prettyprint {
1094 my($self,$k) = @_;
1095 my $v = $CPAN::Config->{$k};
1096 if (ref $v) {
1097 my(@report) = ref $v eq "ARRAY" ?
1098 @$v :
1099 map { sprintf(" %-18s => %s\n",
1100 $_,
1101 defined $v->{$_} ? $v->{$_} : "UNDEFINED"
1102 )} keys %$v;
1103 $CPAN::Frontend->myprint(
1104 join(
1105 "",
1106 sprintf(
1107 " %-18s\n",
1108 $k
1109 ),
1110 map {"\t$_\n"} @report
1111 )
1112 );
1113 } elsif (defined $v) {
1114 $CPAN::Frontend->myprint(sprintf " %-18s %s\n", $k, $v);
1115 } else {
1116 $CPAN::Frontend->myprint(sprintf " %-18s %s\n", $k, "UNDEFINED");
1117 }
1118}
1119
1120#-> sub CPAN::Config::commit ;
1121sub commit {
1122 my($self,$configpm) = @_;
1123 unless (defined $configpm){
1124 $configpm ||= $INC{"CPAN/MyConfig.pm"};
1125 $configpm ||= $INC{"CPAN/Config.pm"};
1126 $configpm || Carp::confess(q{
1127CPAN::Config::commit called without an argument.
1128Please specify a filename where to save the configuration or try
1129"o conf init" to have an interactive course through configing.
1130});
1131 }
1132 my($mode);
1133 if (-f $configpm) {
1134 $mode = (stat $configpm)[2];
1135 if ($mode && ! -w _) {
1136 Carp::confess("$configpm is not writable");
1137 }
1138 }
1139
1140 my $msg;
1141 $msg = <<EOF unless $configpm =~ /MyConfig/;
1142
1143# This is CPAN.pm's systemwide configuration file. This file provides
1144# defaults for users, and the values can be changed in a per-user
1145# configuration file. The user-config file is being looked for as
1146# ~/.cpan/CPAN/MyConfig.pm.
1147
1148EOF
1149 $msg ||= "\n";
1150 my($fh) = FileHandle->new;
1151 rename $configpm, "$configpm~" if -f $configpm;
1152 open $fh, ">$configpm" or
1153 $CPAN::Frontend->mydie("Couldn't open >$configpm: $!");
1154 $fh->print(qq[$msg\$CPAN::Config = \{\n]);
1155 foreach (sort keys %$CPAN::Config) {
1156 $fh->print(
1157 " '$_' => ",
1158 ExtUtils::MakeMaker::neatvalue($CPAN::Config->{$_}),
1159 ",\n"
1160 );
1161 }
1162
1163 $fh->print("};\n1;\n__END__\n");
1164 close $fh;
1165
1166 #$mode = 0444 | ( $mode & 0111 ? 0111 : 0 );
1167 #chmod $mode, $configpm;
1168###why was that so? $self->defaults;
1169 $CPAN::Frontend->myprint("commit: wrote $configpm\n");
1170 1;
1171}
1172
1173*default = \&defaults;
1174#-> sub CPAN::Config::defaults ;
1175sub defaults {
1176 my($self) = @_;
1177 $self->unload;
1178 $self->load;
1179 1;
1180}
1181
1182sub init {
1183 my($self) = @_;
1184 undef $CPAN::Config->{'inhibit_startup_message'}; # lazy trick to
1185 # have the least
1186 # important
1187 # variable
1188 # undefined
1189 $self->load;
1190 1;
1191}
1192
1193# This is a piece of repeated code that is abstracted here for
1194# maintainability. RMB
1195#
1196sub _configpmtest {
1197 my($configpmdir, $configpmtest) = @_;
1198 if (-w $configpmtest) {
1199 return $configpmtest;
1200 } elsif (-w $configpmdir) {
1201 #_#_# following code dumped core on me with 5.003_11, a.k.
1202 my $configpm_bak = "$configpmtest.bak";
1203 unlink $configpm_bak if -f $configpm_bak;
1204 if( -f $configpmtest ) {
1205 if( rename $configpmtest, $configpm_bak ) {
1206 $CPAN::Frontend->mywarn(<<END)
1207Old configuration file $configpmtest
1208 moved to $configpm_bak
1209END
1210 }
1211 }
1212 my $fh = FileHandle->new;
1213 if ($fh->open(">$configpmtest")) {
1214 $fh->print("1;\n");
1215 return $configpmtest;
1216 } else {
1217 # Should never happen
1218 Carp::confess("Cannot open >$configpmtest");
1219 }
1220 } else { return }
1221}
1222
1223#-> sub CPAN::Config::load ;
1224sub load {
1225 my($self) = shift;
1226 my(@miss);
1227 use Carp;
1228 eval {require CPAN::Config;}; # We eval because of some
1229 # MakeMaker problems
1230 unless ($dot_cpan++){
1231 unshift @INC, File::Spec->catdir($ENV{HOME},".cpan");
1232 eval {require CPAN::MyConfig;}; # where you can override
1233 # system wide settings
1234 shift @INC;
1235 }
1236 return unless @miss = $self->missing_config_data;
1237
1238 require CPAN::FirstTime;
1239 my($configpm,$fh,$redo,$theycalled);
1240 $redo ||= "";
1241 $theycalled++ if @miss==1 && $miss[0] eq 'inhibit_startup_message';
1242 if (defined $INC{"CPAN/Config.pm"} && -w $INC{"CPAN/Config.pm"}) {
1243 $configpm = $INC{"CPAN/Config.pm"};
1244 $redo++;
1245 } elsif (defined $INC{"CPAN/MyConfig.pm"} && -w $INC{"CPAN/MyConfig.pm"}) {
1246 $configpm = $INC{"CPAN/MyConfig.pm"};
1247 $redo++;
1248 } else {
1249 my($path_to_cpan) = File::Basename::dirname($INC{"CPAN.pm"});
1250 my($configpmdir) = File::Spec->catdir($path_to_cpan,"CPAN");
1251 my($configpmtest) = File::Spec->catfile($configpmdir,"Config.pm");
1252 if (-d $configpmdir or File::Path::mkpath($configpmdir)) {
1253 $configpm = _configpmtest($configpmdir,$configpmtest);
1254 }
1255 unless ($configpm) {
1256 $configpmdir = File::Spec->catdir($ENV{HOME},".cpan","CPAN");
1257 File::Path::mkpath($configpmdir);
1258 $configpmtest = File::Spec->catfile($configpmdir,"MyConfig.pm");
1259 $configpm = _configpmtest($configpmdir,$configpmtest);
1260 unless ($configpm) {
1261 Carp::confess(qq{WARNING: CPAN.pm is unable to }.
1262 qq{create a configuration file.});
1263 }
1264 }
1265 }
1266 local($") = ", ";
1267 $CPAN::Frontend->myprint(<<END) if $redo && ! $theycalled;
1268We have to reconfigure CPAN.pm due to following uninitialized parameters:
1269
1270@miss
1271END
1272 $CPAN::Frontend->myprint(qq{
1273$configpm initialized.
1274});
1275 sleep 2;
1276 CPAN::FirstTime::init($configpm);
1277}
1278
1279#-> sub CPAN::Config::missing_config_data ;
1280sub missing_config_data {
1281 my(@miss);
1282 for (
1283 "cpan_home", "keep_source_where", "build_dir", "build_cache",
1284 "scan_cache", "index_expire", "gzip", "tar", "unzip", "make",
1285 "pager",
1286 "makepl_arg", "make_arg", "make_install_arg", "urllist",
1287 "inhibit_startup_message", "ftp_proxy", "http_proxy", "no_proxy",
1288 "prerequisites_policy",
1289 "cache_metadata",
1290 ) {
1291 push @miss, $_ unless defined $CPAN::Config->{$_};
1292 }
1293 return @miss;
1294}
1295
1296#-> sub CPAN::Config::unload ;
1297sub unload {
1298 delete $INC{'CPAN/MyConfig.pm'};
1299 delete $INC{'CPAN/Config.pm'};
1300}
1301
1302#-> sub CPAN::Config::help ;
1303sub help {
1304 $CPAN::Frontend->myprint(q[
1305Known options:
1306 defaults reload default config values from disk
1307 commit commit session changes to disk
1308 init go through a dialog to set all parameters
1309
1310You may edit key values in the follow fashion (the "o" is a literal
1311letter o):
1312
1313 o conf build_cache 15
1314
1315 o conf build_dir "/foo/bar"
1316
1317 o conf urllist shift
1318
1319 o conf urllist unshift ftp://ftp.foo.bar/
1320
1321]);
1322 undef; #don't reprint CPAN::Config
1323}
1324
1325#-> sub CPAN::Config::cpl ;
1326sub cpl {
1327 my($word,$line,$pos) = @_;
1328 $word ||= "";
1329 CPAN->debug("word[$word] line[$line] pos[$pos]") if $CPAN::DEBUG;
1330 my(@words) = split " ", substr($line,0,$pos+1);
1331 if (
1332 defined($words[2])
1333 and
1334 (
1335 $words[2] =~ /list$/ && @words == 3
1336 ||
1337 $words[2] =~ /list$/ && @words == 4 && length($word)
1338 )
1339 ) {
1340 return grep /^\Q$word\E/, qw(splice shift unshift pop push);
1341 } elsif (@words >= 4) {
1342 return ();
1343 }
1344 my(@o_conf) = (keys %CPAN::Config::can, keys %$CPAN::Config);
1345 return grep /^\Q$word\E/, @o_conf;
1346}
1347
1348package CPAN::Shell;
1349
1350#-> sub CPAN::Shell::h ;
1351sub h {
1352 my($class,$about) = @_;
1353 if (defined $about) {
1354 $CPAN::Frontend->myprint("Detailed help not yet implemented\n");
1355 } else {
1356 $CPAN::Frontend->myprint(q{
1357Display Information
1358 command argument description
1359 a,b,d,m WORD or /REGEXP/ about authors, bundles, distributions, modules
1360 i WORD or /REGEXP/ about anything of above
1361 r NONE reinstall recommendations
1362 ls AUTHOR about files in the author's directory
1363
1364Download, Test, Make, Install...
1365 get download
1366 make make (implies get)
1367 test MODULES, make test (implies make)
1368 install DISTS, BUNDLES make install (implies test)
1369 clean make clean
1370 look open subshell in these dists' directories
1371 readme display these dists' README files
1372
1373Other
1374 h,? display this menu ! perl-code eval a perl command
1375 o conf [opt] set and query options q quit the cpan shell
1376 reload cpan load CPAN.pm again reload index load newer indices
1377 autobundle Snapshot force cmd unconditionally do cmd});
1378 }
1379}
1380
1381*help = \&h;
1382
1383#-> sub CPAN::Shell::a ;
1384sub a {
1385 my($self,@arg) = @_;
1386 # authors are always UPPERCASE
1387 for (@arg) {
1388 $_ = uc $_ unless /=/;
1389 }
1390 $CPAN::Frontend->myprint($self->format_result('Author',@arg));
1391}
1392
1393#-> sub CPAN::Shell::ls ;
1394sub ls {
1395 my($self,@arg) = @_;
1396 my @accept;
1397 for (@arg) {
1398 unless (/^[A-Z\-]+$/i) {
1399 $CPAN::Frontend->mywarn("ls command rejects argument $_: not an author\n");
1400 next;
1401 }
1402 push @accept, uc $_;
1403 }
1404 for my $a (@accept){
1405 my $author = $self->expand('Author',$a) or die "No author found for $a";
1406 $author->ls;
1407 }
1408}
1409
1410#-> sub CPAN::Shell::local_bundles ;
1411sub local_bundles {
1412 my($self,@which) = @_;
1413 my($incdir,$bdir,$dh);
1414 foreach $incdir ($CPAN::Config->{'cpan_home'},@INC) {
1415 my @bbase = "Bundle";
1416 while (my $bbase = shift @bbase) {
1417 $bdir = File::Spec->catdir($incdir,split /::/, $bbase);
1418 CPAN->debug("bdir[$bdir]\@bbase[@bbase]") if $CPAN::DEBUG;
1419 if ($dh = DirHandle->new($bdir)) { # may fail
1420 my($entry);
1421 for $entry ($dh->read) {
1422 next if $entry =~ /^\./;
1423 if (-d File::Spec->catdir($bdir,$entry)){
1424 push @bbase, "$bbase\::$entry";
1425 } else {
1426 next unless $entry =~ s/\.pm(?!\n)\Z//;
1427 $CPAN::META->instance('CPAN::Bundle',"$bbase\::$entry");
1428 }
1429 }
1430 }
1431 }
1432 }
1433}
1434
1435#-> sub CPAN::Shell::b ;
1436sub b {
1437 my($self,@which) = @_;
1438 CPAN->debug("which[@which]") if $CPAN::DEBUG;
1439 $self->local_bundles;
1440 $CPAN::Frontend->myprint($self->format_result('Bundle',@which));
1441}
1442
1443#-> sub CPAN::Shell::d ;
1444sub d { $CPAN::Frontend->myprint(shift->format_result('Distribution',@_));}
1445
1446#-> sub CPAN::Shell::m ;
1447sub m { # emacs confused here }; sub mimimimimi { # emacs in sync here
1448 my $self = shift;
1449 $CPAN::Frontend->myprint($self->format_result('Module',@_));
1450}
1451
1452#-> sub CPAN::Shell::i ;
1453sub i {
1454 my($self) = shift;
1455 my(@args) = @_;
1456 my(@type,$type,@m);
1457 @type = qw/Author Bundle Distribution Module/;
1458 @args = '/./' unless @args;
1459 my(@result);
1460 for $type (@type) {
1461 push @result, $self->expand($type,@args);
1462 }
1463 my $result = @result == 1 ?
1464 $result[0]->as_string :
1465 @result == 0 ?
1466 "No objects found of any type for argument @args\n" :
1467 join("",
1468 (map {$_->as_glimpse} @result),
1469 scalar @result, " items found\n",
1470 );
1471 $CPAN::Frontend->myprint($result);
1472}
1473
1474#-> sub CPAN::Shell::o ;
1475
1476# CPAN::Shell::o and CPAN::Config::edit are closely related. 'o conf'
1477# should have been called set and 'o debug' maybe 'set debug'
1478sub o {
1479 my($self,$o_type,@o_what) = @_;
1480 $o_type ||= "";
1481 CPAN->debug("o_type[$o_type] o_what[".join(" | ",@o_what)."]\n");
1482 if ($o_type eq 'conf') {
1483 shift @o_what if @o_what && $o_what[0] eq 'help';
1484 if (!@o_what) { # print all things, "o conf"
1485 my($k,$v);
1486 $CPAN::Frontend->myprint("CPAN::Config options");
1487 if (exists $INC{'CPAN/Config.pm'}) {
1488 $CPAN::Frontend->myprint(" from $INC{'CPAN/Config.pm'}");
1489 }
1490 if (exists $INC{'CPAN/MyConfig.pm'}) {
1491 $CPAN::Frontend->myprint(" and $INC{'CPAN/MyConfig.pm'}");
1492 }
1493 $CPAN::Frontend->myprint(":\n");
1494 for $k (sort keys %CPAN::Config::can) {
1495 $v = $CPAN::Config::can{$k};
1496 $CPAN::Frontend->myprint(sprintf " %-18s %s\n", $k, $v);
1497 }
1498 $CPAN::Frontend->myprint("\n");
1499 for $k (sort keys %$CPAN::Config) {
1500 CPAN::Config->prettyprint($k);
1501 }
1502 $CPAN::Frontend->myprint("\n");
1503 } elsif (!CPAN::Config->edit(@o_what)) {
1504 $CPAN::Frontend->myprint(qq{Type 'o conf' to view configuration }.
1505 qq{edit options\n\n});
1506 }
1507 } elsif ($o_type eq 'debug') {
1508 my(%valid);
1509 @o_what = () if defined $o_what[0] && $o_what[0] =~ /help/i;
1510 if (@o_what) {
1511 while (@o_what) {
1512 my($what) = shift @o_what;
1513 if ($what =~ s/^-// && exists $CPAN::DEBUG{$what}) {
1514 $CPAN::DEBUG &= $CPAN::DEBUG ^ $CPAN::DEBUG{$what};
1515 next;
1516 }
1517 if ( exists $CPAN::DEBUG{$what} ) {
1518 $CPAN::DEBUG |= $CPAN::DEBUG{$what};
1519 } elsif ($what =~ /^\d/) {
1520 $CPAN::DEBUG = $what;
1521 } elsif (lc $what eq 'all') {
1522 my($max) = 0;
1523 for (values %CPAN::DEBUG) {
1524 $max += $_;
1525 }
1526 $CPAN::DEBUG = $max;
1527 } else {
1528 my($known) = 0;
1529 for (keys %CPAN::DEBUG) {
1530 next unless lc($_) eq lc($what);
1531 $CPAN::DEBUG |= $CPAN::DEBUG{$_};
1532 $known = 1;
1533 }
1534 $CPAN::Frontend->myprint("unknown argument [$what]\n")
1535 unless $known;
1536 }
1537 }
1538 } else {
1539 my $raw = "Valid options for debug are ".
1540 join(", ",sort(keys %CPAN::DEBUG), 'all').
1541 qq{ or a number. Completion works on the options. }.
1542 qq{Case is ignored.};
1543 require Text::Wrap;
1544 $CPAN::Frontend->myprint(Text::Wrap::fill("","",$raw));
1545 $CPAN::Frontend->myprint("\n\n");
1546 }
1547 if ($CPAN::DEBUG) {
1548 $CPAN::Frontend->myprint("Options set for debugging:\n");
1549 my($k,$v);
1550 for $k (sort {$CPAN::DEBUG{$a} <=> $CPAN::DEBUG{$b}} keys %CPAN::DEBUG) {
1551 $v = $CPAN::DEBUG{$k};
1552 $CPAN::Frontend->myprint(sprintf " %-14s(%s)\n", $k, $v)
1553 if $v & $CPAN::DEBUG;
1554 }
1555 } else {
1556 $CPAN::Frontend->myprint("Debugging turned off completely.\n");
1557 }
1558 } else {
1559 $CPAN::Frontend->myprint(qq{
1560Known options:
1561 conf set or get configuration variables
1562 debug set or get debugging options
1563});
1564 }
1565}
1566
1567sub paintdots_onreload {
1568 my($ref) = shift;
1569 sub {
1570 if ( $_[0] =~ /[Ss]ubroutine ([\w:]+) redefined/ ) {
1571 my($subr) = $1;
1572 ++$$ref;
1573 local($|) = 1;
1574 # $CPAN::Frontend->myprint(".($subr)");
1575 $CPAN::Frontend->myprint(".");
1576 return;
1577 }
1578 warn @_;
1579 };
1580}
1581
1582#-> sub CPAN::Shell::reload ;
1583sub reload {
1584 my($self,$command,@arg) = @_;
1585 $command ||= "";
1586 $self->debug("self[$self]command[$command]arg[@arg]") if $CPAN::DEBUG;
1587 if ($command =~ /cpan/i) {
1588 for my $f (qw(CPAN.pm CPAN/FirstTime.pm)) {
1589 next unless $INC{$f};
1590 CPAN->debug("reloading the whole $f") if $CPAN::DEBUG;
1591 my $fh = FileHandle->new($INC{$f});
1592 local($/);
1593 my $redef = 0;
1594 local($SIG{__WARN__}) = paintdots_onreload(\$redef);
1595 eval <$fh>;
1596 warn $@ if $@;
1597 $CPAN::Frontend->myprint("\n$redef subroutines redefined\n");
1598 }
1599 } elsif ($command =~ /index/) {
1600 CPAN::Index->force_reload;
1601 } else {
1602 $CPAN::Frontend->myprint(qq{cpan re-evals the CPAN.pm file
1603index re-reads the index files\n});
1604 }
1605}
1606
1607#-> sub CPAN::Shell::_binary_extensions ;
1608sub _binary_extensions {
1609 my($self) = shift @_;
1610 my(@result,$module,%seen,%need,$headerdone);
1611 for $module ($self->expand('Module','/./')) {
1612 my $file = $module->cpan_file;
1613 next if $file eq "N/A";
1614 next if $file =~ /^Contact Author/;
1615 my $dist = $CPAN::META->instance('CPAN::Distribution',$file);
1616 next if $dist->isa_perl;
1617 next unless $module->xs_file;
1618 local($|) = 1;
1619 $CPAN::Frontend->myprint(".");
1620 push @result, $module;
1621 }
1622# print join " | ", @result;
1623 $CPAN::Frontend->myprint("\n");
1624 return @result;
1625}
1626
1627#-> sub CPAN::Shell::recompile ;
1628sub recompile {
1629 my($self) = shift @_;
1630 my($module,@module,$cpan_file,%dist);
1631 @module = $self->_binary_extensions();
1632 for $module (@module){ # we force now and compile later, so we
1633 # don't do it twice
1634 $cpan_file = $module->cpan_file;
1635 my $pack = $CPAN::META->instance('CPAN::Distribution',$cpan_file);
1636 $pack->force;
1637 $dist{$cpan_file}++;
1638 }
1639 for $cpan_file (sort keys %dist) {
1640 $CPAN::Frontend->myprint(" CPAN: Recompiling $cpan_file\n\n");
1641 my $pack = $CPAN::META->instance('CPAN::Distribution',$cpan_file);
1642 $pack->install;
1643 $CPAN::Signal = 0; # it's tempting to reset Signal, so we can
1644 # stop a package from recompiling,
1645 # e.g. IO-1.12 when we have perl5.003_10
1646 }
1647}
1648
1649#-> sub CPAN::Shell::_u_r_common ;
1650sub _u_r_common {
1651 my($self) = shift @_;
1652 my($what) = shift @_;
1653 CPAN->debug("self[$self] what[$what] args[@_]") if $CPAN::DEBUG;
1654 Carp::croak "Usage: \$obj->_u_r_common(a|r|u)" unless
1655 $what && $what =~ /^[aru]$/;
1656 my(@args) = @_;
1657 @args = '/./' unless @args;
1658 my(@result,$module,%seen,%need,$headerdone,
1659 $version_undefs,$version_zeroes);
1660 $version_undefs = $version_zeroes = 0;
1661 my $sprintf = "%s%-25s%s %9s %9s %s\n";
1662 my @expand = $self->expand('Module',@args);
1663 my $expand = scalar @expand;
1664 if (0) { # Looks like noise to me, was very useful for debugging
1665 # for metadata cache
1666 $CPAN::Frontend->myprint(sprintf "%d matches in the database\n", $expand);
1667 }
1668 for $module (@expand) {
1669 my $file = $module->cpan_file;
1670 next unless defined $file; # ??
1671 my($latest) = $module->cpan_version;
1672 my($inst_file) = $module->inst_file;
1673 my($have);
1674 return if $CPAN::Signal;
1675 if ($inst_file){
1676 if ($what eq "a") {
1677 $have = $module->inst_version;
1678 } elsif ($what eq "r") {
1679 $have = $module->inst_version;
1680 local($^W) = 0;
1681 if ($have eq "undef"){
1682 $version_undefs++;
1683 } elsif ($have == 0){
1684 $version_zeroes++;
1685 }
1686 next unless CPAN::Version->vgt($latest, $have);
1687# to be pedantic we should probably say:
1688# && !($have eq "undef" && $latest ne "undef" && $latest gt "");
1689# to catch the case where CPAN has a version 0 and we have a version undef
1690 } elsif ($what eq "u") {
1691 next;
1692 }
1693 } else {
1694 if ($what eq "a") {
1695 next;
1696 } elsif ($what eq "r") {
1697 next;
1698 } elsif ($what eq "u") {
1699 $have = "-";
1700 }
1701 }
1702 return if $CPAN::Signal; # this is sometimes lengthy
1703 $seen{$file} ||= 0;
1704 if ($what eq "a") {
1705 push @result, sprintf "%s %s\n", $module->id, $have;
1706 } elsif ($what eq "r") {
1707 push @result, $module->id;
1708 next if $seen{$file}++;
1709 } elsif ($what eq "u") {
1710 push @result, $module->id;
1711 next if $seen{$file}++;
1712 next if $file =~ /^Contact/;
1713 }
1714 unless ($headerdone++){
1715 $CPAN::Frontend->myprint("\n");
1716 $CPAN::Frontend->myprint(sprintf(
1717 $sprintf,
1718 "",
1719 "Package namespace",
1720 "",
1721 "installed",
1722 "latest",
1723 "in CPAN file"
1724 ));
1725 }
1726 my $color_on = "";
1727 my $color_off = "";
1728 if (
1729 $COLOR_REGISTERED
1730 &&
1731 $CPAN::META->has_inst("Term::ANSIColor")
1732 &&
1733 $module->{RO}{description}
1734 ) {
1735 $color_on = Term::ANSIColor::color("green");
1736 $color_off = Term::ANSIColor::color("reset");
1737 }
1738 $CPAN::Frontend->myprint(sprintf $sprintf,
1739 $color_on,
1740 $module->id,
1741 $color_off,
1742 $have,
1743 $latest,
1744 $file);
1745 $need{$module->id}++;
1746 }
1747 unless (%need) {
1748 if ($what eq "u") {
1749 $CPAN::Frontend->myprint("No modules found for @args\n");
1750 } elsif ($what eq "r") {
1751 $CPAN::Frontend->myprint("All modules are up to date for @args\n");
1752 }
1753 }
1754 if ($what eq "r") {
1755 if ($version_zeroes) {
1756 my $s_has = $version_zeroes > 1 ? "s have" : " has";
1757 $CPAN::Frontend->myprint(qq{$version_zeroes installed module$s_has }.
1758 qq{a version number of 0\n});
1759 }
1760 if ($version_undefs) {
1761 my $s_has = $version_undefs > 1 ? "s have" : " has";
1762 $CPAN::Frontend->myprint(qq{$version_undefs installed module$s_has no }.
1763 qq{parseable version number\n});
1764 }
1765 }
1766 @result;
1767}
1768
1769#-> sub CPAN::Shell::r ;
1770sub r {
1771 shift->_u_r_common("r",@_);
1772}
1773
1774#-> sub CPAN::Shell::u ;
1775sub u {
1776 shift->_u_r_common("u",@_);
1777}
1778
1779#-> sub CPAN::Shell::autobundle ;
1780sub autobundle {
1781 my($self) = shift;
1782 CPAN::Config->load unless $CPAN::Config_loaded++;
1783 my(@bundle) = $self->_u_r_common("a",@_);
1784 my($todir) = File::Spec->catdir($CPAN::Config->{'cpan_home'},"Bundle");
1785 File::Path::mkpath($todir);
1786 unless (-d $todir) {
1787 $CPAN::Frontend->myprint("Couldn't mkdir $todir for some reason\n");
1788 return;
1789 }
1790 my($y,$m,$d) = (localtime)[5,4,3];
1791 $y+=1900;
1792 $m++;
1793 my($c) = 0;
1794 my($me) = sprintf "Snapshot_%04d_%02d_%02d_%02d", $y, $m, $d, $c;
1795 my($to) = File::Spec->catfile($todir,"$me.pm");
1796 while (-f $to) {
1797 $me = sprintf "Snapshot_%04d_%02d_%02d_%02d", $y, $m, $d, ++$c;
1798 $to = File::Spec->catfile($todir,"$me.pm");
1799 }
1800 my($fh) = FileHandle->new(">$to") or Carp::croak "Can't open >$to: $!";
1801 $fh->print(
1802 "package Bundle::$me;\n\n",
1803 "\$VERSION = '0.01';\n\n",
1804 "1;\n\n",
1805 "__END__\n\n",
1806 "=head1 NAME\n\n",
1807 "Bundle::$me - Snapshot of installation on ",
1808 $Config::Config{'myhostname'},
1809 " on ",
1810 scalar(localtime),
1811 "\n\n=head1 SYNOPSIS\n\n",
1812 "perl -MCPAN -e 'install Bundle::$me'\n\n",
1813 "=head1 CONTENTS\n\n",
1814 join("\n", @bundle),
1815 "\n\n=head1 CONFIGURATION\n\n",
1816 Config->myconfig,
1817 "\n\n=head1 AUTHOR\n\n",
1818 "This Bundle has been generated automatically ",
1819 "by the autobundle routine in CPAN.pm.\n",
1820 );
1821 $fh->close;
1822 $CPAN::Frontend->myprint("\nWrote bundle file
1823 $to\n\n");
1824}
1825
1826#-> sub CPAN::Shell::expandany ;
1827sub expandany {
1828 my($self,$s) = @_;
1829 CPAN->debug("s[$s]") if $CPAN::DEBUG;
1830 if ($s =~ m|/|) { # looks like a file
1831 $s = CPAN::Distribution->normalize($s);
1832 return $CPAN::META->instance('CPAN::Distribution',$s);
1833 # Distributions spring into existence, not expand
1834 } elsif ($s =~ m|^Bundle::|) {
1835 $self->local_bundles; # scanning so late for bundles seems
1836 # both attractive and crumpy: always
1837 # current state but easy to forget
1838 # somewhere
1839 return $self->expand('Bundle',$s);
1840 } else {
1841 return $self->expand('Module',$s)
1842 if $CPAN::META->exists('CPAN::Module',$s);
1843 }
1844 return;
1845}
1846
1847#-> sub CPAN::Shell::expand ;
1848sub expand {
1849 shift;
1850 my($type,@args) = @_;
1851 my($arg,@m);
1852 CPAN->debug("type[$type]args[@args]") if $CPAN::DEBUG;
1853 for $arg (@args) {
1854 my($regex,$command);
1855 if ($arg =~ m|^/(.*)/$|) {
1856 $regex = $1;
1857 } elsif ($arg =~ m/=/) {
1858 $command = 1;
1859 }
1860 my $class = "CPAN::$type";
1861 my $obj;
1862 CPAN->debug(sprintf "class[%s]regex[%s]command[%s]",
1863 $class,
1864 defined $regex ? $regex : "UNDEFINED",
1865 $command || "UNDEFINED",
1866 ) if $CPAN::DEBUG;
1867 if (defined $regex) {
1868 for $obj (
1869 sort
1870 {$a->id cmp $b->id}
1871 $CPAN::META->all_objects($class)
1872 ) {
1873 unless ($obj->id){
1874 # BUG, we got an empty object somewhere
1875 require Data::Dumper;
1876 CPAN->debug(sprintf(
1877 "Bug in CPAN: Empty id on obj[%s][%s]",
1878 $obj,
1879 Data::Dumper::Dumper($obj)
1880 )) if $CPAN::DEBUG;
1881 next;
1882 }
1883 push @m, $obj
1884 if $obj->id =~ /$regex/i
1885 or
1886 (
1887 (
1888 $] < 5.00303 ### provide sort of
1889 ### compatibility with 5.003
1890 ||
1891 $obj->can('name')
1892 )
1893 &&
1894 $obj->name =~ /$regex/i
1895 );
1896 }
1897 } elsif ($command) {
1898 die "equal sign in command disabled (immature interface), ".
1899 "you can set
1900 ! \$CPAN::Shell::ADVANCED_QUERY=1
1901to enable it. But please note, this is HIGHLY EXPERIMENTAL code
1902that may go away anytime.\n"
1903 unless $ADVANCED_QUERY;
1904 my($method,$criterion) = $arg =~ /(.+?)=(.+)/;
1905 my($matchcrit) = $criterion =~ m/^~(.+)/;
1906 for my $self (
1907 sort
1908 {$a->id cmp $b->id}
1909 $CPAN::META->all_objects($class)
1910 ) {
1911 my $lhs = $self->$method() or next; # () for 5.00503
1912 if ($matchcrit) {
1913 push @m, $self if $lhs =~ m/$matchcrit/;
1914 } else {
1915 push @m, $self if $lhs eq $criterion;
1916 }
1917 }
1918 } else {
1919 my($xarg) = $arg;
1920 if ( $type eq 'Bundle' ) {
1921 $xarg =~ s/^(Bundle::)?(.*)/Bundle::$2/;
1922 } elsif ($type eq "Distribution") {
1923 $xarg = CPAN::Distribution->normalize($arg);
1924 }
1925 if ($CPAN::META->exists($class,$xarg)) {
1926 $obj = $CPAN::META->instance($class,$xarg);
1927 } elsif ($CPAN::META->exists($class,$arg)) {
1928 $obj = $CPAN::META->instance($class,$arg);
1929 } else {
1930 next;
1931 }
1932 push @m, $obj;
1933 }
1934 }
1935 return wantarray ? @m : $m[0];
1936}
1937
1938#-> sub CPAN::Shell::format_result ;
1939sub format_result {
1940 my($self) = shift;
1941 my($type,@args) = @_;
1942 @args = '/./' unless @args;
1943 my(@result) = $self->expand($type,@args);
1944 my $result = @result == 1 ?
1945 $result[0]->as_string :
1946 @result == 0 ?
1947 "No objects of type $type found for argument @args\n" :
1948 join("",
1949 (map {$_->as_glimpse} @result),
1950 scalar @result, " items found\n",
1951 );
1952 $result;
1953}
1954
1955# The only reason for this method is currently to have a reliable
1956# debugging utility that reveals which output is going through which
1957# channel. No, I don't like the colors ;-)
1958
1959#-> sub CPAN::Shell::print_ornameted ;
1960sub print_ornamented {
1961 my($self,$what,$ornament) = @_;
1962 my $longest = 0;
1963 return unless defined $what;
1964
1965 if ($CPAN::Config->{term_is_latin}){
1966 # courtesy jhi:
1967 $what
1968 =~ s{([\xC0-\xDF])([\x80-\xBF])}{chr(ord($1)<<6&0xC0|ord($2)&0x3F)}eg; #};
1969 }
1970 if ($PRINT_ORNAMENTING) {
1971 unless (defined &color) {
1972 if ($CPAN::META->has_inst("Term::ANSIColor")) {
1973 import Term::ANSIColor "color";
1974 } else {
1975 *color = sub { return "" };
1976 }
1977 }
1978 my $line;
1979 for $line (split /\n/, $what) {
1980 $longest = length($line) if length($line) > $longest;
1981 }
1982 my $sprintf = "%-" . $longest . "s";
1983 while ($what){
1984 $what =~ s/(.*\n?)//m;
1985 my $line = $1;
1986 last unless $line;
1987 my($nl) = chomp $line ? "\n" : "";
1988 # print "line[$line]ornament[$ornament]sprintf[$sprintf]\n";
1989 print color($ornament), sprintf($sprintf,$line), color("reset"), $nl;
1990 }
1991 } else {
1992 # chomp $what;
1993 # $what .= "\n"; # newlines unless $PRINT_ORNAMENTING
1994 print $what;
1995 }
1996}
1997
1998sub myprint {
1999 my($self,$what) = @_;
2000
2001 $self->print_ornamented($what, 'bold blue on_yellow');
2002}
2003
2004sub myexit {
2005 my($self,$what) = @_;
2006 $self->myprint($what);
2007 exit;
2008}
2009
2010sub mywarn {
2011 my($self,$what) = @_;
2012 $self->print_ornamented($what, 'bold red on_yellow');
2013}
2014
2015sub myconfess {
2016 my($self,$what) = @_;
2017 $self->print_ornamented($what, 'bold red on_white');
2018 Carp::confess "died";
2019}
2020
2021sub mydie {
2022 my($self,$what) = @_;
2023 $self->print_ornamented($what, 'bold red on_white');
2024 die "\n";
2025}
2026
2027sub setup_output {
2028 return if -t STDOUT;
2029 my $odef = select STDERR;
2030 $| = 1;
2031 select STDOUT;
2032 $| = 1;
2033 select $odef;
2034}
2035
2036#-> sub CPAN::Shell::rematein ;
2037# RE-adme||MA-ke||TE-st||IN-stall
2038sub rematein {
2039 shift;
2040 my($meth,@some) = @_;
2041 my $pragma = "";
2042 if ($meth eq 'force') {
2043 $pragma = $meth;
2044 $meth = shift @some;
2045 }
2046 setup_output();
2047 CPAN->debug("pragma[$pragma]meth[$meth] some[@some]") if $CPAN::DEBUG;
2048
2049 # Here is the place to set "test_count" on all involved parties to
2050 # 0. We then can pass this counter on to the involved
2051 # distributions and those can refuse to test if test_count > X. In
2052 # the first stab at it we could use a 1 for "X".
2053
2054 # But when do I reset the distributions to start with 0 again?
2055 # Jost suggested to have a random or cycling interaction ID that
2056 # we pass through. But the ID is something that is just left lying
2057 # around in addition to the counter, so I'd prefer to set the
2058 # counter to 0 now, and repeat at the end of the loop. But what
2059 # about dependencies? They appear later and are not reset, they
2060 # enter the queue but not its copy. How do they get a sensible
2061 # test_count?
2062
2063 # construct the queue
2064 my($s,@s,@qcopy);
2065 foreach $s (@some) {
2066 my $obj;
2067 if (ref $s) {
2068 CPAN->debug("s is an object[$s]") if $CPAN::DEBUG;
2069 $obj = $s;
2070 } elsif ($s =~ m|^/|) { # looks like a regexp
2071 $CPAN::Frontend->mywarn("Sorry, $meth with a regular expression is ".
2072 "not supported\n");
2073 sleep 2;
2074 next;
2075 } else {
2076 CPAN->debug("calling expandany [$s]") if $CPAN::DEBUG;
2077 $obj = CPAN::Shell->expandany($s);
2078 }
2079 if (ref $obj) {
2080 $obj->color_cmd_tmps(0,1);
2081 CPAN::Queue->new($obj->id);
2082 push @qcopy, $obj;
2083 } elsif ($CPAN::META->exists('CPAN::Author',$s)) {
2084 $obj = $CPAN::META->instance('CPAN::Author',$s);
2085 if ($meth =~ /^(dump|ls)$/) {
2086 $obj->$meth();
2087 } else {
2088 $CPAN::Frontend->myprint(
2089 join "",
2090 "Don't be silly, you can't $meth ",
2091 $obj->fullname,
2092 " ;-)\n"
2093 );
2094 sleep 2;
2095 }
2096 } else {
2097 $CPAN::Frontend
2098 ->myprint(qq{Warning: Cannot $meth $s, }.
2099 qq{don\'t know what it is.
2100Try the command
2101
2102 i /$s/
2103
2104to find objects with matching identifiers.
2105});
2106 sleep 2;
2107 }
2108 }
2109
2110 # queuerunner (please be warned: when I started to change the
2111 # queue to hold objects instead of names, I made one or two
2112 # mistakes and never found which. I reverted back instead)
2113 while ($s = CPAN::Queue->first) {
2114 my $obj;
2115 if (ref $s) {
2116 $obj = $s; # I do not believe, we would survive if this happened
2117 } else {
2118 $obj = CPAN::Shell->expandany($s);
2119 }
2120 if ($pragma
2121 &&
2122 ($] < 5.00303 || $obj->can($pragma))){
2123 ### compatibility with 5.003
2124 $obj->$pragma($meth); # the pragma "force" in
2125 # "CPAN::Distribution" must know
2126 # what we are intending
2127 }
2128 if ($]>=5.00303 && $obj->can('called_for')) {
2129 $obj->called_for($s);
2130 }
2131 CPAN->debug(
2132 qq{pragma[$pragma]meth[$meth]obj[$obj]as_string\[}.
2133 $obj->as_string.
2134 qq{\]}
2135 ) if $CPAN::DEBUG;
2136
2137 if ($obj->$meth()){
2138 CPAN::Queue->delete($s);
2139 } else {
2140 CPAN->debug("failed");
2141 }
2142
2143 $obj->undelay;
2144 CPAN::Queue->delete_first($s);
2145 }
2146 for my $obj (@qcopy) {
2147 $obj->color_cmd_tmps(0,0);
2148 }
2149}
2150
2151#-> sub CPAN::Shell::dump ;
2152sub dump { shift->rematein('dump',@_); }
2153#-> sub CPAN::Shell::force ;
2154sub force { shift->rematein('force',@_); }
2155#-> sub CPAN::Shell::get ;
2156sub get { shift->rematein('get',@_); }
2157#-> sub CPAN::Shell::readme ;
2158sub readme { shift->rematein('readme',@_); }
2159#-> sub CPAN::Shell::make ;
2160sub make { shift->rematein('make',@_); }
2161#-> sub CPAN::Shell::test ;
2162sub test { shift->rematein('test',@_); }
2163#-> sub CPAN::Shell::install ;
2164sub install { shift->rematein('install',@_); }
2165#-> sub CPAN::Shell::clean ;
2166sub clean { shift->rematein('clean',@_); }
2167#-> sub CPAN::Shell::look ;
2168sub look { shift->rematein('look',@_); }
2169#-> sub CPAN::Shell::cvs_import ;
2170sub cvs_import { shift->rematein('cvs_import',@_); }
2171
2172package CPAN::LWP::UserAgent;
2173
2174sub config {
2175 return if $SETUPDONE;
2176 if ($CPAN::META->has_usable('LWP::UserAgent')) {
2177 require LWP::UserAgent;
2178 @ISA = qw(Exporter LWP::UserAgent);
2179 $SETUPDONE++;
2180 } else {
2181 $CPAN::Frontend->mywarn("LWP::UserAgent not available\n");
2182 }
2183}
2184
2185sub get_basic_credentials {
2186 my($self, $realm, $uri, $proxy) = @_;
2187 return unless $proxy;
2188 if ($USER && $PASSWD) {
2189 } elsif (defined $CPAN::Config->{proxy_user} &&
2190 defined $CPAN::Config->{proxy_pass}) {
2191 $USER = $CPAN::Config->{proxy_user};
2192 $PASSWD = $CPAN::Config->{proxy_pass};
2193 } else {
2194 require ExtUtils::MakeMaker;
2195 ExtUtils::MakeMaker->import(qw(prompt));
2196 $USER = prompt("Proxy authentication needed!
2197 (Note: to permanently configure username and password run
2198 o conf proxy_user your_username
2199 o conf proxy_pass your_password
2200 )\nUsername:");
2201 if ($CPAN::META->has_inst("Term::ReadKey")) {
2202 Term::ReadKey::ReadMode("noecho");
2203 } else {
2204 $CPAN::Frontend->mywarn("Warning: Term::ReadKey seems not to be available, your password will be echoed to the terminal!\n");
2205 }
2206 $PASSWD = prompt("Password:");
2207 if ($CPAN::META->has_inst("Term::ReadKey")) {
2208 Term::ReadKey::ReadMode("restore");
2209 }
2210 $CPAN::Frontend->myprint("\n\n");
2211 }
2212 return($USER,$PASSWD);
2213}
2214
2215# mirror(): Its purpose is to deal with proxy authentication. When we
2216# call SUPER::mirror, we relly call the mirror method in
2217# LWP::UserAgent. LWP::UserAgent will then call
2218# $self->get_basic_credentials or some equivalent and this will be
2219# $self->dispatched to our own get_basic_credentials method.
2220
2221# Our own get_basic_credentials sets $USER and $PASSWD, two globals.
2222
2223# 407 stands for HTTP_PROXY_AUTHENTICATION_REQUIRED. Which means
2224# although we have gone through our get_basic_credentials, the proxy
2225# server refuses to connect. This could be a case where the username or
2226# password has changed in the meantime, so I'm trying once again without
2227# $USER and $PASSWD to give the get_basic_credentials routine another
2228# chance to set $USER and $PASSWD.
2229
2230sub mirror {
2231 my($self,$url,$aslocal) = @_;
2232 my $result = $self->SUPER::mirror($url,$aslocal);
2233 if ($result->code == 407) {
2234 undef $USER;
2235 undef $PASSWD;
2236 $result = $self->SUPER::mirror($url,$aslocal);
2237 }
2238 $result;
2239}
2240
2241package CPAN::FTP;
2242
2243#-> sub CPAN::FTP::ftp_get ;
2244sub ftp_get {
2245 my($class,$host,$dir,$file,$target) = @_;
2246 $class->debug(
2247 qq[Going to fetch file [$file] from dir [$dir]
2248 on host [$host] as local [$target]\n]
2249 ) if $CPAN::DEBUG;
2250 my $ftp = Net::FTP->new($host);
2251 return 0 unless defined $ftp;
2252 $ftp->debug(1) if $CPAN::DEBUG{'FTP'} & $CPAN::DEBUG;
2253 $class->debug(qq[Going to login("anonymous","$Config::Config{cf_email}")]);
2254 unless ( $ftp->login("anonymous",$Config::Config{'cf_email'}) ){
2255 warn "Couldn't login on $host";
2256 return;
2257 }
2258 unless ( $ftp->cwd($dir) ){
2259 warn "Couldn't cwd $dir";
2260 return;
2261 }
2262 $ftp->binary;
2263 $class->debug(qq[Going to ->get("$file","$target")\n]) if $CPAN::DEBUG;
2264 unless ( $ftp->get($file,$target) ){
2265 warn "Couldn't fetch $file from $host\n";
2266 return;
2267 }
2268 $ftp->quit; # it's ok if this fails
2269 return 1;
2270}
2271
2272# If more accuracy is wanted/needed, Chris Leach sent me this patch...
2273
2274 # > *** /install/perl/live/lib/CPAN.pm- Wed Sep 24 13:08:48 1997
2275 # > --- /tmp/cp Wed Sep 24 13:26:40 1997
2276 # > ***************
2277 # > *** 1562,1567 ****
2278 # > --- 1562,1580 ----
2279 # > return 1 if substr($url,0,4) eq "file";
2280 # > return 1 unless $url =~ m|://([^/]+)|;
2281 # > my $host = $1;
2282 # > + my $proxy = $CPAN::Config->{'http_proxy'} || $ENV{'http_proxy'};
2283 # > + if ($proxy) {
2284 # > + $proxy =~ m|://([^/:]+)|;
2285 # > + $proxy = $1;
2286 # > + my $noproxy = $CPAN::Config->{'no_proxy'} || $ENV{'no_proxy'};
2287 # > + if ($noproxy) {
2288 # > + if ($host !~ /$noproxy$/) {
2289 # > + $host = $proxy;
2290 # > + }
2291 # > + } else {
2292 # > + $host = $proxy;
2293 # > + }
2294 # > + }
2295 # > require Net::Ping;
2296 # > return 1 unless $Net::Ping::VERSION >= 2;
2297 # > my $p;
2298
2299
2300#-> sub CPAN::FTP::localize ;
2301sub localize {
2302 my($self,$file,$aslocal,$force) = @_;
2303 $force ||= 0;
2304 Carp::croak "Usage: ->localize(cpan_file,as_local_file[,$force])"
2305 unless defined $aslocal;
2306 $self->debug("file[$file] aslocal[$aslocal] force[$force]")
2307 if $CPAN::DEBUG;
2308
2309 if ($^O eq 'MacOS') {
2310 # Comment by AK on 2000-09-03: Uniq short filenames would be
2311 # available in CHECKSUMS file
2312 my($name, $path) = File::Basename::fileparse($aslocal, '');
2313 if (length($name) > 31) {
2314 $name =~ s/(
2315 \.(
2316 readme(\.(gz|Z))? |
2317 (tar\.)?(gz|Z) |
2318 tgz |
2319 zip |
2320 pm\.(gz|Z)
2321 )
2322 )$//x;
2323 my $suf = $1;
2324 my $size = 31 - length($suf);
2325 while (length($name) > $size) {
2326 chop $name;
2327 }
2328 $name .= $suf;
2329 $aslocal = File::Spec->catfile($path, $name);
2330 }
2331 }
2332
2333 return $aslocal if -f $aslocal && -r _ && !($force & 1);
2334 my($restore) = 0;
2335 if (-f $aslocal){
2336 rename $aslocal, "$aslocal.bak";
2337 $restore++;
2338 }
2339
2340 my($aslocal_dir) = File::Basename::dirname($aslocal);
2341 File::Path::mkpath($aslocal_dir);
2342 $CPAN::Frontend->mywarn(qq{Warning: You are not allowed to write into }.
2343 qq{directory "$aslocal_dir".
2344 I\'ll continue, but if you encounter problems, they may be due
2345 to insufficient permissions.\n}) unless -w $aslocal_dir;
2346
2347 # Inheritance is not easier to manage than a few if/else branches
2348 if ($CPAN::META->has_usable('LWP::UserAgent')) {
2349 unless ($Ua) {
2350 CPAN::LWP::UserAgent->config;
2351 eval {$Ua = CPAN::LWP::UserAgent->new;}; # Why is has_usable still not fit enough?
2352 if ($@) {
2353 $CPAN::Frontend->mywarn("CPAN::LWP::UserAgent->new dies with $@\n")
2354 if $CPAN::DEBUG;
2355 } else {
2356 my($var);
2357 $Ua->proxy('ftp', $var)
2358 if $var = $CPAN::Config->{ftp_proxy} || $ENV{ftp_proxy};
2359 $Ua->proxy('http', $var)
2360 if $var = $CPAN::Config->{http_proxy} || $ENV{http_proxy};
2361
2362
2363# >>>>> On Wed, 13 Dec 2000 09:21:34 -0500, "Robison, Jonathon (J.M.)" <[email protected]> said:
2364#
2365# > I note that although CPAN.pm can use proxies, it doesn't seem equipped to
2366# > use ones that require basic autorization.
2367#
2368# > Example of when I use it manually in my own stuff:
2369#
2370# > $ua->proxy(['http','ftp'], http://my.proxy.server:83');
2371# > $req->proxy_authorization_basic("username","password");
2372# > $res = $ua->request($req);
2373#
2374
2375 $Ua->no_proxy($var)
2376 if $var = $CPAN::Config->{no_proxy} || $ENV{no_proxy};
2377 }
2378 }
2379 }
2380 for my $prx (qw(ftp_proxy http_proxy no_proxy)) {
2381 $ENV{$prx} = $CPAN::Config->{$prx} if $CPAN::Config->{$prx};
2382 }
2383
2384 # Try the list of urls for each single object. We keep a record
2385 # where we did get a file from
2386 my(@reordered,$last);
2387 $CPAN::Config->{urllist} ||= [];
2388 unless (ref $CPAN::Config->{urllist} eq 'ARRAY') {
2389 warn "Malformed urllist; ignoring. Configuration file corrupt?\n";
2390 }
2391 $last = $#{$CPAN::Config->{urllist}};
2392 if ($force & 2) { # local cpans probably out of date, don't reorder
2393 @reordered = (0..$last);
2394 } else {
2395 @reordered =
2396 sort {
2397 (substr($CPAN::Config->{urllist}[$b],0,4) eq "file")
2398 <=>
2399 (substr($CPAN::Config->{urllist}[$a],0,4) eq "file")
2400 or
2401 defined($Thesite)
2402 and
2403 ($b == $Thesite)
2404 <=>
2405 ($a == $Thesite)
2406 } 0..$last;
2407 }
2408 my(@levels);
2409 if ($Themethod) {
2410 @levels = ($Themethod, grep {$_ ne $Themethod} qw/easy hard hardest/);
2411 } else {
2412 @levels = qw/easy hard hardest/;
2413 }
2414 @levels = qw/easy/ if $^O eq 'MacOS';
2415 my($levelno);
2416 for $levelno (0..$#levels) {
2417 my $level = $levels[$levelno];
2418 my $method = "host$level";
2419 my @host_seq = $level eq "easy" ?
2420 @reordered : 0..$last; # reordered has CDROM up front
2421 @host_seq = (0) unless @host_seq;
2422 my $ret = $self->$method(\@host_seq,$file,$aslocal);
2423 if ($ret) {
2424 $Themethod = $level;
2425 my $now = time;
2426 # utime $now, $now, $aslocal; # too bad, if we do that, we
2427 # might alter a local mirror
2428 $self->debug("level[$level]") if $CPAN::DEBUG;
2429 return $ret;
2430 } else {
2431 unlink $aslocal;
2432 last if $CPAN::Signal; # need to cleanup
2433 }
2434 }
2435 unless ($CPAN::Signal) {
2436 my(@mess);
2437 push @mess,
2438 qq{Please check, if the URLs I found in your configuration file \(}.
2439 join(", ", @{$CPAN::Config->{urllist}}).
2440 qq{\) are valid. The urllist can be edited.},
2441 qq{E.g. with 'o conf urllist push ftp://myurl/'};
2442 $CPAN::Frontend->myprint(Text::Wrap::wrap("","",@mess). "\n\n");
2443 sleep 2;
2444 $CPAN::Frontend->myprint("Could not fetch $file\n");
2445 }
2446 if ($restore) {
2447 rename "$aslocal.bak", $aslocal;
2448 $CPAN::Frontend->myprint("Trying to get away with old file:\n" .
2449 $self->ls($aslocal));
2450 return $aslocal;
2451 }
2452 return;
2453}
2454
2455sub hosteasy {
2456 my($self,$host_seq,$file,$aslocal) = @_;
2457 my($i);
2458 HOSTEASY: for $i (@$host_seq) {
2459 my $url = $CPAN::Config->{urllist}[$i] || $CPAN::Defaultsite;
2460 $url .= "/" unless substr($url,-1) eq "/";
2461 $url .= $file;
2462 $self->debug("localizing perlish[$url]") if $CPAN::DEBUG;
2463 if ($url =~ /^file:/) {
2464 my $l;
2465 if ($CPAN::META->has_inst('URI::URL')) {
2466 my $u = URI::URL->new($url);
2467 $l = $u->path;
2468 } else { # works only on Unix, is poorly constructed, but
2469 # hopefully better than nothing.
2470 # RFC 1738 says fileurl BNF is
2471 # fileurl = "file://" [ host | "localhost" ] "/" fpath
2472 # Thanks to "Mark D. Baushke" <[email protected]> for
2473 # the code
2474 ($l = $url) =~ s|^file://[^/]*/|/|; # discard the host part
2475 $l =~ s|^file:||; # assume they
2476 # meant
2477 # file://localhost
2478 $l =~ s|^/||s unless -f $l; # e.g. /P:
2479 $self->debug("without URI::URL we try local file $l") if $CPAN::DEBUG;
2480 }
2481 if ( -f $l && -r _) {
2482 $Thesite = $i;
2483 return $l;
2484 }
2485 # Maybe mirror has compressed it?
2486 if (-f "$l.gz") {
2487 $self->debug("found compressed $l.gz") if $CPAN::DEBUG;
2488 CPAN::Tarzip->gunzip("$l.gz", $aslocal);
2489 if ( -f $aslocal) {
2490 $Thesite = $i;
2491 return $aslocal;
2492 }
2493 }
2494 }
2495 if ($CPAN::META->has_usable('LWP')) {
2496 $CPAN::Frontend->myprint("Fetching with LWP:
2497 $url
2498");
2499 unless ($Ua) {
2500 CPAN::LWP::UserAgent->config;
2501 eval { $Ua = CPAN::LWP::UserAgent->new; };
2502 if ($@) {
2503 $CPAN::Frontend->mywarn("CPAN::LWP::UserAgent->new dies with $@\n");
2504 }
2505 }
2506 my $res = $Ua->mirror($url, $aslocal);
2507 if ($res->is_success) {
2508 $Thesite = $i;
2509 my $now = time;
2510 utime $now, $now, $aslocal; # download time is more
2511 # important than upload time
2512 return $aslocal;
2513 } elsif ($url !~ /\.gz(?!\n)\Z/) {
2514 my $gzurl = "$url.gz";
2515 $CPAN::Frontend->myprint("Fetching with LWP:
2516 $gzurl
2517");
2518 $res = $Ua->mirror($gzurl, "$aslocal.gz");
2519 if ($res->is_success &&
2520 CPAN::Tarzip->gunzip("$aslocal.gz",$aslocal)
2521 ) {
2522 $Thesite = $i;
2523 return $aslocal;
2524 }
2525 } else {
2526 $CPAN::Frontend->myprint(sprintf(
2527 "LWP failed with code[%s] message[%s]\n",
2528 $res->code,
2529 $res->message,
2530 ));
2531 # Alan Burlison informed me that in firewall environments
2532 # Net::FTP can still succeed where LWP fails. So we do not
2533 # skip Net::FTP anymore when LWP is available.
2534 }
2535 } else {
2536 $CPAN::Frontend->myprint("LWP not available\n");
2537 }
2538 return if $CPAN::Signal;
2539 if ($url =~ m|^ftp://(.*?)/(.*)/(.*)|) {
2540 # that's the nice and easy way thanks to Graham
2541 my($host,$dir,$getfile) = ($1,$2,$3);
2542 if ($CPAN::META->has_usable('Net::FTP')) {
2543 $dir =~ s|/+|/|g;
2544 $CPAN::Frontend->myprint("Fetching with Net::FTP:
2545 $url
2546");
2547 $self->debug("getfile[$getfile]dir[$dir]host[$host]" .
2548 "aslocal[$aslocal]") if $CPAN::DEBUG;
2549 if (CPAN::FTP->ftp_get($host,$dir,$getfile,$aslocal)) {
2550 $Thesite = $i;
2551 return $aslocal;
2552 }
2553 if ($aslocal !~ /\.gz(?!\n)\Z/) {
2554 my $gz = "$aslocal.gz";
2555 $CPAN::Frontend->myprint("Fetching with Net::FTP
2556 $url.gz
2557");
2558 if (CPAN::FTP->ftp_get($host,
2559 $dir,
2560 "$getfile.gz",
2561 $gz) &&
2562 CPAN::Tarzip->gunzip($gz,$aslocal)
2563 ){
2564 $Thesite = $i;
2565 return $aslocal;
2566 }
2567 }
2568 # next HOSTEASY;
2569 }
2570 }
2571 return if $CPAN::Signal;
2572 }
2573}
2574
2575sub hosthard {
2576 my($self,$host_seq,$file,$aslocal) = @_;
2577
2578 # Came back if Net::FTP couldn't establish connection (or
2579 # failed otherwise) Maybe they are behind a firewall, but they
2580 # gave us a socksified (or other) ftp program...
2581
2582 my($i);
2583 my($devnull) = $CPAN::Config->{devnull} || "";
2584 # < /dev/null ";
2585 my($aslocal_dir) = File::Basename::dirname($aslocal);
2586 File::Path::mkpath($aslocal_dir);
2587 HOSTHARD: for $i (@$host_seq) {
2588 my $url = $CPAN::Config->{urllist}[$i] || $CPAN::Defaultsite;
2589 $url .= "/" unless substr($url,-1) eq "/";
2590 $url .= $file;
2591 my($proto,$host,$dir,$getfile);
2592
2593 # Courtesy Mark Conty [email protected] change from
2594 # if ($url =~ m|^ftp://(.*?)/(.*)/(.*)|) {
2595 # to
2596 if ($url =~ m|^([^:]+)://(.*?)/(.*)/(.*)|) {
2597 # proto not yet used
2598 ($proto,$host,$dir,$getfile) = ($1,$2,$3,$4);
2599 } else {
2600 next HOSTHARD; # who said, we could ftp anything except ftp?
2601 }
2602 next HOSTHARD if $proto eq "file"; # file URLs would have had
2603 # success above. Likely a bogus URL
2604
2605 $self->debug("localizing funkyftpwise[$url]") if $CPAN::DEBUG;
2606 my($f,$funkyftp);
2607 for $f ('lynx','ncftpget','ncftp','wget') {
2608 next unless exists $CPAN::Config->{$f};
2609 $funkyftp = $CPAN::Config->{$f};
2610 next unless defined $funkyftp;
2611 next if $funkyftp =~ /^\s*$/;
2612 my($asl_ungz, $asl_gz);
2613 ($asl_ungz = $aslocal) =~ s/\.gz//;
2614 $asl_gz = "$asl_ungz.gz";
2615 my($src_switch) = "";
2616 if ($f eq "lynx"){
2617 $src_switch = " -source";
2618 } elsif ($f eq "ncftp"){
2619 $src_switch = " -c";
2620 } elsif ($f eq "wget"){
2621 $src_switch = " -O -";
2622 }
2623 my($chdir) = "";
2624 my($stdout_redir) = " > $asl_ungz";
2625 if ($f eq "ncftpget"){
2626 $chdir = "cd $aslocal_dir && ";
2627 $stdout_redir = "";
2628 }
2629 $CPAN::Frontend->myprint(
2630 qq[
2631Trying with "$funkyftp$src_switch" to get
2632 $url
2633]);
2634 my($system) =
2635 "$chdir$funkyftp$src_switch \"$url\" $devnull$stdout_redir";
2636 $self->debug("system[$system]") if $CPAN::DEBUG;
2637 my($wstatus);
2638 if (($wstatus = system($system)) == 0
2639 &&
2640 ($f eq "lynx" ?
2641 -s $asl_ungz # lynx returns 0 when it fails somewhere
2642 : 1
2643 )
2644 ) {
2645 if (-s $aslocal) {
2646 # Looks good
2647 } elsif ($asl_ungz ne $aslocal) {
2648 # test gzip integrity
2649 if (CPAN::Tarzip->gtest($asl_ungz)) {
2650 # e.g. foo.tar is gzipped --> foo.tar.gz
2651 rename $asl_ungz, $aslocal;
2652 } else {
2653 CPAN::Tarzip->gzip($asl_ungz,$asl_gz);
2654 }
2655 }
2656 $Thesite = $i;
2657 return $aslocal;
2658 } elsif ($url !~ /\.gz(?!\n)\Z/) {
2659 unlink $asl_ungz if
2660 -f $asl_ungz && -s _ == 0;
2661 my $gz = "$aslocal.gz";
2662 my $gzurl = "$url.gz";
2663 $CPAN::Frontend->myprint(
2664 qq[
2665Trying with "$funkyftp$src_switch" to get
2666 $url.gz
2667]);
2668 my($system) = "$funkyftp$src_switch \"$url.gz\" $devnull > $asl_gz";
2669 $self->debug("system[$system]") if $CPAN::DEBUG;
2670 my($wstatus);
2671 if (($wstatus = system($system)) == 0
2672 &&
2673 -s $asl_gz
2674 ) {
2675 # test gzip integrity
2676 if (CPAN::Tarzip->gtest($asl_gz)) {
2677 CPAN::Tarzip->gunzip($asl_gz,$aslocal);
2678 } else {
2679 # somebody uncompressed file for us?
2680 rename $asl_ungz, $aslocal;
2681 }
2682 $Thesite = $i;
2683 return $aslocal;
2684 } else {
2685 unlink $asl_gz if -f $asl_gz;
2686 }
2687 } else {
2688 my $estatus = $wstatus >> 8;
2689 my $size = -f $aslocal ?
2690 ", left\n$aslocal with size ".-s _ :
2691 "\nWarning: expected file [$aslocal] doesn't exist";
2692 $CPAN::Frontend->myprint(qq{
2693System call "$system"
2694returned status $estatus (wstat $wstatus)$size
2695});
2696 }
2697 return if $CPAN::Signal;
2698 } # lynx,ncftpget,ncftp
2699 } # host
2700}
2701
2702sub hosthardest {
2703 my($self,$host_seq,$file,$aslocal) = @_;
2704
2705 my($i);
2706 my($aslocal_dir) = File::Basename::dirname($aslocal);
2707 File::Path::mkpath($aslocal_dir);
2708 my $ftpbin = $CPAN::Config->{ftp};
2709 HOSTHARDEST: for $i (@$host_seq) {
2710 unless (length $ftpbin && MM->maybe_command($ftpbin)) {
2711 $CPAN::Frontend->myprint("No external ftp command available\n\n");
2712 last HOSTHARDEST;
2713 }
2714 my $url = $CPAN::Config->{urllist}[$i] || $CPAN::Defaultsite;
2715 $url .= "/" unless substr($url,-1) eq "/";
2716 $url .= $file;
2717 $self->debug("localizing ftpwise[$url]") if $CPAN::DEBUG;
2718 unless ($url =~ m|^ftp://(.*?)/(.*)/(.*)|) {
2719 next;
2720 }
2721 my($host,$dir,$getfile) = ($1,$2,$3);
2722 my $timestamp = 0;
2723 my($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,
2724 $ctime,$blksize,$blocks) = stat($aslocal);
2725 $timestamp = $mtime ||= 0;
2726 my($netrc) = CPAN::FTP::netrc->new;
2727 my($netrcfile) = $netrc->netrc;
2728 my($verbose) = $CPAN::DEBUG{'FTP'} & $CPAN::DEBUG ? " -v" : "";
2729 my $targetfile = File::Basename::basename($aslocal);
2730 my(@dialog);
2731 push(
2732 @dialog,
2733 "lcd $aslocal_dir",
2734 "cd /",
2735 map("cd $_", split /\//, $dir), # RFC 1738
2736 "bin",
2737 "get $getfile $targetfile",
2738 "quit"
2739 );
2740 if (! $netrcfile) {
2741 CPAN->debug("No ~/.netrc file found") if $CPAN::DEBUG;
2742 } elsif ($netrc->hasdefault || $netrc->contains($host)) {
2743 CPAN->debug(sprintf("hasdef[%d]cont($host)[%d]",
2744 $netrc->hasdefault,
2745 $netrc->contains($host))) if $CPAN::DEBUG;
2746 if ($netrc->protected) {
2747 $CPAN::Frontend->myprint(qq{
2748 Trying with external ftp to get
2749 $url
2750 As this requires some features that are not thoroughly tested, we\'re
2751 not sure, that we get it right....
2752
2753}
2754 );
2755 $self->talk_ftp("$ftpbin$verbose $host",
2756 @dialog);
2757 ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
2758 $atime,$mtime,$ctime,$blksize,$blocks) = stat($aslocal);
2759 $mtime ||= 0;
2760 if ($mtime > $timestamp) {
2761 $CPAN::Frontend->myprint("GOT $aslocal\n");
2762 $Thesite = $i;
2763 return $aslocal;
2764 } else {
2765 $CPAN::Frontend->myprint("Hmm... Still failed!\n");
2766 }
2767 return if $CPAN::Signal;
2768 } else {
2769 $CPAN::Frontend->mywarn(qq{Your $netrcfile is not }.
2770 qq{correctly protected.\n});
2771 }
2772 } else {
2773 $CPAN::Frontend->mywarn("Your ~/.netrc neither contains $host
2774 nor does it have a default entry\n");
2775 }
2776
2777 # OK, they don't have a valid ~/.netrc. Use 'ftp -n'
2778 # then and login manually to host, using e-mail as
2779 # password.
2780 $CPAN::Frontend->myprint(qq{Issuing "$ftpbin$verbose -n"\n});
2781 unshift(
2782 @dialog,
2783 "open $host",
2784 "user anonymous $Config::Config{'cf_email'}"
2785 );
2786 $self->talk_ftp("$ftpbin$verbose -n", @dialog);
2787 ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
2788 $atime,$mtime,$ctime,$blksize,$blocks) = stat($aslocal);
2789 $mtime ||= 0;
2790 if ($mtime > $timestamp) {
2791 $CPAN::Frontend->myprint("GOT $aslocal\n");
2792 $Thesite = $i;
2793 return $aslocal;
2794 } else {
2795 $CPAN::Frontend->myprint("Bad luck... Still failed!\n");
2796 }
2797 return if $CPAN::Signal;
2798 $CPAN::Frontend->myprint("Can't access URL $url.\n\n");
2799 sleep 2;
2800 } # host
2801}
2802
2803sub talk_ftp {
2804 my($self,$command,@dialog) = @_;
2805 my $fh = FileHandle->new;
2806 $fh->open("|$command") or die "Couldn't open ftp: $!";
2807 foreach (@dialog) { $fh->print("$_\n") }
2808 $fh->close; # Wait for process to complete
2809 my $wstatus = $?;
2810 my $estatus = $wstatus >> 8;
2811 $CPAN::Frontend->myprint(qq{
2812Subprocess "|$command"
2813 returned status $estatus (wstat $wstatus)
2814}) if $wstatus;
2815}
2816
2817# find2perl needs modularization, too, all the following is stolen
2818# from there
2819# CPAN::FTP::ls
2820sub ls {
2821 my($self,$name) = @_;
2822 my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$sizemm,
2823 $atime,$mtime,$ctime,$blksize,$blocks) = lstat($name);
2824
2825 my($perms,%user,%group);
2826 my $pname = $name;
2827
2828 if ($blocks) {
2829 $blocks = int(($blocks + 1) / 2);
2830 }
2831 else {
2832 $blocks = int(($sizemm + 1023) / 1024);
2833 }
2834
2835 if (-f _) { $perms = '-'; }
2836 elsif (-d _) { $perms = 'd'; }
2837 elsif (-c _) { $perms = 'c'; $sizemm = &sizemm; }
2838 elsif (-b _) { $perms = 'b'; $sizemm = &sizemm; }
2839 elsif (-p _) { $perms = 'p'; }
2840 elsif (-S _) { $perms = 's'; }
2841 else { $perms = 'l'; $pname .= ' -> ' . readlink($_); }
2842
2843 my(@rwx) = ('---','--x','-w-','-wx','r--','r-x','rw-','rwx');
2844 my(@moname) = qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec);
2845 my $tmpmode = $mode;
2846 my $tmp = $rwx[$tmpmode & 7];
2847 $tmpmode >>= 3;
2848 $tmp = $rwx[$tmpmode & 7] . $tmp;
2849 $tmpmode >>= 3;
2850 $tmp = $rwx[$tmpmode & 7] . $tmp;
2851 substr($tmp,2,1) =~ tr/-x/Ss/ if -u _;
2852 substr($tmp,5,1) =~ tr/-x/Ss/ if -g _;
2853 substr($tmp,8,1) =~ tr/-x/Tt/ if -k _;
2854 $perms .= $tmp;
2855
2856 my $user = $user{$uid} || $uid; # too lazy to implement lookup
2857 my $group = $group{$gid} || $gid;
2858
2859 my($sec,$min,$hour,$mday,$mon,$year) = localtime($mtime);
2860 my($timeyear);
2861 my($moname) = $moname[$mon];
2862 if (-M _ > 365.25 / 2) {
2863 $timeyear = $year + 1900;
2864 }
2865 else {
2866 $timeyear = sprintf("%02d:%02d", $hour, $min);
2867 }
2868
2869 sprintf "%5lu %4ld %-10s %2d %-8s %-8s %8s %s %2d %5s %s\n",
2870 $ino,
2871 $blocks,
2872 $perms,
2873 $nlink,
2874 $user,
2875 $group,
2876 $sizemm,
2877 $moname,
2878 $mday,
2879 $timeyear,
2880 $pname;
2881}
2882
2883package CPAN::FTP::netrc;
2884
2885sub new {
2886 my($class) = @_;
2887 my $file = File::Spec->catfile($ENV{HOME},".netrc");
2888
2889 my($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
2890 $atime,$mtime,$ctime,$blksize,$blocks)
2891 = stat($file);
2892 $mode ||= 0;
2893 my $protected = 0;
2894
2895 my($fh,@machines,$hasdefault);
2896 $hasdefault = 0;
2897 $fh = FileHandle->new or die "Could not create a filehandle";
2898
2899 if($fh->open($file)){
2900 $protected = ($mode & 077) == 0;
2901 local($/) = "";
2902 NETRC: while (<$fh>) {
2903 my(@tokens) = split " ", $_;
2904 TOKEN: while (@tokens) {
2905 my($t) = shift @tokens;
2906 if ($t eq "default"){
2907 $hasdefault++;
2908 last NETRC;
2909 }
2910 last TOKEN if $t eq "macdef";
2911 if ($t eq "machine") {
2912 push @machines, shift @tokens;
2913 }
2914 }
2915 }
2916 } else {
2917 $file = $hasdefault = $protected = "";
2918 }
2919
2920 bless {
2921 'mach' => [@machines],
2922 'netrc' => $file,
2923 'hasdefault' => $hasdefault,
2924 'protected' => $protected,
2925 }, $class;
2926}
2927
2928# CPAN::FTP::hasdefault;
2929sub hasdefault { shift->{'hasdefault'} }
2930sub netrc { shift->{'netrc'} }
2931sub protected { shift->{'protected'} }
2932sub contains {
2933 my($self,$mach) = @_;
2934 for ( @{$self->{'mach'}} ) {
2935 return 1 if $_ eq $mach;
2936 }
2937 return 0;
2938}
2939
2940package CPAN::Complete;
2941
2942sub gnu_cpl {
2943 my($text, $line, $start, $end) = @_;
2944 my(@perlret) = cpl($text, $line, $start);
2945 # find longest common match. Can anybody show me how to peruse
2946 # T::R::Gnu to have this done automatically? Seems expensive.
2947 return () unless @perlret;
2948 my($newtext) = $text;
2949 for (my $i = length($text)+1;;$i++) {
2950 last unless length($perlret[0]) && length($perlret[0]) >= $i;
2951 my $try = substr($perlret[0],0,$i);
2952 my @tries = grep {substr($_,0,$i) eq $try} @perlret;
2953 # warn "try[$try]tries[@tries]";
2954 if (@tries == @perlret) {
2955 $newtext = $try;
2956 } else {
2957 last;
2958 }
2959 }
2960 ($newtext,@perlret);
2961}
2962
2963#-> sub CPAN::Complete::cpl ;
2964sub cpl {
2965 my($word,$line,$pos) = @_;
2966 $word ||= "";
2967 $line ||= "";
2968 $pos ||= 0;
2969 CPAN->debug("word [$word] line[$line] pos[$pos]") if $CPAN::DEBUG;
2970 $line =~ s/^\s*//;
2971 if ($line =~ s/^(force\s*)//) {
2972 $pos -= length($1);
2973 }
2974 my @return;
2975 if ($pos == 0) {
2976 @return = grep /^$word/, @CPAN::Complete::COMMANDS;
2977 } elsif ( $line !~ /^[\!abcdghimorutl]/ ) {
2978 @return = ();
2979 } elsif ($line =~ /^(a|ls)\s/) {
2980 @return = cplx('CPAN::Author',uc($word));
2981 } elsif ($line =~ /^b\s/) {
2982 CPAN::Shell->local_bundles;
2983 @return = cplx('CPAN::Bundle',$word);
2984 } elsif ($line =~ /^d\s/) {
2985 @return = cplx('CPAN::Distribution',$word);
2986 } elsif ($line =~ m/^(
2987 [mru]|make|clean|dump|get|test|install|readme|look|cvs_import
2988 )\s/x ) {
2989 if ($word =~ /^Bundle::/) {
2990 CPAN::Shell->local_bundles;
2991 }
2992 @return = (cplx('CPAN::Module',$word),cplx('CPAN::Bundle',$word));
2993 } elsif ($line =~ /^i\s/) {
2994 @return = cpl_any($word);
2995 } elsif ($line =~ /^reload\s/) {
2996 @return = cpl_reload($word,$line,$pos);
2997 } elsif ($line =~ /^o\s/) {
2998 @return = cpl_option($word,$line,$pos);
2999 } elsif ($line =~ m/^\S+\s/ ) {
3000 # fallback for future commands and what we have forgotten above
3001 @return = (cplx('CPAN::Module',$word),cplx('CPAN::Bundle',$word));
3002 } else {
3003 @return = ();
3004 }
3005 return @return;
3006}
3007
3008#-> sub CPAN::Complete::cplx ;
3009sub cplx {
3010 my($class, $word) = @_;
3011 # I believed for many years that this was sorted, today I
3012 # realized, it wasn't sorted anymore. Now (rev 1.301 / v 1.55) I
3013 # make it sorted again. Maybe sort was dropped when GNU-readline
3014 # support came in? The RCS file is difficult to read on that:-(
3015 sort grep /^\Q$word\E/, map { $_->id } $CPAN::META->all_objects($class);
3016}
3017
3018#-> sub CPAN::Complete::cpl_any ;
3019sub cpl_any {
3020 my($word) = shift;
3021 return (
3022 cplx('CPAN::Author',$word),
3023 cplx('CPAN::Bundle',$word),
3024 cplx('CPAN::Distribution',$word),
3025 cplx('CPAN::Module',$word),
3026 );
3027}
3028
3029#-> sub CPAN::Complete::cpl_reload ;
3030sub cpl_reload {
3031 my($word,$line,$pos) = @_;
3032 $word ||= "";
3033 my(@words) = split " ", $line;
3034 CPAN->debug("word[$word] line[$line] pos[$pos]") if $CPAN::DEBUG;
3035 my(@ok) = qw(cpan index);
3036 return @ok if @words == 1;
3037 return grep /^\Q$word\E/, @ok if @words == 2 && $word;
3038}
3039
3040#-> sub CPAN::Complete::cpl_option ;
3041sub cpl_option {
3042 my($word,$line,$pos) = @_;
3043 $word ||= "";
3044 my(@words) = split " ", $line;
3045 CPAN->debug("word[$word] line[$line] pos[$pos]") if $CPAN::DEBUG;
3046 my(@ok) = qw(conf debug);
3047 return @ok if @words == 1;
3048 return grep /^\Q$word\E/, @ok if @words == 2 && length($word);
3049 if (0) {
3050 } elsif ($words[1] eq 'index') {
3051 return ();
3052 } elsif ($words[1] eq 'conf') {
3053 return CPAN::Config::cpl(@_);
3054 } elsif ($words[1] eq 'debug') {
3055 return sort grep /^\Q$word\E/, sort keys %CPAN::DEBUG, 'all';
3056 }
3057}
3058
3059package CPAN::Index;
3060
3061#-> sub CPAN::Index::force_reload ;
3062sub force_reload {
3063 my($class) = @_;
3064 $CPAN::Index::LAST_TIME = 0;
3065 $class->reload(1);
3066}
3067
3068#-> sub CPAN::Index::reload ;
3069sub reload {
3070 my($cl,$force) = @_;
3071 my $time = time;
3072
3073 # XXX check if a newer one is available. (We currently read it
3074 # from time to time)
3075 for ($CPAN::Config->{index_expire}) {
3076 $_ = 0.001 unless $_ && $_ > 0.001;
3077 }
3078 unless (1 || $CPAN::Have_warned->{readmetadatacache}++) {
3079 # debug here when CPAN doesn't seem to read the Metadata
3080 require Carp;
3081 Carp::cluck("META-PROTOCOL[$CPAN::META->{PROTOCOL}]");
3082 }
3083 unless ($CPAN::META->{PROTOCOL}) {
3084 $cl->read_metadata_cache;
3085 $CPAN::META->{PROTOCOL} ||= "1.0";
3086 }
3087 if ( $CPAN::META->{PROTOCOL} < PROTOCOL ) {
3088 # warn "Setting last_time to 0";
3089 $LAST_TIME = 0; # No warning necessary
3090 }
3091 return if $LAST_TIME + $CPAN::Config->{index_expire}*86400 > $time
3092 and ! $force;
3093 if (0) {
3094 # IFF we are developing, it helps to wipe out the memory
3095 # between reloads, otherwise it is not what a user expects.
3096 undef $CPAN::META; # Neue Gruendlichkeit since v1.52(r1.274)
3097 $CPAN::META = CPAN->new;
3098 }
3099 {
3100 my($debug,$t2);
3101 local $LAST_TIME = $time;
3102 local $CPAN::META->{PROTOCOL} = PROTOCOL;
3103
3104 my $needshort = $^O eq "dos";
3105
3106 $cl->rd_authindex($cl
3107 ->reload_x(
3108 "authors/01mailrc.txt.gz",
3109 $needshort ?
3110 File::Spec->catfile('authors', '01mailrc.gz') :
3111 File::Spec->catfile('authors', '01mailrc.txt.gz'),
3112 $force));
3113 $t2 = time;
3114 $debug = "timing reading 01[".($t2 - $time)."]";
3115 $time = $t2;
3116 return if $CPAN::Signal; # this is sometimes lengthy
3117 $cl->rd_modpacks($cl
3118 ->reload_x(
3119 "modules/02packages.details.txt.gz",
3120 $needshort ?
3121 File::Spec->catfile('modules', '02packag.gz') :
3122 File::Spec->catfile('modules', '02packages.details.txt.gz'),
3123 $force));
3124 $t2 = time;
3125 $debug .= "02[".($t2 - $time)."]";
3126 $time = $t2;
3127 return if $CPAN::Signal; # this is sometimes lengthy
3128 $cl->rd_modlist($cl
3129 ->reload_x(
3130 "modules/03modlist.data.gz",
3131 $needshort ?
3132 File::Spec->catfile('modules', '03mlist.gz') :
3133 File::Spec->catfile('modules', '03modlist.data.gz'),
3134 $force));
3135 $cl->write_metadata_cache;
3136 $t2 = time;
3137 $debug .= "03[".($t2 - $time)."]";
3138 $time = $t2;
3139 CPAN->debug($debug) if $CPAN::DEBUG;
3140 }
3141 $LAST_TIME = $time;
3142 $CPAN::META->{PROTOCOL} = PROTOCOL;
3143}
3144
3145#-> sub CPAN::Index::reload_x ;
3146sub reload_x {
3147 my($cl,$wanted,$localname,$force) = @_;
3148 $force |= 2; # means we're dealing with an index here
3149 CPAN::Config->load; # we should guarantee loading wherever we rely
3150 # on Config XXX
3151 $localname ||= $wanted;
3152 my $abs_wanted = File::Spec->catfile($CPAN::Config->{'keep_source_where'},
3153 $localname);
3154 if (
3155 -f $abs_wanted &&
3156 -M $abs_wanted < $CPAN::Config->{'index_expire'} &&
3157 !($force & 1)
3158 ) {
3159 my $s = $CPAN::Config->{'index_expire'} == 1 ? "" : "s";
3160 $cl->debug(qq{$abs_wanted younger than $CPAN::Config->{'index_expire'} }.
3161 qq{day$s. I\'ll use that.});
3162 return $abs_wanted;
3163 } else {
3164 $force |= 1; # means we're quite serious about it.
3165 }
3166 return CPAN::FTP->localize($wanted,$abs_wanted,$force);
3167}
3168
3169#-> sub CPAN::Index::rd_authindex ;
3170sub rd_authindex {
3171 my($cl, $index_target) = @_;
3172 my @lines;
3173 return unless defined $index_target;
3174 $CPAN::Frontend->myprint("Going to read $index_target\n");
3175 local(*FH);
3176 tie *FH, CPAN::Tarzip, $index_target;
3177 local($/) = "\n";
3178 push @lines, split /\012/ while <FH>;
3179 foreach (@lines) {
3180 my($userid,$fullname,$email) =
3181 m/alias\s+(\S+)\s+\"([^\"\<]+)\s+\<([^\>]+)\>\"/;
3182 next unless $userid && $fullname && $email;
3183
3184 # instantiate an author object
3185 my $userobj = $CPAN::META->instance('CPAN::Author',$userid);
3186 $userobj->set('FULLNAME' => $fullname, 'EMAIL' => $email);
3187 return if $CPAN::Signal;
3188 }
3189}
3190
3191sub userid {
3192 my($self,$dist) = @_;
3193 $dist = $self->{'id'} unless defined $dist;
3194 my($ret) = $dist =~ m|(?:\w/\w\w/)?([^/]+)/|;
3195 $ret;
3196}
3197
3198#-> sub CPAN::Index::rd_modpacks ;
3199sub rd_modpacks {
3200 my($self, $index_target) = @_;
3201 my @lines;
3202 return unless defined $index_target;
3203 $CPAN::Frontend->myprint("Going to read $index_target\n");
3204 my $fh = CPAN::Tarzip->TIEHANDLE($index_target);
3205 local($/) = "\n";
3206 while ($_ = $fh->READLINE) {
3207 s/\012/\n/g;
3208 my @ls = map {"$_\n"} split /\n/, $_;
3209 unshift @ls, "\n" x length($1) if /^(\n+)/;
3210 push @lines, @ls;
3211 }
3212 # read header
3213 my($line_count,$last_updated);
3214 while (@lines) {
3215 my $shift = shift(@lines);
3216 last if $shift =~ /^\s*$/;
3217 $shift =~ /^Line-Count:\s+(\d+)/ and $line_count = $1;
3218 $shift =~ /^Last-Updated:\s+(.+)/ and $last_updated = $1;
3219 }
3220 if (not defined $line_count) {
3221
3222 warn qq{Warning: Your $index_target does not contain a Line-Count header.
3223Please check the validity of the index file by comparing it to more
3224than one CPAN mirror. I'll continue but problems seem likely to
3225happen.\a
3226};
3227
3228 sleep 5;
3229 } elsif ($line_count != scalar @lines) {
3230
3231 warn sprintf qq{Warning: Your %s
3232contains a Line-Count header of %d but I see %d lines there. Please
3233check the validity of the index file by comparing it to more than one
3234CPAN mirror. I'll continue but problems seem likely to happen.\a\n},
3235$index_target, $line_count, scalar(@lines);
3236
3237 }
3238 if (not defined $last_updated) {
3239
3240 warn qq{Warning: Your $index_target does not contain a Last-Updated header.
3241Please check the validity of the index file by comparing it to more
3242than one CPAN mirror. I'll continue but problems seem likely to
3243happen.\a
3244};
3245
3246 sleep 5;
3247 } else {
3248
3249 $CPAN::Frontend
3250 ->myprint(sprintf qq{ Database was generated on %s\n},
3251 $last_updated);
3252 $DATE_OF_02 = $last_updated;
3253
3254 if ($CPAN::META->has_inst(HTTP::Date)) {
3255 require HTTP::Date;
3256 my($age) = (time - HTTP::Date::str2time($last_updated))/3600/24;
3257 if ($age > 30) {
3258
3259 $CPAN::Frontend
3260 ->mywarn(sprintf
3261 qq{Warning: This index file is %d days old.
3262 Please check the host you chose as your CPAN mirror for staleness.
3263 I'll continue but problems seem likely to happen.\a\n},
3264 $age);
3265
3266 }
3267 } else {
3268 $CPAN::Frontend->myprint(" HTTP::Date not available\n");
3269 }
3270 }
3271
3272
3273 # A necessity since we have metadata_cache: delete what isn't
3274 # there anymore
3275 my $secondtime = $CPAN::META->exists("CPAN::Module","CPAN");
3276 CPAN->debug("secondtime[$secondtime]") if $CPAN::DEBUG;
3277 my(%exists);
3278 foreach (@lines) {
3279 chomp;
3280 # before 1.56 we split into 3 and discarded the rest. From
3281 # 1.57 we assign remaining text to $comment thus allowing to
3282 # influence isa_perl
3283 my($mod,$version,$dist,$comment) = split " ", $_, 4;
3284 my($bundle,$id,$userid);
3285
3286 if ($mod eq 'CPAN' &&
3287 ! (
3288 CPAN::Queue->exists('Bundle::CPAN') ||
3289 CPAN::Queue->exists('CPAN')
3290 )
3291 ) {
3292 local($^W)= 0;
3293 if ($version > $CPAN::VERSION){
3294 $CPAN::Frontend->myprint(qq{
3295 There's a new CPAN.pm version (v$version) available!
3296 [Current version is v$CPAN::VERSION]
3297 You might want to try
3298 install Bundle::CPAN
3299 reload cpan
3300 without quitting the current session. It should be a seamless upgrade
3301 while we are running...
3302}); #});
3303 sleep 2;
3304 $CPAN::Frontend->myprint(qq{\n});
3305 }
3306 last if $CPAN::Signal;
3307 } elsif ($mod =~ /^Bundle::(.*)/) {
3308 $bundle = $1;
3309 }
3310
3311 if ($bundle){
3312 $id = $CPAN::META->instance('CPAN::Bundle',$mod);
3313 # Let's make it a module too, because bundles have so much
3314 # in common with modules.
3315
3316 # Changed in 1.57_63: seems like memory bloat now without
3317 # any value, so commented out
3318
3319 # $CPAN::META->instance('CPAN::Module',$mod);
3320
3321 } else {
3322
3323 # instantiate a module object
3324 $id = $CPAN::META->instance('CPAN::Module',$mod);
3325
3326 }
3327
3328 if ($id->cpan_file ne $dist){ # update only if file is
3329 # different. CPAN prohibits same
3330 # name with different version
3331 $userid = $id->userid || $self->userid($dist);
3332 $id->set(
3333 'CPAN_USERID' => $userid,
3334 'CPAN_VERSION' => $version,
3335 'CPAN_FILE' => $dist,
3336 );
3337 }
3338
3339 # instantiate a distribution object
3340 if ($CPAN::META->exists('CPAN::Distribution',$dist)) {
3341 # we do not need CONTAINSMODS unless we do something with
3342 # this dist, so we better produce it on demand.
3343
3344 ## my $obj = $CPAN::META->instance(
3345 ## 'CPAN::Distribution' => $dist
3346 ## );
3347 ## $obj->{CONTAINSMODS}{$mod} = undef; # experimental
3348 } else {
3349 $CPAN::META->instance(
3350 'CPAN::Distribution' => $dist
3351 )->set(
3352 'CPAN_USERID' => $userid,
3353 'CPAN_COMMENT' => $comment,
3354 );
3355 }
3356 if ($secondtime) {
3357 for my $name ($mod,$dist) {
3358 CPAN->debug("exists name[$name]") if $CPAN::DEBUG;
3359 $exists{$name} = undef;
3360 }
3361 }
3362 return if $CPAN::Signal;
3363 }
3364 undef $fh;
3365 if ($secondtime) {
3366 for my $class (qw(CPAN::Module CPAN::Bundle CPAN::Distribution)) {
3367 for my $o ($CPAN::META->all_objects($class)) {
3368 next if exists $exists{$o->{ID}};
3369 $CPAN::META->delete($class,$o->{ID});
3370 CPAN->debug("deleting ID[$o->{ID}] in class[$class]")
3371 if $CPAN::DEBUG;
3372 }
3373 }
3374 }
3375}
3376
3377#-> sub CPAN::Index::rd_modlist ;
3378sub rd_modlist {
3379 my($cl,$index_target) = @_;
3380 return unless defined $index_target;
3381 $CPAN::Frontend->myprint("Going to read $index_target\n");
3382 my $fh = CPAN::Tarzip->TIEHANDLE($index_target);
3383 my @eval;
3384 local($/) = "\n";
3385 while ($_ = $fh->READLINE) {
3386 s/\012/\n/g;
3387 my @ls = map {"$_\n"} split /\n/, $_;
3388 unshift @ls, "\n" x length($1) if /^(\n+)/;
3389 push @eval, @ls;
3390 }
3391 while (@eval) {
3392 my $shift = shift(@eval);
3393 if ($shift =~ /^Date:\s+(.*)/){
3394 return if $DATE_OF_03 eq $1;
3395 ($DATE_OF_03) = $1;
3396 }
3397 last if $shift =~ /^\s*$/;
3398 }
3399 undef $fh;
3400 push @eval, q{CPAN::Modulelist->data;};
3401 local($^W) = 0;
3402 my($comp) = Safe->new("CPAN::Safe1");
3403 my($eval) = join("", @eval);
3404 my $ret = $comp->reval($eval);
3405 Carp::confess($@) if $@;
3406 return if $CPAN::Signal;
3407 for (keys %$ret) {
3408 my $obj = $CPAN::META->instance("CPAN::Module",$_);
3409 delete $ret->{$_}{modid}; # not needed here, maybe elsewhere
3410 $obj->set(%{$ret->{$_}});
3411 return if $CPAN::Signal;
3412 }
3413}
3414
3415#-> sub CPAN::Index::write_metadata_cache ;
3416sub write_metadata_cache {
3417 my($self) = @_;
3418 return unless $CPAN::Config->{'cache_metadata'};
3419 return unless $CPAN::META->has_usable("Storable");
3420 my $cache;
3421 foreach my $k (qw(CPAN::Bundle CPAN::Author CPAN::Module
3422 CPAN::Distribution)) {
3423 $cache->{$k} = $CPAN::META->{readonly}{$k}; # unsafe meta access, ok
3424 }
3425 my $metadata_file = File::Spec->catfile($CPAN::Config->{cpan_home},"Metadata");
3426 $cache->{last_time} = $LAST_TIME;
3427 $cache->{DATE_OF_02} = $DATE_OF_02;
3428 $cache->{PROTOCOL} = PROTOCOL;
3429 $CPAN::Frontend->myprint("Going to write $metadata_file\n");
3430 eval { Storable::nstore($cache, $metadata_file) };
3431 $CPAN::Frontend->mywarn($@) if $@; # ?? missing "\n" after $@ in mywarn ??
3432}
3433
3434#-> sub CPAN::Index::read_metadata_cache ;
3435sub read_metadata_cache {
3436 my($self) = @_;
3437 return unless $CPAN::Config->{'cache_metadata'};
3438 return unless $CPAN::META->has_usable("Storable");
3439 my $metadata_file = File::Spec->catfile($CPAN::Config->{cpan_home},"Metadata");
3440 return unless -r $metadata_file and -f $metadata_file;
3441 $CPAN::Frontend->myprint("Going to read $metadata_file\n");
3442 my $cache;
3443 eval { $cache = Storable::retrieve($metadata_file) };
3444 $CPAN::Frontend->mywarn($@) if $@; # ?? missing "\n" after $@ in mywarn ??
3445 if (!$cache || ref $cache ne 'HASH'){
3446 $LAST_TIME = 0;
3447 return;
3448 }
3449 if (exists $cache->{PROTOCOL}) {
3450 if (PROTOCOL > $cache->{PROTOCOL}) {
3451 $CPAN::Frontend->mywarn(sprintf("Ignoring Metadata cache written ".
3452 "with protocol v%s, requiring v%s\n",
3453 $cache->{PROTOCOL},
3454 PROTOCOL)
3455 );
3456 return;
3457 }
3458 } else {
3459 $CPAN::Frontend->mywarn("Ignoring Metadata cache written ".
3460 "with protocol v1.0\n");
3461 return;
3462 }
3463 my $clcnt = 0;
3464 my $idcnt = 0;
3465 while(my($class,$v) = each %$cache) {
3466 next unless $class =~ /^CPAN::/;
3467 $CPAN::META->{readonly}{$class} = $v; # unsafe meta access, ok
3468 while (my($id,$ro) = each %$v) {
3469 $CPAN::META->{readwrite}{$class}{$id} ||=
3470 $class->new(ID=>$id, RO=>$ro);
3471 $idcnt++;
3472 }
3473 $clcnt++;
3474 }
3475 unless ($clcnt) { # sanity check
3476 $CPAN::Frontend->myprint("Warning: Found no data in $metadata_file\n");
3477 return;
3478 }
3479 if ($idcnt < 1000) {
3480 $CPAN::Frontend->myprint("Warning: Found only $idcnt objects ".
3481 "in $metadata_file\n");
3482 return;
3483 }
3484 $CPAN::META->{PROTOCOL} ||=
3485 $cache->{PROTOCOL}; # reading does not up or downgrade, but it
3486 # does initialize to some protocol
3487 $LAST_TIME = $cache->{last_time};
3488 $DATE_OF_02 = $cache->{DATE_OF_02};
3489 $CPAN::Frontend->myprint(" Database was generated on $DATE_OF_02\n")
3490 if defined $DATE_OF_02; # An old cache may not contain DATE_OF_02
3491 return;
3492}
3493
3494package CPAN::InfoObj;
3495
3496# Accessors
3497sub cpan_userid {
3498 my $self = shift;
3499 $self->{RO}{CPAN_USERID}
3500}
3501
3502sub id { shift->{ID}; }
3503
3504#-> sub CPAN::InfoObj::new ;
3505sub new {
3506 my $this = bless {}, shift;
3507 %$this = @_;
3508 $this
3509}
3510
3511# The set method may only be used by code that reads index data or
3512# otherwise "objective" data from the outside world. All session
3513# related material may do anything else with instance variables but
3514# must not touch the hash under the RO attribute. The reason is that
3515# the RO hash gets written to Metadata file and is thus persistent.
3516
3517#-> sub CPAN::InfoObj::set ;
3518sub set {
3519 my($self,%att) = @_;
3520 my $class = ref $self;
3521
3522 # This must be ||=, not ||, because only if we write an empty
3523 # reference, only then the set method will write into the readonly
3524 # area. But for Distributions that spring into existence, maybe
3525 # because of a typo, we do not like it that they are written into
3526 # the readonly area and made permanent (at least for a while) and
3527 # that is why we do not "allow" other places to call ->set.
3528 unless ($self->id) {
3529 CPAN->debug("Bug? Empty ID, rejecting");
3530 return;
3531 }
3532 my $ro = $self->{RO} =
3533 $CPAN::META->{readonly}{$class}{$self->id} ||= {};
3534
3535 while (my($k,$v) = each %att) {
3536 $ro->{$k} = $v;
3537 }
3538}
3539
3540#-> sub CPAN::InfoObj::as_glimpse ;
3541sub as_glimpse {
3542 my($self) = @_;
3543 my(@m);
3544 my $class = ref($self);
3545 $class =~ s/^CPAN:://;
3546 push @m, sprintf "%-15s %s\n", $class, $self->{ID};
3547 join "", @m;
3548}
3549
3550#-> sub CPAN::InfoObj::as_string ;
3551sub as_string {
3552 my($self) = @_;
3553 my(@m);
3554 my $class = ref($self);
3555 $class =~ s/^CPAN:://;
3556 push @m, $class, " id = $self->{ID}\n";
3557 for (sort keys %{$self->{RO}}) {
3558 # next if m/^(ID|RO)$/;
3559 my $extra = "";
3560 if ($_ eq "CPAN_USERID") {
3561 $extra .= " (".$self->author;
3562 my $email; # old perls!
3563 if ($email = $CPAN::META->instance("CPAN::Author",
3564 $self->cpan_userid
3565 )->email) {
3566 $extra .= " <$email>";
3567 } else {
3568 $extra .= " <no email>";
3569 }
3570 $extra .= ")";
3571 } elsif ($_ eq "FULLNAME") { # potential UTF-8 conversion
3572 push @m, sprintf " %-12s %s\n", $_, $self->fullname;
3573 next;
3574 }
3575 next unless defined $self->{RO}{$_};
3576 push @m, sprintf " %-12s %s%s\n", $_, $self->{RO}{$_}, $extra;
3577 }
3578 for (sort keys %$self) {
3579 next if m/^(ID|RO)$/;
3580 if (ref($self->{$_}) eq "ARRAY") {
3581 push @m, sprintf " %-12s %s\n", $_, "@{$self->{$_}}";
3582 } elsif (ref($self->{$_}) eq "HASH") {
3583 push @m, sprintf(
3584 " %-12s %s\n",
3585 $_,
3586 join(" ",keys %{$self->{$_}}),
3587 );
3588 } else {
3589 push @m, sprintf " %-12s %s\n", $_, $self->{$_};
3590 }
3591 }
3592 join "", @m, "\n";
3593}
3594
3595#-> sub CPAN::InfoObj::author ;
3596sub author {
3597 my($self) = @_;
3598 $CPAN::META->instance("CPAN::Author",$self->cpan_userid)->fullname;
3599}
3600
3601#-> sub CPAN::InfoObj::dump ;
3602sub dump {
3603 my($self) = @_;
3604 require Data::Dumper;
3605 print Data::Dumper::Dumper($self);
3606}
3607
3608package CPAN::Author;
3609
3610#-> sub CPAN::Author::id
3611sub id {
3612 my $self = shift;
3613 my $id = $self->{ID};
3614 $CPAN::Frontend->mydie("Illegal author id[$id]") unless $id =~ /^[A-Z]/;
3615 $id;
3616}
3617
3618#-> sub CPAN::Author::as_glimpse ;
3619sub as_glimpse {
3620 my($self) = @_;
3621 my(@m);
3622 my $class = ref($self);
3623 $class =~ s/^CPAN:://;
3624 push @m, sprintf(qq{%-15s %s ("%s" <%s>)\n},
3625 $class,
3626 $self->{ID},
3627 $self->fullname,
3628 $self->email);
3629 join "", @m;
3630}
3631
3632#-> sub CPAN::Author::fullname ;
3633sub fullname {
3634 shift->{RO}{FULLNAME};
3635}
3636*name = \&fullname;
3637
3638#-> sub CPAN::Author::email ;
3639sub email { shift->{RO}{EMAIL}; }
3640
3641#-> sub CPAN::Author::ls ;
3642sub ls {
3643 my $self = shift;
3644 my $id = $self->id;
3645
3646 # adapted from CPAN::Distribution::verifyMD5 ;
3647 my(@csf); # chksumfile
3648 @csf = $self->id =~ /(.)(.)(.*)/;
3649 $csf[1] = join "", @csf[0,1];
3650 $csf[2] = join "", @csf[1,2];
3651 my(@dl);
3652 @dl = $self->dir_listing([$csf[0],"CHECKSUMS"], 0);
3653 unless (grep {$_->[2] eq $csf[1]} @dl) {
3654 $CPAN::Frontend->myprint("No files in the directory of $id\n");
3655 return;
3656 }
3657 @dl = $self->dir_listing([@csf[0,1],"CHECKSUMS"], 0);
3658 unless (grep {$_->[2] eq $csf[2]} @dl) {
3659 $CPAN::Frontend->myprint("No files in the directory of $id\n");
3660 return;
3661 }
3662 @dl = $self->dir_listing([@csf,"CHECKSUMS"], 1);
3663 $CPAN::Frontend->myprint(join "", map {
3664 sprintf("%8d %10s %s/%s\n", $_->[0], $_->[1], $id, $_->[2])
3665 } sort { $a->[2] cmp $b->[2] } @dl);
3666}
3667
3668# returns an array of arrays, the latter contain (size,mtime,filename)
3669#-> sub CPAN::Author::dir_listing ;
3670sub dir_listing {
3671 my $self = shift;
3672 my $chksumfile = shift;
3673 my $recursive = shift;
3674 my $lc_want =
3675 File::Spec->catfile($CPAN::Config->{keep_source_where},
3676 "authors", "id", @$chksumfile);
3677 local($") = "/";
3678 # connect "force" argument with "index_expire".
3679 my $force = 0;
3680 if (my @stat = stat $lc_want) {
3681 $force = $stat[9] + $CPAN::Config->{index_expire}*86400 <= time;
3682 }
3683 my $lc_file = CPAN::FTP->localize("authors/id/@$chksumfile",
3684 $lc_want,$force);
3685 unless ($lc_file) {
3686 $CPAN::Frontend->myprint("Trying $lc_want.gz\n");
3687 $chksumfile->[-1] .= ".gz";
3688 $lc_file = CPAN::FTP->localize("authors/id/@$chksumfile",
3689 "$lc_want.gz",1);
3690 if ($lc_file) {
3691 $lc_file =~ s{\.gz(?!\n)\Z}{}; #};
3692 CPAN::Tarzip->gunzip("$lc_file.gz",$lc_file);
3693 } else {
3694 return;
3695 }
3696 }
3697
3698 # adapted from CPAN::Distribution::MD5_check_file ;
3699 my $fh = FileHandle->new;
3700 my($cksum);
3701 if (open $fh, $lc_file){
3702 local($/);
3703 my $eval = <$fh>;
3704 $eval =~ s/\015?\012/\n/g;
3705 close $fh;
3706 my($comp) = Safe->new();
3707 $cksum = $comp->reval($eval);
3708 if ($@) {
3709 rename $lc_file, "$lc_file.bad";
3710 Carp::confess($@) if $@;
3711 }
3712 } else {
3713 Carp::carp "Could not open $lc_file for reading";
3714 }
3715 my(@result,$f);
3716 for $f (sort keys %$cksum) {
3717 if (exists $cksum->{$f}{isdir}) {
3718 if ($recursive) {
3719 my(@dir) = @$chksumfile;
3720 pop @dir;
3721 push @dir, $f, "CHECKSUMS";
3722 push @result, map {
3723 [$_->[0], $_->[1], "$f/$_->[2]"]
3724 } $self->dir_listing(\@dir,1);
3725 } else {
3726 push @result, [ 0, "-", $f ];
3727 }
3728 } else {
3729 push @result, [
3730 ($cksum->{$f}{"size"}||0),
3731 $cksum->{$f}{"mtime"}||"---",
3732 $f
3733 ];
3734 }
3735 }
3736 @result;
3737}
3738
3739package CPAN::Distribution;
3740
3741# Accessors
3742sub cpan_comment { shift->{RO}{CPAN_COMMENT} }
3743
3744sub undelay {
3745 my $self = shift;
3746 delete $self->{later};
3747}
3748
3749# CPAN::Distribution::normalize
3750sub normalize {
3751 my($self,$s) = @_;
3752 $s = $self->id unless defined $s;
3753 if (
3754 $s =~ tr|/|| == 1
3755 or
3756 $s !~ m|[A-Z]/[A-Z-]{2}/[A-Z-]{2,}/|
3757 ) {
3758 return $s if $s =~ m:^N/A|^Contact Author: ;
3759 $s =~ s|^(.)(.)([^/]*/)(.+)$|$1/$1$2/$1$2$3$4| or
3760 $CPAN::Frontend->mywarn("Strange distribution name [$s]\n");
3761 CPAN->debug("s[$s]") if $CPAN::DEBUG;
3762 }
3763 $s;
3764}
3765
3766#-> sub CPAN::Distribution::color_cmd_tmps ;
3767sub color_cmd_tmps {
3768 my($self) = shift;
3769 my($depth) = shift || 0;
3770 my($color) = shift || 0;
3771 my($ancestors) = shift || [];
3772 # a distribution needs to recurse into its prereq_pms
3773
3774 return if exists $self->{incommandcolor}
3775 && $self->{incommandcolor}==$color;
3776 if ($depth>=100){
3777 $CPAN::Frontend->mydie(CPAN::Exception::RecursiveDependency->new($ancestors));
3778 }
3779 # warn "color_cmd_tmps $depth $color " . $self->id; # sleep 1;
3780 my $prereq_pm = $self->prereq_pm;
3781 if (defined $prereq_pm) {
3782 for my $pre (keys %$prereq_pm) {
3783 my $premo = CPAN::Shell->expand("Module",$pre);
3784 $premo->color_cmd_tmps($depth+1,$color,[@$ancestors, $self->id]);
3785 }
3786 }
3787 if ($color==0) {
3788 delete $self->{sponsored_mods};
3789 delete $self->{badtestcnt};
3790 }
3791 $self->{incommandcolor} = $color;
3792}
3793
3794#-> sub CPAN::Distribution::as_string ;
3795sub as_string {
3796 my $self = shift;
3797 $self->containsmods;
3798 $self->SUPER::as_string(@_);
3799}
3800
3801#-> sub CPAN::Distribution::containsmods ;
3802sub containsmods {
3803 my $self = shift;
3804 return keys %{$self->{CONTAINSMODS}} if exists $self->{CONTAINSMODS};
3805 my $dist_id = $self->{ID};
3806 for my $mod ($CPAN::META->all_objects("CPAN::Module")) {
3807 my $mod_file = $mod->cpan_file or next;
3808 my $mod_id = $mod->{ID} or next;
3809 # warn "mod_file[$mod_file] dist_id[$dist_id] mod_id[$mod_id]";
3810 # sleep 1;
3811 $self->{CONTAINSMODS}{$mod_id} = undef if $mod_file eq $dist_id;
3812 }
3813 keys %{$self->{CONTAINSMODS}};
3814}
3815
3816#-> sub CPAN::Distribution::uptodate ;
3817sub uptodate {
3818 my($self) = @_;
3819 my $c;
3820 foreach $c ($self->containsmods) {
3821 my $obj = CPAN::Shell->expandany($c);
3822 return 0 unless $obj->uptodate;
3823 }
3824 return 1;
3825}
3826
3827#-> sub CPAN::Distribution::called_for ;
3828sub called_for {
3829 my($self,$id) = @_;
3830 $self->{CALLED_FOR} = $id if defined $id;
3831 return $self->{CALLED_FOR};
3832}
3833
3834#-> sub CPAN::Distribution::safe_chdir ;
3835sub safe_chdir {
3836 my($self,$todir) = @_;
3837 # we die if we cannot chdir and we are debuggable
3838 Carp::confess("safe_chdir called without todir argument")
3839 unless defined $todir and length $todir;
3840 if (chdir $todir) {
3841 $self->debug(sprintf "changed directory to %s", CPAN::anycwd())
3842 if $CPAN::DEBUG;
3843 } else {
3844 my $cwd = CPAN::anycwd();
3845 $CPAN::Frontend->mydie(qq{Could not chdir from cwd[$cwd] }.
3846 qq{to todir[$todir]: $!});
3847 }
3848}
3849
3850#-> sub CPAN::Distribution::get ;
3851sub get {
3852 my($self) = @_;
3853 EXCUSE: {
3854 my @e;
3855 exists $self->{'build_dir'} and push @e,
3856 "Is already unwrapped into directory $self->{'build_dir'}";
3857 $CPAN::Frontend->myprint(join "", map {" $_\n"} @e) and return if @e;
3858 }
3859 my $sub_wd = CPAN::anycwd(); # for cleaning up as good as possible
3860
3861 #
3862 # Get the file on local disk
3863 #
3864
3865 my($local_file);
3866 my($local_wanted) =
3867 File::Spec->catfile(
3868 $CPAN::Config->{keep_source_where},
3869 "authors",
3870 "id",
3871 split(/\//,$self->id)
3872 );
3873
3874 $self->debug("Doing localize") if $CPAN::DEBUG;
3875 unless ($local_file =
3876 CPAN::FTP->localize("authors/id/$self->{ID}",
3877 $local_wanted)) {
3878 my $note = "";
3879 if ($CPAN::Index::DATE_OF_02) {
3880 $note = "Note: Current database in memory was generated ".
3881 "on $CPAN::Index::DATE_OF_02\n";
3882 }
3883 $CPAN::Frontend->mydie("Giving up on '$local_wanted'\n$note");
3884 }
3885 $self->debug("local_file[$local_file]") if $CPAN::DEBUG;
3886 $self->{localfile} = $local_file;
3887 return if $CPAN::Signal;
3888
3889 #
3890 # Check integrity
3891 #
3892 if ($CPAN::META->has_inst("Digest::MD5")) {
3893 $self->debug("Digest::MD5 is installed, verifying");
3894 $self->verifyMD5;
3895 } else {
3896 $self->debug("Digest::MD5 is NOT installed");
3897 }
3898 return if $CPAN::Signal;
3899
3900 #
3901 # Create a clean room and go there
3902 #
3903 $CPAN::META->{cachemgr} ||= CPAN::CacheMgr->new(); # unsafe meta access, ok
3904 my $builddir = $CPAN::META->{cachemgr}->dir; # unsafe meta access, ok
3905 $self->safe_chdir($builddir);
3906 $self->debug("Removing tmp") if $CPAN::DEBUG;
3907 File::Path::rmtree("tmp");
3908 mkdir "tmp", 0755 or Carp::croak "Couldn't mkdir tmp: $!";
3909 if ($CPAN::Signal){
3910 $self->safe_chdir($sub_wd);
3911 return;
3912 }
3913 $self->safe_chdir("tmp");
3914
3915 #
3916 # Unpack the goods
3917 #
3918 if ($local_file =~ /(\.tar\.(gz|Z)|\.tgz)(?!\n)\Z/i){
3919 $self->{was_uncompressed}++ unless CPAN::Tarzip->gtest($local_file);
3920 $self->untar_me($local_file);
3921 } elsif ( $local_file =~ /\.zip(?!\n)\Z/i ) {
3922 $self->unzip_me($local_file);
3923 } elsif ( $local_file =~ /\.pm\.(gz|Z)(?!\n)\Z/) {
3924 $self->{was_uncompressed}++ unless CPAN::Tarzip->gtest($local_file);
3925 $self->pm2dir_me($local_file);
3926 } else {
3927 $self->{archived} = "NO";
3928 $self->safe_chdir($sub_wd);
3929 return;
3930 }
3931
3932 # we are still in the tmp directory!
3933 # Let's check if the package has its own directory.
3934 my $dh = DirHandle->new(File::Spec->curdir)
3935 or Carp::croak("Couldn't opendir .: $!");
3936 my @readdir = grep $_ !~ /^\.\.?(?!\n)\Z/s, $dh->read; ### MAC??
3937 $dh->close;
3938 my ($distdir,$packagedir);
3939 if (@readdir == 1 && -d $readdir[0]) {
3940 $distdir = $readdir[0];
3941 $packagedir = File::Spec->catdir($builddir,$distdir);
3942 $self->debug("packagedir[$packagedir]builddir[$builddir]distdir[$distdir]")
3943 if $CPAN::DEBUG;
3944 -d $packagedir and $CPAN::Frontend->myprint("Removing previously used ".
3945 "$packagedir\n");
3946 File::Path::rmtree($packagedir);
3947 rename($distdir,$packagedir) or
3948 Carp::confess("Couldn't rename $distdir to $packagedir: $!");
3949 $self->debug(sprintf("renamed distdir[%s] to packagedir[%s] -e[%s]-d[%s]",
3950 $distdir,
3951 $packagedir,
3952 -e $packagedir,
3953 -d $packagedir,
3954 )) if $CPAN::DEBUG;
3955 } else {
3956 my $userid = $self->cpan_userid;
3957 unless ($userid) {
3958 CPAN->debug("no userid? self[$self]");
3959 $userid = "anon";
3960 }
3961 my $pragmatic_dir = $userid . '000';
3962 $pragmatic_dir =~ s/\W_//g;
3963 $pragmatic_dir++ while -d "../$pragmatic_dir";
3964 $packagedir = File::Spec->catdir($builddir,$pragmatic_dir);
3965 $self->debug("packagedir[$packagedir]") if $CPAN::DEBUG;
3966 File::Path::mkpath($packagedir);
3967 my($f);
3968 for $f (@readdir) { # is already without "." and ".."
3969 my $to = File::Spec->catdir($packagedir,$f);
3970 rename($f,$to) or Carp::confess("Couldn't rename $f to $to: $!");
3971 }
3972 }
3973 if ($CPAN::Signal){
3974 $self->safe_chdir($sub_wd);
3975 return;
3976 }
3977
3978 $self->{'build_dir'} = $packagedir;
3979 $self->safe_chdir($builddir);
3980 File::Path::rmtree("tmp");
3981
3982 my($mpl) = File::Spec->catfile($packagedir,"Makefile.PL");
3983 my($mpl_exists) = -f $mpl;
3984 unless ($mpl_exists) {
3985 # NFS has been reported to have racing problems after the
3986 # renaming of a directory in some environments.
3987 # This trick helps.
3988 sleep 1;
3989 my $mpldh = DirHandle->new($packagedir)
3990 or Carp::croak("Couldn't opendir $packagedir: $!");
3991 $mpl_exists = grep /^Makefile\.PL$/, $mpldh->read;
3992 $mpldh->close;
3993 }
3994 unless ($mpl_exists) {
3995 $self->debug(sprintf("makefilepl[%s]anycwd[%s]",
3996 $mpl,
3997 CPAN::anycwd(),
3998 )) if $CPAN::DEBUG;
3999 my($configure) = File::Spec->catfile($packagedir,"Configure");
4000 if (-f $configure) {
4001 # do we have anything to do?
4002 $self->{'configure'} = $configure;
4003 } elsif (-f File::Spec->catfile($packagedir,"Makefile")) {
4004 $CPAN::Frontend->myprint(qq{
4005Package comes with a Makefile and without a Makefile.PL.
4006We\'ll try to build it with that Makefile then.
4007});
4008 $self->{writemakefile} = "YES";
4009 sleep 2;
4010 } else {
4011 my $cf = $self->called_for || "unknown";
4012 if ($cf =~ m|/|) {
4013 $cf =~ s|.*/||;
4014 $cf =~ s|\W.*||;
4015 }
4016 $cf =~ s|[/\\:]||g; # risk of filesystem damage
4017 $cf = "unknown" unless length($cf);
4018 $CPAN::Frontend->myprint(qq{Package seems to come without Makefile.PL.
4019 (The test -f "$mpl" returned false.)
4020 Writing one on our own (setting NAME to $cf)\a\n});
4021 $self->{had_no_makefile_pl}++;
4022 sleep 3;
4023
4024 # Writing our own Makefile.PL
4025
4026 my $fh = FileHandle->new;
4027 $fh->open(">$mpl")
4028 or Carp::croak("Could not open >$mpl: $!");
4029 $fh->print(
4030qq{# This Makefile.PL has been autogenerated by the module CPAN.pm
4031# because there was no Makefile.PL supplied.
4032# Autogenerated on: }.scalar localtime().qq{
4033
4034use ExtUtils::MakeMaker;
4035WriteMakefile(NAME => q[$cf]);
4036
4037});
4038 $fh->close;
4039 }
4040 }
4041
4042 return $self;
4043}
4044
4045# CPAN::Distribution::untar_me ;
4046sub untar_me {
4047 my($self,$local_file) = @_;
4048 $self->{archived} = "tar";
4049 if (CPAN::Tarzip->untar($local_file)) {
4050 $self->{unwrapped} = "YES";
4051 } else {
4052 $self->{unwrapped} = "NO";
4053 }
4054}
4055
4056# CPAN::Distribution::unzip_me ;
4057sub unzip_me {
4058 my($self,$local_file) = @_;
4059 $self->{archived} = "zip";
4060 if (CPAN::Tarzip->unzip($local_file)) {
4061 $self->{unwrapped} = "YES";
4062 } else {
4063 $self->{unwrapped} = "NO";
4064 }
4065 return;
4066}
4067
4068sub pm2dir_me {
4069 my($self,$local_file) = @_;
4070 $self->{archived} = "pm";
4071 my $to = File::Basename::basename($local_file);
4072 $to =~ s/\.(gz|Z)(?!\n)\Z//;
4073 if (CPAN::Tarzip->gunzip($local_file,$to)) {
4074 $self->{unwrapped} = "YES";
4075 } else {
4076 $self->{unwrapped} = "NO";
4077 }
4078}
4079
4080#-> sub CPAN::Distribution::new ;
4081sub new {
4082 my($class,%att) = @_;
4083
4084 # $CPAN::META->{cachemgr} ||= CPAN::CacheMgr->new();
4085
4086 my $this = { %att };
4087 return bless $this, $class;
4088}
4089
4090#-> sub CPAN::Distribution::look ;
4091sub look {
4092 my($self) = @_;
4093
4094 if ($^O eq 'MacOS') {
4095 $self->Mac::BuildTools::look;
4096 return;
4097 }
4098
4099 if ( $CPAN::Config->{'shell'} ) {
4100 $CPAN::Frontend->myprint(qq{
4101Trying to open a subshell in the build directory...
4102});
4103 } else {
4104 $CPAN::Frontend->myprint(qq{
4105Your configuration does not define a value for subshells.
4106Please define it with "o conf shell <your shell>"
4107});
4108 return;
4109 }
4110 my $dist = $self->id;
4111 my $dir;
4112 unless ($dir = $self->dir) {
4113 $self->get;
4114 }
4115 unless ($dir ||= $self->dir) {
4116 $CPAN::Frontend->mywarn(qq{
4117Could not determine which directory to use for looking at $dist.
4118});
4119 return;
4120 }
4121 my $pwd = CPAN::anycwd();
4122 $self->safe_chdir($dir);
4123 $CPAN::Frontend->myprint(qq{Working directory is $dir\n});
4124 unless (system($CPAN::Config->{'shell'}) == 0) {
4125 my $code = $? >> 8;
4126 $CPAN::Frontend->mywarn("Subprocess shell exit code $code\n");
4127 }
4128 $self->safe_chdir($pwd);
4129}
4130
4131# CPAN::Distribution::cvs_import ;
4132sub cvs_import {
4133 my($self) = @_;
4134 $self->get;
4135 my $dir = $self->dir;
4136
4137 my $package = $self->called_for;
4138 my $module = $CPAN::META->instance('CPAN::Module', $package);
4139 my $version = $module->cpan_version;
4140
4141 my $userid = $self->cpan_userid;
4142
4143 my $cvs_dir = (split /\//, $dir)[-1];
4144 $cvs_dir =~ s/-\d+[^-]+(?!\n)\Z//;
4145 my $cvs_root =
4146 $CPAN::Config->{cvsroot} || $ENV{CVSROOT};
4147 my $cvs_site_perl =
4148 $CPAN::Config->{cvs_site_perl} || $ENV{CVS_SITE_PERL};
4149 if ($cvs_site_perl) {
4150 $cvs_dir = "$cvs_site_perl/$cvs_dir";
4151 }
4152 my $cvs_log = qq{"imported $package $version sources"};
4153 $version =~ s/\./_/g;
4154 my @cmd = ('cvs', '-d', $cvs_root, 'import', '-m', $cvs_log,
4155 "$cvs_dir", $userid, "v$version");
4156
4157 my $pwd = CPAN::anycwd();
4158 chdir($dir) or $CPAN::Frontend->mydie(qq{Could not chdir to "$dir": $!});
4159
4160 $CPAN::Frontend->myprint(qq{Working directory is $dir\n});
4161
4162 $CPAN::Frontend->myprint(qq{@cmd\n});
4163 system(@cmd) == 0 or
4164 $CPAN::Frontend->mydie("cvs import failed");
4165 chdir($pwd) or $CPAN::Frontend->mydie(qq{Could not chdir to "$pwd": $!});
4166}
4167
4168#-> sub CPAN::Distribution::readme ;
4169sub readme {
4170 my($self) = @_;
4171 my($dist) = $self->id;
4172 my($sans,$suffix) = $dist =~ /(.+)\.(tgz|tar[\._-]gz|tar\.Z|zip)$/;
4173 $self->debug("sans[$sans] suffix[$suffix]\n") if $CPAN::DEBUG;
4174 my($local_file);
4175 my($local_wanted) =
4176 File::Spec->catfile(
4177 $CPAN::Config->{keep_source_where},
4178 "authors",
4179 "id",
4180 split(/\//,"$sans.readme"),
4181 );
4182 $self->debug("Doing localize") if $CPAN::DEBUG;
4183 $local_file = CPAN::FTP->localize("authors/id/$sans.readme",
4184 $local_wanted)
4185 or $CPAN::Frontend->mydie(qq{No $sans.readme found});;
4186
4187 if ($^O eq 'MacOS') {
4188 Mac::BuildTools::launch_file($local_file);
4189 return;
4190 }
4191
4192 my $fh_pager = FileHandle->new;
4193 local($SIG{PIPE}) = "IGNORE";
4194 $fh_pager->open("|$CPAN::Config->{'pager'}")
4195 or die "Could not open pager $CPAN::Config->{'pager'}: $!";
4196 my $fh_readme = FileHandle->new;
4197 $fh_readme->open($local_file)
4198 or $CPAN::Frontend->mydie(qq{Could not open "$local_file": $!});
4199 $CPAN::Frontend->myprint(qq{
4200Displaying file
4201 $local_file
4202with pager "$CPAN::Config->{'pager'}"
4203});
4204 sleep 2;
4205 $fh_pager->print(<$fh_readme>);
4206}
4207
4208#-> sub CPAN::Distribution::verifyMD5 ;
4209sub verifyMD5 {
4210 my($self) = @_;
4211 EXCUSE: {
4212 my @e;
4213 $self->{MD5_STATUS} ||= "";
4214 $self->{MD5_STATUS} eq "OK" and push @e, "MD5 Checksum was ok";
4215 $CPAN::Frontend->myprint(join "", map {" $_\n"} @e) and return if @e;
4216 }
4217 my($lc_want,$lc_file,@local,$basename);
4218 @local = split(/\//,$self->id);
4219 pop @local;
4220 push @local, "CHECKSUMS";
4221 $lc_want =
4222 File::Spec->catfile($CPAN::Config->{keep_source_where},
4223 "authors", "id", @local);
4224 local($") = "/";
4225 if (
4226 -s $lc_want
4227 &&
4228 $self->MD5_check_file($lc_want)
4229 ) {
4230 return $self->{MD5_STATUS} = "OK";
4231 }
4232 $lc_file = CPAN::FTP->localize("authors/id/@local",
4233 $lc_want,1);
4234 unless ($lc_file) {
4235 $CPAN::Frontend->myprint("Trying $lc_want.gz\n");
4236 $local[-1] .= ".gz";
4237 $lc_file = CPAN::FTP->localize("authors/id/@local",
4238 "$lc_want.gz",1);
4239 if ($lc_file) {
4240 $lc_file =~ s/\.gz(?!\n)\Z//;
4241 CPAN::Tarzip->gunzip("$lc_file.gz",$lc_file);
4242 } else {
4243 return;
4244 }
4245 }
4246 $self->MD5_check_file($lc_file);
4247}
4248
4249#-> sub CPAN::Distribution::MD5_check_file ;
4250sub MD5_check_file {
4251 my($self,$chk_file) = @_;
4252 my($cksum,$file,$basename);
4253 $file = $self->{localfile};
4254 $basename = File::Basename::basename($file);
4255 my $fh = FileHandle->new;
4256 if (open $fh, $chk_file){
4257 local($/);
4258 my $eval = <$fh>;
4259 $eval =~ s/\015?\012/\n/g;
4260 close $fh;
4261 my($comp) = Safe->new();
4262 $cksum = $comp->reval($eval);
4263 if ($@) {
4264 rename $chk_file, "$chk_file.bad";
4265 Carp::confess($@) if $@;
4266 }
4267 } else {
4268 Carp::carp "Could not open $chk_file for reading";
4269 }
4270
4271 if (exists $cksum->{$basename}{md5}) {
4272 $self->debug("Found checksum for $basename:" .
4273 "$cksum->{$basename}{md5}\n") if $CPAN::DEBUG;
4274
4275 open($fh, $file);
4276 binmode $fh;
4277 my $eq = $self->eq_MD5($fh,$cksum->{$basename}{'md5'});
4278 $fh->close;
4279 $fh = CPAN::Tarzip->TIEHANDLE($file);
4280
4281 unless ($eq) {
4282 # had to inline it, when I tied it, the tiedness got lost on
4283 # the call to eq_MD5. (Jan 1998)
4284 my $md5 = Digest::MD5->new;
4285 my($data,$ref);
4286 $ref = \$data;
4287 while ($fh->READ($ref, 4096) > 0){
4288 $md5->add($data);
4289 }
4290 my $hexdigest = $md5->hexdigest;
4291 $eq += $hexdigest eq $cksum->{$basename}{'md5-ungz'};
4292 }
4293
4294 if ($eq) {
4295 $CPAN::Frontend->myprint("Checksum for $file ok\n");
4296 return $self->{MD5_STATUS} = "OK";
4297 } else {
4298 $CPAN::Frontend->myprint(qq{\nChecksum mismatch for }.
4299 qq{distribution file. }.
4300 qq{Please investigate.\n\n}.
4301 $self->as_string,
4302 $CPAN::META->instance(
4303 'CPAN::Author',
4304 $self->cpan_userid
4305 )->as_string);
4306
4307 my $wrap = qq{I\'d recommend removing $file. Its MD5
4308checksum is incorrect. Maybe you have configured your 'urllist' with
4309a bad URL. Please check this array with 'o conf urllist', and
4310retry.};
4311
4312 $CPAN::Frontend->mydie(Text::Wrap::wrap("","",$wrap));
4313
4314 # former versions just returned here but this seems a
4315 # serious threat that deserves a die
4316
4317 # $CPAN::Frontend->myprint("\n\n");
4318 # sleep 3;
4319 # return;
4320 }
4321 # close $fh if fileno($fh);
4322 } else {
4323 $self->{MD5_STATUS} ||= "";
4324 if ($self->{MD5_STATUS} eq "NIL") {
4325 $CPAN::Frontend->mywarn(qq{
4326Warning: No md5 checksum for $basename in $chk_file.
4327
4328The cause for this may be that the file is very new and the checksum
4329has not yet been calculated, but it may also be that something is
4330going awry right now.
4331});
4332 my $answer = ExtUtils::MakeMaker::prompt("Proceed?", "yes");
4333 $answer =~ /^\s*y/i or $CPAN::Frontend->mydie("Aborted.");
4334 }
4335 $self->{MD5_STATUS} = "NIL";
4336 return;
4337 }
4338}
4339
4340#-> sub CPAN::Distribution::eq_MD5 ;
4341sub eq_MD5 {
4342 my($self,$fh,$expectMD5) = @_;
4343 my $md5 = Digest::MD5->new;
4344 my($data);
4345 while (read($fh, $data, 4096)){
4346 $md5->add($data);
4347 }
4348 # $md5->addfile($fh);
4349 my $hexdigest = $md5->hexdigest;
4350 # warn "fh[$fh] hex[$hexdigest] aexp[$expectMD5]";
4351 $hexdigest eq $expectMD5;
4352}
4353
4354#-> sub CPAN::Distribution::force ;
4355
4356# Both modules and distributions know if "force" is in effect by
4357# autoinspection, not by inspecting a global variable. One of the
4358# reason why this was chosen to work that way was the treatment of
4359# dependencies. They should not autpomatically inherit the force
4360# status. But this has the downside that ^C and die() will return to
4361# the prompt but will not be able to reset the force_update
4362# attributes. We try to correct for it currently in the read_metadata
4363# routine, and immediately before we check for a Signal. I hope this
4364# works out in one of v1.57_53ff
4365
4366sub force {
4367 my($self, $method) = @_;
4368 for my $att (qw(
4369 MD5_STATUS archived build_dir localfile make install unwrapped
4370 writemakefile
4371 )) {
4372 delete $self->{$att};
4373 }
4374 if ($method && $method eq "install") {
4375 $self->{"force_update"}++; # name should probably have been force_install
4376 }
4377}
4378
4379#-> sub CPAN::Distribution::unforce ;
4380sub unforce {
4381 my($self) = @_;
4382 delete $self->{'force_update'};
4383}
4384
4385#-> sub CPAN::Distribution::isa_perl ;
4386sub isa_perl {
4387 my($self) = @_;
4388 my $file = File::Basename::basename($self->id);
4389 if ($file =~ m{ ^ perl
4390 -?
4391 (5)
4392 ([._-])
4393 (
4394 \d{3}(_[0-4][0-9])?
4395 |
4396 \d*[24680]\.\d+
4397 )
4398 \.tar[._-]gz
4399 (?!\n)\Z
4400 }xs){
4401 return "$1.$3";
4402 } elsif ($self->cpan_comment
4403 &&
4404 $self->cpan_comment =~ /isa_perl\(.+?\)/){
4405 return $1;
4406 }
4407}
4408
4409#-> sub CPAN::Distribution::perl ;
4410sub perl {
4411 my($self) = @_;
4412 my($perl) = File::Spec->file_name_is_absolute($^X) ? $^X : "";
4413 my $pwd = CPAN::anycwd();
4414 my $candidate = File::Spec->catfile($pwd,$^X);
4415 $perl ||= $candidate if MM->maybe_command($candidate);
4416 unless ($perl) {
4417 my ($component,$perl_name);
4418 DIST_PERLNAME: foreach $perl_name ($^X, 'perl', 'perl5', "perl$]") {
4419 PATH_COMPONENT: foreach $component (File::Spec->path(),
4420 $Config::Config{'binexp'}) {
4421 next unless defined($component) && $component;
4422 my($abs) = File::Spec->catfile($component,$perl_name);
4423 if (MM->maybe_command($abs)) {
4424 $perl = $abs;
4425 last DIST_PERLNAME;
4426 }
4427 }
4428 }
4429 }
4430 $perl;
4431}
4432
4433#-> sub CPAN::Distribution::make ;
4434sub make {
4435 my($self) = @_;
4436 $CPAN::Frontend->myprint(sprintf "Running make for %s\n", $self->id);
4437 # Emergency brake if they said install Pippi and get newest perl
4438 if ($self->isa_perl) {
4439 if (
4440 $self->called_for ne $self->id &&
4441 ! $self->{force_update}
4442 ) {
4443 # if we die here, we break bundles
4444 $CPAN::Frontend->mywarn(sprintf qq{
4445The most recent version "%s" of the module "%s"
4446comes with the current version of perl (%s).
4447I\'ll build that only if you ask for something like
4448 force install %s
4449or
4450 install %s
4451},
4452 $CPAN::META->instance(
4453 'CPAN::Module',
4454 $self->called_for
4455 )->cpan_version,
4456 $self->called_for,
4457 $self->isa_perl,
4458 $self->called_for,
4459 $self->id);
4460 sleep 5; return;
4461 }
4462 }
4463 $self->get;
4464 EXCUSE: {
4465 my @e;
4466 $self->{archived} eq "NO" and push @e,
4467 "Is neither a tar nor a zip archive.";
4468
4469 $self->{unwrapped} eq "NO" and push @e,
4470 "had problems unarchiving. Please build manually";
4471
4472 exists $self->{writemakefile} &&
4473 $self->{writemakefile} =~ m/ ^ NO\s* ( .* ) /sx and push @e,
4474 $1 || "Had some problem writing Makefile";
4475
4476 defined $self->{'make'} and push @e,
4477 "Has already been processed within this session";
4478
4479 exists $self->{later} and length($self->{later}) and
4480 push @e, $self->{later};
4481
4482 $CPAN::Frontend->myprint(join "", map {" $_\n"} @e) and return if @e;
4483 }
4484 $CPAN::Frontend->myprint("\n CPAN.pm: Going to build ".$self->id."\n\n");
4485 my $builddir = $self->dir;
4486 chdir $builddir or Carp::croak("Couldn't chdir $builddir: $!");
4487 $self->debug("Changed directory to $builddir") if $CPAN::DEBUG;
4488
4489 if ($^O eq 'MacOS') {
4490 Mac::BuildTools::make($self);
4491 return;
4492 }
4493
4494 my $system;
4495 if ($self->{'configure'}) {
4496 $system = $self->{'configure'};
4497 } else {
4498 my($perl) = $self->perl or die "Couldn\'t find executable perl\n";
4499 my $switch = "";
4500# This needs a handler that can be turned on or off:
4501# $switch = "-MExtUtils::MakeMaker ".
4502# "-Mops=:default,:filesys_read,:filesys_open,require,chdir"
4503# if $] > 5.00310;
4504 $system = "$perl $switch Makefile.PL $CPAN::Config->{makepl_arg}";
4505 }
4506 unless (exists $self->{writemakefile}) {
4507 local($SIG{ALRM}) = sub { die "inactivity_timeout reached\n" };
4508 my($ret,$pid);
4509 $@ = "";
4510 if ($CPAN::Config->{inactivity_timeout}) {
4511 eval {
4512 alarm $CPAN::Config->{inactivity_timeout};
4513 local $SIG{CHLD}; # = sub { wait };
4514 if (defined($pid = fork)) {
4515 if ($pid) { #parent
4516 # wait;
4517 waitpid $pid, 0;
4518 } else { #child
4519 # note, this exec isn't necessary if
4520 # inactivity_timeout is 0. On the Mac I'd
4521 # suggest, we set it always to 0.
4522 exec $system;
4523 }
4524 } else {
4525 $CPAN::Frontend->myprint("Cannot fork: $!");
4526 return;
4527 }
4528 };
4529 alarm 0;
4530 if ($@){
4531 kill 9, $pid;
4532 waitpid $pid, 0;
4533 $CPAN::Frontend->myprint($@);
4534 $self->{writemakefile} = "NO $@";
4535 $@ = "";
4536 return;
4537 }
4538 } else {
4539 $ret = system($system);
4540 if ($ret != 0) {
4541 $self->{writemakefile} = "NO Makefile.PL returned status $ret";
4542 return;
4543 }
4544 }
4545 if (-f "Makefile") {
4546 $self->{writemakefile} = "YES";
4547 delete $self->{make_clean}; # if cleaned before, enable next
4548 } else {
4549 $self->{writemakefile} =
4550 qq{NO Makefile.PL refused to write a Makefile.};
4551 # It's probably worth it to record the reason, so let's retry
4552 # local $/;
4553 # my $fh = IO::File->new("$system |"); # STDERR? STDIN?
4554 # $self->{writemakefile} .= <$fh>;
4555 }
4556 }
4557 if ($CPAN::Signal){
4558 delete $self->{force_update};
4559 return;
4560 }
4561 if (my @prereq = $self->unsat_prereq){
4562 return 1 if $self->follow_prereqs(@prereq); # signal success to the queuerunner
4563 }
4564 $system = join " ", $CPAN::Config->{'make'}, $CPAN::Config->{make_arg};
4565 if (system($system) == 0) {
4566 $CPAN::Frontend->myprint(" $system -- OK\n");
4567 $self->{'make'} = "YES";
4568 } else {
4569 $self->{writemakefile} ||= "YES";
4570 $self->{'make'} = "NO";
4571 $CPAN::Frontend->myprint(" $system -- NOT OK\n");
4572 }
4573}
4574
4575sub follow_prereqs {
4576 my($self) = shift;
4577 my(@prereq) = @_;
4578 my $id = $self->id;
4579 $CPAN::Frontend->myprint("---- Unsatisfied dependencies detected ".
4580 "during [$id] -----\n");
4581
4582 for my $p (@prereq) {
4583 $CPAN::Frontend->myprint(" $p\n");
4584 }
4585 my $follow = 0;
4586 if ($CPAN::Config->{prerequisites_policy} eq "follow") {
4587 $follow = 1;
4588 } elsif ($CPAN::Config->{prerequisites_policy} eq "ask") {
4589 require ExtUtils::MakeMaker;
4590 my $answer = ExtUtils::MakeMaker::prompt(
4591"Shall I follow them and prepend them to the queue
4592of modules we are processing right now?", "yes");
4593 $follow = $answer =~ /^\s*y/i;
4594 } else {
4595 local($") = ", ";
4596 $CPAN::Frontend->
4597 myprint(" Ignoring dependencies on modules @prereq\n");
4598 }
4599 if ($follow) {
4600 # color them as dirty
4601 for my $p (@prereq) {
4602 # warn "calling color_cmd_tmps(0,1)";
4603 CPAN::Shell->expandany($p)->color_cmd_tmps(0,1);
4604 }
4605 CPAN::Queue->jumpqueue(@prereq,$id); # queue them and requeue yourself
4606 $self->{later} = "Delayed until after prerequisites";
4607 return 1; # signal success to the queuerunner
4608 }
4609}
4610
4611#-> sub CPAN::Distribution::unsat_prereq ;
4612sub unsat_prereq {
4613 my($self) = @_;
4614 my $prereq_pm = $self->prereq_pm or return;
4615 my(@need);
4616 NEED: while (my($need_module, $need_version) = each %$prereq_pm) {
4617 my $nmo = $CPAN::META->instance("CPAN::Module",$need_module);
4618 # we were too demanding:
4619 next if $nmo->uptodate;
4620
4621 # if they have not specified a version, we accept any installed one
4622 if (not defined $need_version or
4623 $need_version == 0 or
4624 $need_version eq "undef") {
4625 next if defined $nmo->inst_file;
4626 }
4627
4628 # We only want to install prereqs if either they're not installed
4629 # or if the installed version is too old. We cannot omit this
4630 # check, because if 'force' is in effect, nobody else will check.
4631 {
4632 local($^W) = 0;
4633 if (
4634 defined $nmo->inst_file &&
4635 ! CPAN::Version->vgt($need_version, $nmo->inst_version)
4636 ){
4637 CPAN->debug(sprintf "id[%s]inst_file[%s]inst_version[%s]need_version[%s]",
4638 $nmo->id,
4639 $nmo->inst_file,
4640 $nmo->inst_version,
4641 CPAN::Version->readable($need_version)
4642 );
4643 next NEED;
4644 }
4645 }
4646
4647 if ($self->{sponsored_mods}{$need_module}++){
4648 # We have already sponsored it and for some reason it's still
4649 # not available. So we do nothing. Or what should we do?
4650 # if we push it again, we have a potential infinite loop
4651 next;
4652 }
4653 push @need, $need_module;
4654 }
4655 @need;
4656}
4657
4658#-> sub CPAN::Distribution::prereq_pm ;
4659sub prereq_pm {
4660 my($self) = @_;
4661 return $self->{prereq_pm} if
4662 exists $self->{prereq_pm_detected} && $self->{prereq_pm_detected};
4663 return unless $self->{writemakefile}; # no need to have succeeded
4664 # but we must have run it
4665 my $build_dir = $self->{build_dir} or die "Panic: no build_dir?";
4666 my $makefile = File::Spec->catfile($build_dir,"Makefile");
4667 my(%p) = ();
4668 my $fh;
4669 if (-f $makefile
4670 and
4671 $fh = FileHandle->new("<$makefile\0")) {
4672
4673 local($/) = "\n";
4674
4675 # A.Speer @p -> %p, where %p is $p{Module::Name}=Required_Version
4676 while (<$fh>) {
4677 last if /MakeMaker post_initialize section/;
4678 my($p) = m{^[\#]
4679 \s+PREREQ_PM\s+=>\s+(.+)
4680 }x;
4681 next unless $p;
4682 # warn "Found prereq expr[$p]";
4683
4684 # Regexp modified by A.Speer to remember actual version of file
4685 # PREREQ_PM hash key wants, then add to
4686 while ( $p =~ m/(?:\s)([\w\:]+)=>q\[(.*?)\],?/g ){
4687 # In case a prereq is mentioned twice, complain.
4688 if ( defined $p{$1} ) {
4689 warn "Warning: PREREQ_PM mentions $1 more than once, last mention wins";
4690 }
4691 $p{$1} = $2;
4692 }
4693 last;
4694 }
4695 }
4696 $self->{prereq_pm_detected}++;
4697 return $self->{prereq_pm} = \%p;
4698}
4699
4700#-> sub CPAN::Distribution::test ;
4701sub test {
4702 my($self) = @_;
4703 $self->make;
4704 if ($CPAN::Signal){
4705 delete $self->{force_update};
4706 return;
4707 }
4708 $CPAN::Frontend->myprint("Running make test\n");
4709 if (my @prereq = $self->unsat_prereq){
4710 return 1 if $self->follow_prereqs(@prereq); # signal success to the queuerunner
4711 }
4712 EXCUSE: {
4713 my @e;
4714 exists $self->{make} or exists $self->{later} or push @e,
4715 "Make had some problems, maybe interrupted? Won't test";
4716
4717 exists $self->{'make'} and
4718 $self->{'make'} eq 'NO' and
4719 push @e, "Can't test without successful make";
4720
4721 exists $self->{build_dir} or push @e, "Has no own directory";
4722 $self->{badtestcnt} ||= 0;
4723 $self->{badtestcnt} > 0 and
4724 push @e, "Won't repeat unsuccessful test during this command";
4725
4726 exists $self->{later} and length($self->{later}) and
4727 push @e, $self->{later};
4728
4729 $CPAN::Frontend->myprint(join "", map {" $_\n"} @e) and return if @e;
4730 }
4731 chdir $self->{'build_dir'} or
4732 Carp::croak("Couldn't chdir to $self->{'build_dir'}");
4733 $self->debug("Changed directory to $self->{'build_dir'}")
4734 if $CPAN::DEBUG;
4735
4736 if ($^O eq 'MacOS') {
4737 Mac::BuildTools::make_test($self);
4738 return;
4739 }
4740
4741 local $ENV{PERL5LIB} = $ENV{PERL5LIB} || "";
4742 $CPAN::META->set_perl5lib;
4743 my $system = join " ", $CPAN::Config->{'make'}, "test";
4744 if (system($system) == 0) {
4745 $CPAN::Frontend->myprint(" $system -- OK\n");
4746 $CPAN::META->is_tested($self->{'build_dir'});
4747 $self->{make_test} = "YES";
4748 } else {
4749 $self->{make_test} = "NO";
4750 $self->{badtestcnt}++;
4751 $CPAN::Frontend->myprint(" $system -- NOT OK\n");
4752 }
4753}
4754
4755#-> sub CPAN::Distribution::clean ;
4756sub clean {
4757 my($self) = @_;
4758 $CPAN::Frontend->myprint("Running make clean\n");
4759 EXCUSE: {
4760 my @e;
4761 exists $self->{make_clean} and $self->{make_clean} eq "YES" and
4762 push @e, "make clean already called once";
4763 exists $self->{build_dir} or push @e, "Has no own directory";
4764 $CPAN::Frontend->myprint(join "", map {" $_\n"} @e) and return if @e;
4765 }
4766 chdir $self->{'build_dir'} or
4767 Carp::croak("Couldn't chdir to $self->{'build_dir'}");
4768 $self->debug("Changed directory to $self->{'build_dir'}") if $CPAN::DEBUG;
4769
4770 if ($^O eq 'MacOS') {
4771 Mac::BuildTools::make_clean($self);
4772 return;
4773 }
4774
4775 my $system = join " ", $CPAN::Config->{'make'}, "clean";
4776 if (system($system) == 0) {
4777 $CPAN::Frontend->myprint(" $system -- OK\n");
4778
4779 # $self->force;
4780
4781 # Jost Krieger pointed out that this "force" was wrong because
4782 # it has the effect that the next "install" on this distribution
4783 # will untar everything again. Instead we should bring the
4784 # object's state back to where it is after untarring.
4785
4786 delete $self->{force_update};
4787 delete $self->{install};
4788 delete $self->{writemakefile};
4789 delete $self->{make};
4790 delete $self->{make_test}; # no matter if yes or no, tests must be redone
4791 $self->{make_clean} = "YES";
4792
4793 } else {
4794 # Hmmm, what to do if make clean failed?
4795
4796 $CPAN::Frontend->myprint(qq{ $system -- NOT OK
4797
4798make clean did not succeed, marking directory as unusable for further work.
4799});
4800 $self->force("make"); # so that this directory won't be used again
4801
4802 }
4803}
4804
4805#-> sub CPAN::Distribution::install ;
4806sub install {
4807 my($self) = @_;
4808 $self->test;
4809 if ($CPAN::Signal){
4810 delete $self->{force_update};
4811 return;
4812 }
4813 $CPAN::Frontend->myprint("Running make install\n");
4814 EXCUSE: {
4815 my @e;
4816 exists $self->{build_dir} or push @e, "Has no own directory";
4817
4818 exists $self->{make} or exists $self->{later} or push @e,
4819 "Make had some problems, maybe interrupted? Won't install";
4820
4821 exists $self->{'make'} and
4822 $self->{'make'} eq 'NO' and
4823 push @e, "make had returned bad status, install seems impossible";
4824
4825 push @e, "make test had returned bad status, ".
4826 "won't install without force"
4827 if exists $self->{'make_test'} and
4828 $self->{'make_test'} eq 'NO' and
4829 ! $self->{'force_update'};
4830
4831 exists $self->{'install'} and push @e,
4832 $self->{'install'} eq "YES" ?
4833 "Already done" : "Already tried without success";
4834
4835 exists $self->{later} and length($self->{later}) and
4836 push @e, $self->{later};
4837
4838 $CPAN::Frontend->myprint(join "", map {" $_\n"} @e) and return if @e;
4839 }
4840 chdir $self->{'build_dir'} or
4841 Carp::croak("Couldn't chdir to $self->{'build_dir'}");
4842 $self->debug("Changed directory to $self->{'build_dir'}")
4843 if $CPAN::DEBUG;
4844
4845 if ($^O eq 'MacOS') {
4846 Mac::BuildTools::make_install($self);
4847 return;
4848 }
4849
4850 my $system = join(" ", $CPAN::Config->{'make'},
4851 "install", $CPAN::Config->{make_install_arg});
4852 my($stderr) = $^O =~ /Win/i ? "" : " 2>&1 ";
4853 my($pipe) = FileHandle->new("$system $stderr |");
4854 my($makeout) = "";
4855 while (<$pipe>){
4856 $CPAN::Frontend->myprint($_);
4857 $makeout .= $_;
4858 }
4859 $pipe->close;
4860 if ($?==0) {
4861 $CPAN::Frontend->myprint(" $system -- OK\n");
4862 $CPAN::META->is_installed($self->{'build_dir'});
4863 return $self->{'install'} = "YES";
4864 } else {
4865 $self->{'install'} = "NO";
4866 $CPAN::Frontend->myprint(" $system -- NOT OK\n");
4867 if ($makeout =~ /permission/s && $> > 0) {
4868 $CPAN::Frontend->myprint(qq{ You may have to su }.
4869 qq{to root to install the package\n});
4870 }
4871 }
4872 delete $self->{force_update};
4873}
4874
4875#-> sub CPAN::Distribution::dir ;
4876sub dir {
4877 shift->{'build_dir'};
4878}
4879
4880package CPAN::Bundle;
4881
4882sub look {
4883 my $self = shift;
4884 $CPAN::Frontend->myprint($self->as_string);
4885}
4886
4887sub undelay {
4888 my $self = shift;
4889 delete $self->{later};
4890 for my $c ( $self->contains ) {
4891 my $obj = CPAN::Shell->expandany($c) or next;
4892 $obj->undelay;
4893 }
4894}
4895
4896#-> sub CPAN::Bundle::color_cmd_tmps ;
4897sub color_cmd_tmps {
4898 my($self) = shift;
4899 my($depth) = shift || 0;
4900 my($color) = shift || 0;
4901 my($ancestors) = shift || [];
4902 # a module needs to recurse to its cpan_file, a distribution needs
4903 # to recurse into its prereq_pms, a bundle needs to recurse into its modules
4904
4905 return if exists $self->{incommandcolor}
4906 && $self->{incommandcolor}==$color;
4907 if ($depth>=100){
4908 $CPAN::Frontend->mydie(CPAN::Exception::RecursiveDependency->new($ancestors));
4909 }
4910 # warn "color_cmd_tmps $depth $color " . $self->id; # sleep 1;
4911
4912 for my $c ( $self->contains ) {
4913 my $obj = CPAN::Shell->expandany($c) or next;
4914 CPAN->debug("c[$c]obj[$obj]") if $CPAN::DEBUG;
4915 $obj->color_cmd_tmps($depth+1,$color,[@$ancestors, $self->id]);
4916 }
4917 if ($color==0) {
4918 delete $self->{badtestcnt};
4919 }
4920 $self->{incommandcolor} = $color;
4921}
4922
4923#-> sub CPAN::Bundle::as_string ;
4924sub as_string {
4925 my($self) = @_;
4926 $self->contains;
4927 # following line must be "=", not "||=" because we have a moving target
4928 $self->{INST_VERSION} = $self->inst_version;
4929 return $self->SUPER::as_string;
4930}
4931
4932#-> sub CPAN::Bundle::contains ;
4933sub contains {
4934 my($self) = @_;
4935 my($inst_file) = $self->inst_file || "";
4936 my($id) = $self->id;
4937 $self->debug("inst_file[$inst_file]id[$id]") if $CPAN::DEBUG;
4938 unless ($inst_file) {
4939 # Try to get at it in the cpan directory
4940 $self->debug("no inst_file") if $CPAN::DEBUG;
4941 my $cpan_file;
4942 $CPAN::Frontend->mydie("I don't know a bundle with ID $id\n") unless
4943 $cpan_file = $self->cpan_file;
4944 if ($cpan_file eq "N/A") {
4945 $CPAN::Frontend->mydie("Bundle $id not found on disk and not on CPAN.
4946 Maybe stale symlink? Maybe removed during session? Giving up.\n");
4947 }
4948 my $dist = $CPAN::META->instance('CPAN::Distribution',
4949 $self->cpan_file);
4950 $dist->get;
4951 $self->debug($dist->as_string) if $CPAN::DEBUG;
4952 my($todir) = $CPAN::Config->{'cpan_home'};
4953 my(@me,$from,$to,$me);
4954 @me = split /::/, $self->id;
4955 $me[-1] .= ".pm";
4956 $me = File::Spec->catfile(@me);
4957 $from = $self->find_bundle_file($dist->{'build_dir'},$me);
4958 $to = File::Spec->catfile($todir,$me);
4959 File::Path::mkpath(File::Basename::dirname($to));
4960 File::Copy::copy($from, $to)
4961 or Carp::confess("Couldn't copy $from to $to: $!");
4962 $inst_file = $to;
4963 }
4964 my @result;
4965 my $fh = FileHandle->new;
4966 local $/ = "\n";
4967 open($fh,$inst_file) or die "Could not open '$inst_file': $!";
4968 my $in_cont = 0;
4969 $self->debug("inst_file[$inst_file]") if $CPAN::DEBUG;
4970 while (<$fh>) {
4971 $in_cont = m/^=(?!head1\s+CONTENTS)/ ? 0 :
4972 m/^=head1\s+CONTENTS/ ? 1 : $in_cont;
4973 next unless $in_cont;
4974 next if /^=/;
4975 s/\#.*//;
4976 next if /^\s+$/;
4977 chomp;
4978 push @result, (split " ", $_, 2)[0];
4979 }
4980 close $fh;
4981 delete $self->{STATUS};
4982 $self->{CONTAINS} = \@result;
4983 $self->debug("CONTAINS[@result]") if $CPAN::DEBUG;
4984 unless (@result) {
4985 $CPAN::Frontend->mywarn(qq{
4986The bundle file "$inst_file" may be a broken
4987bundlefile. It seems not to contain any bundle definition.
4988Please check the file and if it is bogus, please delete it.
4989Sorry for the inconvenience.
4990});
4991 }
4992 @result;
4993}
4994
4995#-> sub CPAN::Bundle::find_bundle_file
4996sub find_bundle_file {
4997 my($self,$where,$what) = @_;
4998 $self->debug("where[$where]what[$what]") if $CPAN::DEBUG;
4999### The following two lines let CPAN.pm become Bundle/CPAN.pm :-(
5000### my $bu = File::Spec->catfile($where,$what);
5001### return $bu if -f $bu;
5002 my $manifest = File::Spec->catfile($where,"MANIFEST");
5003 unless (-f $manifest) {
5004 require ExtUtils::Manifest;
5005 my $cwd = CPAN::anycwd();
5006 chdir $where or $CPAN::Frontend->mydie(qq{Could not chdir to "$where": $!});
5007 ExtUtils::Manifest::mkmanifest();
5008 chdir $cwd or $CPAN::Frontend->mydie(qq{Could not chdir to "$cwd": $!});
5009 }
5010 my $fh = FileHandle->new($manifest)
5011 or Carp::croak("Couldn't open $manifest: $!");
5012 local($/) = "\n";
5013 my $what2 = $what;
5014 if ($^O eq 'MacOS') {
5015 $what =~ s/^://;
5016 $what =~ tr|:|/|;
5017 $what2 =~ s/:Bundle://;
5018 $what2 =~ tr|:|/|;
5019 } else {
5020 $what2 =~ s|Bundle[/\\]||;
5021 }
5022 my $bu;
5023 while (<$fh>) {
5024 next if /^\s*\#/;
5025 my($file) = /(\S+)/;
5026 if ($file =~ m|\Q$what\E$|) {
5027 $bu = $file;
5028 # return File::Spec->catfile($where,$bu); # bad
5029 last;
5030 }
5031 # retry if she managed to
5032 # have no Bundle directory
5033 $bu = $file if $file =~ m|\Q$what2\E$|;
5034 }
5035 $bu =~ tr|/|:| if $^O eq 'MacOS';
5036 return File::Spec->catfile($where, $bu) if $bu;
5037 Carp::croak("Couldn't find a Bundle file in $where");
5038}
5039
5040# needs to work quite differently from Module::inst_file because of
5041# cpan_home/Bundle/ directory and the possibility that we have
5042# shadowing effect. As it makes no sense to take the first in @INC for
5043# Bundles, we parse them all for $VERSION and take the newest.
5044
5045#-> sub CPAN::Bundle::inst_file ;
5046sub inst_file {
5047 my($self) = @_;
5048 my($inst_file);
5049 my(@me);
5050 @me = split /::/, $self->id;
5051 $me[-1] .= ".pm";
5052 my($incdir,$bestv);
5053 foreach $incdir ($CPAN::Config->{'cpan_home'},@INC) {
5054 my $bfile = File::Spec->catfile($incdir, @me);
5055 CPAN->debug("bfile[$bfile]") if $CPAN::DEBUG;
5056 next unless -f $bfile;
5057 my $foundv = MM->parse_version($bfile);
5058 if (!$bestv || CPAN::Version->vgt($foundv,$bestv)) {
5059 $self->{INST_FILE} = $bfile;
5060 $self->{INST_VERSION} = $bestv = $foundv;
5061 }
5062 }
5063 $self->{INST_FILE};
5064}
5065
5066#-> sub CPAN::Bundle::inst_version ;
5067sub inst_version {
5068 my($self) = @_;
5069 $self->inst_file; # finds INST_VERSION as side effect
5070 $self->{INST_VERSION};
5071}
5072
5073#-> sub CPAN::Bundle::rematein ;
5074sub rematein {
5075 my($self,$meth) = @_;
5076 $self->debug("self[$self] meth[$meth]") if $CPAN::DEBUG;
5077 my($id) = $self->id;
5078 Carp::croak "Can't $meth $id, don't have an associated bundle file. :-(\n"
5079 unless $self->inst_file || $self->cpan_file;
5080 my($s,%fail);
5081 for $s ($self->contains) {
5082 my($type) = $s =~ m|/| ? 'CPAN::Distribution' :
5083 $s =~ m|^Bundle::| ? 'CPAN::Bundle' : 'CPAN::Module';
5084 if ($type eq 'CPAN::Distribution') {
5085 $CPAN::Frontend->mywarn(qq{
5086The Bundle }.$self->id.qq{ contains
5087explicitly a file $s.
5088});
5089 sleep 3;
5090 }
5091 # possibly noisy action:
5092 $self->debug("type[$type] s[$s]") if $CPAN::DEBUG;
5093 my $obj = $CPAN::META->instance($type,$s);
5094 $obj->$meth();
5095 if ($obj->isa(CPAN::Bundle)
5096 &&
5097 exists $obj->{install_failed}
5098 &&
5099 ref($obj->{install_failed}) eq "HASH"
5100 ) {
5101 for (keys %{$obj->{install_failed}}) {
5102 $self->{install_failed}{$_} = undef; # propagate faiure up
5103 # to me in a
5104 # recursive call
5105 $fail{$s} = 1; # the bundle itself may have succeeded but
5106 # not all children
5107 }
5108 } else {
5109 my $success;
5110 $success = $obj->can("uptodate") ? $obj->uptodate : 0;
5111 $success ||= $obj->{'install'} && $obj->{'install'} eq "YES";
5112 if ($success) {
5113 delete $self->{install_failed}{$s};
5114 } else {
5115 $fail{$s} = 1;
5116 }
5117 }
5118 }
5119
5120 # recap with less noise
5121 if ( $meth eq "install" ) {
5122 if (%fail) {
5123 require Text::Wrap;
5124 my $raw = sprintf(qq{Bundle summary:
5125The following items in bundle %s had installation problems:},
5126 $self->id
5127 );
5128 $CPAN::Frontend->myprint(Text::Wrap::fill("","",$raw));
5129 $CPAN::Frontend->myprint("\n");
5130 my $paragraph = "";
5131 my %reported;
5132 for $s ($self->contains) {
5133 if ($fail{$s}){
5134 $paragraph .= "$s ";
5135 $self->{install_failed}{$s} = undef;
5136 $reported{$s} = undef;
5137 }
5138 }
5139 my $report_propagated;
5140 for $s (sort keys %{$self->{install_failed}}) {
5141 next if exists $reported{$s};
5142 $paragraph .= "and the following items had problems
5143during recursive bundle calls: " unless $report_propagated++;
5144 $paragraph .= "$s ";
5145 }
5146 $CPAN::Frontend->myprint(Text::Wrap::fill(" "," ",$paragraph));
5147 $CPAN::Frontend->myprint("\n");
5148 } else {
5149 $self->{'install'} = 'YES';
5150 }
5151 }
5152}
5153
5154#sub CPAN::Bundle::xs_file
5155sub xs_file {
5156 # If a bundle contains another that contains an xs_file we have
5157 # here, we just don't bother I suppose
5158 return 0;
5159}
5160
5161#-> sub CPAN::Bundle::force ;
5162sub force { shift->rematein('force',@_); }
5163#-> sub CPAN::Bundle::get ;
5164sub get { shift->rematein('get',@_); }
5165#-> sub CPAN::Bundle::make ;
5166sub make { shift->rematein('make',@_); }
5167#-> sub CPAN::Bundle::test ;
5168sub test {
5169 my $self = shift;
5170 $self->{badtestcnt} ||= 0;
5171 $self->rematein('test',@_);
5172}
5173#-> sub CPAN::Bundle::install ;
5174sub install {
5175 my $self = shift;
5176 $self->rematein('install',@_);
5177}
5178#-> sub CPAN::Bundle::clean ;
5179sub clean { shift->rematein('clean',@_); }
5180
5181#-> sub CPAN::Bundle::uptodate ;
5182sub uptodate {
5183 my($self) = @_;
5184 return 0 unless $self->SUPER::uptodate; # we mut have the current Bundle def
5185 my $c;
5186 foreach $c ($self->contains) {
5187 my $obj = CPAN::Shell->expandany($c);
5188 return 0 unless $obj->uptodate;
5189 }
5190 return 1;
5191}
5192
5193#-> sub CPAN::Bundle::readme ;
5194sub readme {
5195 my($self) = @_;
5196 my($file) = $self->cpan_file or $CPAN::Frontend->myprint(qq{
5197No File found for bundle } . $self->id . qq{\n}), return;
5198 $self->debug("self[$self] file[$file]") if $CPAN::DEBUG;
5199 $CPAN::META->instance('CPAN::Distribution',$file)->readme;
5200}
5201
5202package CPAN::Module;
5203
5204# Accessors
5205# sub CPAN::Module::userid
5206sub userid {
5207 my $self = shift;
5208 return unless exists $self->{RO}; # should never happen
5209 return $self->{RO}{userid} || $self->{RO}{CPAN_USERID};
5210}
5211# sub CPAN::Module::description
5212sub description { shift->{RO}{description} }
5213
5214sub undelay {
5215 my $self = shift;
5216 delete $self->{later};
5217 if ( my $dist = CPAN::Shell->expand("Distribution", $self->cpan_file) ) {
5218 $dist->undelay;
5219 }
5220}
5221
5222#-> sub CPAN::Module::color_cmd_tmps ;
5223sub color_cmd_tmps {
5224 my($self) = shift;
5225 my($depth) = shift || 0;
5226 my($color) = shift || 0;
5227 my($ancestors) = shift || [];
5228 # a module needs to recurse to its cpan_file
5229
5230 return if exists $self->{incommandcolor}
5231 && $self->{incommandcolor}==$color;
5232 if ($depth>=100){
5233 $CPAN::Frontend->mydie(CPAN::Exception::RecursiveDependency->new($ancestors));
5234 }
5235 # warn "color_cmd_tmps $depth $color " . $self->id; # sleep 1;
5236
5237 if ( my $dist = CPAN::Shell->expand("Distribution", $self->cpan_file) ) {
5238 $dist->color_cmd_tmps($depth+1,$color,[@$ancestors, $self->id]);
5239 }
5240 if ($color==0) {
5241 delete $self->{badtestcnt};
5242 }
5243 $self->{incommandcolor} = $color;
5244}
5245
5246#-> sub CPAN::Module::as_glimpse ;
5247sub as_glimpse {
5248 my($self) = @_;
5249 my(@m);
5250 my $class = ref($self);
5251 $class =~ s/^CPAN:://;
5252 my $color_on = "";
5253 my $color_off = "";
5254 if (
5255 $CPAN::Shell::COLOR_REGISTERED
5256 &&
5257 $CPAN::META->has_inst("Term::ANSIColor")
5258 &&
5259 $self->{RO}{description}
5260 ) {
5261 $color_on = Term::ANSIColor::color("green");
5262 $color_off = Term::ANSIColor::color("reset");
5263 }
5264 push @m, sprintf("%-15s %s%-15s%s (%s)\n",
5265 $class,
5266 $color_on,
5267 $self->id,
5268 $color_off,
5269 $self->cpan_file);
5270 join "", @m;
5271}
5272
5273#-> sub CPAN::Module::as_string ;
5274sub as_string {
5275 my($self) = @_;
5276 my(@m);
5277 CPAN->debug("$self entering as_string") if $CPAN::DEBUG;
5278 my $class = ref($self);
5279 $class =~ s/^CPAN:://;
5280 local($^W) = 0;
5281 push @m, $class, " id = $self->{ID}\n";
5282 my $sprintf = " %-12s %s\n";
5283 push @m, sprintf($sprintf, 'DESCRIPTION', $self->description)
5284 if $self->description;
5285 my $sprintf2 = " %-12s %s (%s)\n";
5286 my($userid);
5287 $userid = $self->userid;
5288 if ( $userid ){
5289 my $author;
5290 if ($author = CPAN::Shell->expand('Author',$userid)) {
5291 my $email = "";
5292 my $m; # old perls
5293 if ($m = $author->email) {
5294 $email = " <$m>";
5295 }
5296 push @m, sprintf(
5297 $sprintf2,
5298 'CPAN_USERID',
5299 $userid,
5300 $author->fullname . $email
5301 );
5302 }
5303 }
5304 push @m, sprintf($sprintf, 'CPAN_VERSION', $self->cpan_version)
5305 if $self->cpan_version;
5306 push @m, sprintf($sprintf, 'CPAN_FILE', $self->cpan_file)
5307 if $self->cpan_file;
5308 my $sprintf3 = " %-12s %1s%1s%1s%1s (%s,%s,%s,%s)\n";
5309 my(%statd,%stats,%statl,%stati);
5310 @statd{qw,? i c a b R M S,} = qw,unknown idea
5311 pre-alpha alpha beta released mature standard,;
5312 @stats{qw,? m d u n a,} = qw,unknown mailing-list
5313 developer comp.lang.perl.* none abandoned,;
5314 @statl{qw,? p c + o h,} = qw,unknown perl C C++ other hybrid,;
5315 @stati{qw,? f r O h,} = qw,unknown functions
5316 references+ties object-oriented hybrid,;
5317 $statd{' '} = 'unknown';
5318 $stats{' '} = 'unknown';
5319 $statl{' '} = 'unknown';
5320 $stati{' '} = 'unknown';
5321 push @m, sprintf(
5322 $sprintf3,
5323 'DSLI_STATUS',
5324 $self->{RO}{statd},
5325 $self->{RO}{stats},
5326 $self->{RO}{statl},
5327 $self->{RO}{stati},
5328 $statd{$self->{RO}{statd}},
5329 $stats{$self->{RO}{stats}},
5330 $statl{$self->{RO}{statl}},
5331 $stati{$self->{RO}{stati}}
5332 ) if $self->{RO}{statd};
5333 my $local_file = $self->inst_file;
5334 unless ($self->{MANPAGE}) {
5335 if ($local_file) {
5336 $self->{MANPAGE} = $self->manpage_headline($local_file);
5337 } else {
5338 # If we have already untarred it, we should look there
5339 my $dist = $CPAN::META->instance('CPAN::Distribution',
5340 $self->cpan_file);
5341 # warn "dist[$dist]";
5342 # mff=manifest file; mfh=manifest handle
5343 my($mff,$mfh);
5344 if (
5345 $dist->{build_dir}
5346 and
5347 (-f ($mff = File::Spec->catfile($dist->{build_dir}, "MANIFEST")))
5348 and
5349 $mfh = FileHandle->new($mff)
5350 ) {
5351 CPAN->debug("mff[$mff]") if $CPAN::DEBUG;
5352 my $lfre = $self->id; # local file RE
5353 $lfre =~ s/::/./g;
5354 $lfre .= "\\.pm\$";
5355 my($lfl); # local file file
5356 local $/ = "\n";
5357 my(@mflines) = <$mfh>;
5358 for (@mflines) {
5359 s/^\s+//;
5360 s/\s.*//s;
5361 }
5362 while (length($lfre)>5 and !$lfl) {
5363 ($lfl) = grep /$lfre/, @mflines;
5364 CPAN->debug("lfl[$lfl]lfre[$lfre]") if $CPAN::DEBUG;
5365 $lfre =~ s/.+?\.//;
5366 }
5367 $lfl =~ s/\s.*//; # remove comments
5368 $lfl =~ s/\s+//g; # chomp would maybe be too system-specific
5369 my $lfl_abs = File::Spec->catfile($dist->{build_dir},$lfl);
5370 # warn "lfl_abs[$lfl_abs]";
5371 if (-f $lfl_abs) {
5372 $self->{MANPAGE} = $self->manpage_headline($lfl_abs);
5373 }
5374 }
5375 }
5376 }
5377 my($item);
5378 for $item (qw/MANPAGE/) {
5379 push @m, sprintf($sprintf, $item, $self->{$item})
5380 if exists $self->{$item};
5381 }
5382 for $item (qw/CONTAINS/) {
5383 push @m, sprintf($sprintf, $item, join(" ",@{$self->{$item}}))
5384 if exists $self->{$item} && @{$self->{$item}};
5385 }
5386 push @m, sprintf($sprintf, 'INST_FILE',
5387 $local_file || "(not installed)");
5388 push @m, sprintf($sprintf, 'INST_VERSION',
5389 $self->inst_version) if $local_file;
5390 join "", @m, "\n";
5391}
5392
5393sub manpage_headline {
5394 my($self,$local_file) = @_;
5395 my(@local_file) = $local_file;
5396 $local_file =~ s/\.pm(?!\n)\Z/.pod/;
5397 push @local_file, $local_file;
5398 my(@result,$locf);
5399 for $locf (@local_file) {
5400 next unless -f $locf;
5401 my $fh = FileHandle->new($locf)
5402 or $Carp::Frontend->mydie("Couldn't open $locf: $!");
5403 my $inpod = 0;
5404 local $/ = "\n";
5405 while (<$fh>) {
5406 $inpod = m/^=(?!head1\s+NAME\s*$)/ ? 0 :
5407 m/^=head1\s+NAME\s*$/ ? 1 : $inpod;
5408 next unless $inpod;
5409 next if /^=/;
5410 next if /^\s+$/;
5411 chomp;
5412 push @result, $_;
5413 }
5414 close $fh;
5415 last if @result;
5416 }
5417 join " ", @result;
5418}
5419
5420#-> sub CPAN::Module::cpan_file ;
5421# Note: also inherited by CPAN::Bundle
5422sub cpan_file {
5423 my $self = shift;
5424 CPAN->debug(sprintf "id[%s]", $self->id) if $CPAN::DEBUG;
5425 unless (defined $self->{RO}{CPAN_FILE}) {
5426 CPAN::Index->reload;
5427 }
5428 if (exists $self->{RO}{CPAN_FILE} && defined $self->{RO}{CPAN_FILE}){
5429 return $self->{RO}{CPAN_FILE};
5430 } else {
5431 my $userid = $self->userid;
5432 if ( $userid ) {
5433 if ($CPAN::META->exists("CPAN::Author",$userid)) {
5434 my $author = $CPAN::META->instance("CPAN::Author",
5435 $userid);
5436 my $fullname = $author->fullname;
5437 my $email = $author->email;
5438 unless (defined $fullname && defined $email) {
5439 return sprintf("Contact Author %s",
5440 $userid,
5441 );
5442 }
5443 return "Contact Author $fullname <$email>";
5444 } else {
5445 return "Contact Author $userid (Email address not available)";
5446 }
5447 } else {
5448 return "N/A";
5449 }
5450 }
5451}
5452
5453#-> sub CPAN::Module::cpan_version ;
5454sub cpan_version {
5455 my $self = shift;
5456
5457 $self->{RO}{CPAN_VERSION} = 'undef'
5458 unless defined $self->{RO}{CPAN_VERSION};
5459 # I believe this is always a bug in the index and should be reported
5460 # as such, but usually I find out such an error and do not want to
5461 # provoke too many bugreports
5462
5463 $self->{RO}{CPAN_VERSION};
5464}
5465
5466#-> sub CPAN::Module::force ;
5467sub force {
5468 my($self) = @_;
5469 $self->{'force_update'}++;
5470}
5471
5472#-> sub CPAN::Module::rematein ;
5473sub rematein {
5474 my($self,$meth) = @_;
5475 $CPAN::Frontend->myprint(sprintf("Running %s for module %s\n",
5476 $meth,
5477 $self->id));
5478 my $cpan_file = $self->cpan_file;
5479 if ($cpan_file eq "N/A" || $cpan_file =~ /^Contact Author/){
5480 $CPAN::Frontend->mywarn(sprintf qq{
5481 The module %s isn\'t available on CPAN.
5482
5483 Either the module has not yet been uploaded to CPAN, or it is
5484 temporary unavailable. Please contact the author to find out
5485 more about the status. Try 'i %s'.
5486},
5487 $self->id,
5488 $self->id,
5489 );
5490 return;
5491 }
5492 my $pack = $CPAN::META->instance('CPAN::Distribution',$cpan_file);
5493 $pack->called_for($self->id);
5494 $pack->force($meth) if exists $self->{'force_update'};
5495 $pack->$meth();
5496 $pack->unforce if $pack->can("unforce") && exists $self->{'force_update'};
5497 delete $self->{'force_update'};
5498}
5499
5500#-> sub CPAN::Module::readme ;
5501sub readme { shift->rematein('readme') }
5502#-> sub CPAN::Module::look ;
5503sub look { shift->rematein('look') }
5504#-> sub CPAN::Module::cvs_import ;
5505sub cvs_import { shift->rematein('cvs_import') }
5506#-> sub CPAN::Module::get ;
5507sub get { shift->rematein('get',@_); }
5508#-> sub CPAN::Module::make ;
5509sub make {
5510 my $self = shift;
5511 $self->rematein('make');
5512}
5513#-> sub CPAN::Module::test ;
5514sub test {
5515 my $self = shift;
5516 $self->{badtestcnt} ||= 0;
5517 $self->rematein('test',@_);
5518}
5519#-> sub CPAN::Module::uptodate ;
5520sub uptodate {
5521 my($self) = @_;
5522 my($latest) = $self->cpan_version;
5523 $latest ||= 0;
5524 my($inst_file) = $self->inst_file;
5525 my($have) = 0;
5526 if (defined $inst_file) {
5527 $have = $self->inst_version;
5528 }
5529 local($^W)=0;
5530 if ($inst_file
5531 &&
5532 ! CPAN::Version->vgt($latest, $have)
5533 ) {
5534 CPAN->debug("returning uptodate. inst_file[$inst_file] ".
5535 "latest[$latest] have[$have]") if $CPAN::DEBUG;
5536 return 1;
5537 }
5538 return;
5539}
5540#-> sub CPAN::Module::install ;
5541sub install {
5542 my($self) = @_;
5543 my($doit) = 0;
5544 if ($self->uptodate
5545 &&
5546 not exists $self->{'force_update'}
5547 ) {
5548 $CPAN::Frontend->myprint( $self->id. " is up to date.\n");
5549 } else {
5550 $doit = 1;
5551 }
5552 if ($self->{RO}{stats} && $self->{RO}{stats} eq "a") {
5553 $CPAN::Frontend->mywarn(qq{
5554\n\n\n ***WARNING***
5555 The module $self->{ID} has no active maintainer.\n\n\n
5556});
5557 sleep 5;
5558 }
5559 $self->rematein('install') if $doit;
5560}
5561#-> sub CPAN::Module::clean ;
5562sub clean { shift->rematein('clean') }
5563
5564#-> sub CPAN::Module::inst_file ;
5565sub inst_file {
5566 my($self) = @_;
5567 my($dir,@packpath);
5568 @packpath = split /::/, $self->{ID};
5569 $packpath[-1] .= ".pm";
5570 foreach $dir (@INC) {
5571 my $pmfile = File::Spec->catfile($dir,@packpath);
5572 if (-f $pmfile){
5573 return $pmfile;
5574 }
5575 }
5576 return;
5577}
5578
5579#-> sub CPAN::Module::xs_file ;
5580sub xs_file {
5581 my($self) = @_;
5582 my($dir,@packpath);
5583 @packpath = split /::/, $self->{ID};
5584 push @packpath, $packpath[-1];
5585 $packpath[-1] .= "." . $Config::Config{'dlext'};
5586 foreach $dir (@INC) {
5587 my $xsfile = File::Spec->catfile($dir,'auto',@packpath);
5588 if (-f $xsfile){
5589 return $xsfile;
5590 }
5591 }
5592 return;
5593}
5594
5595#-> sub CPAN::Module::inst_version ;
5596sub inst_version {
5597 my($self) = @_;
5598 my $parsefile = $self->inst_file or return;
5599 local($^W) = 0 if $] < 5.00303 && $ExtUtils::MakeMaker::VERSION < 5.38;
5600 my $have;
5601
5602 # there was a bug in 5.6.0 that let lots of unini warnings out of
5603 # parse_version. Fixed shortly after 5.6.0 by PMQS. We can remove
5604 # the following workaround after 5.6.1 is out.
5605 local($SIG{__WARN__}) = sub { my $w = shift;
5606 return if $w =~ /uninitialized/i;
5607 warn $w;
5608 };
5609
5610 $have = MM->parse_version($parsefile) || "undef";
5611 $have =~ s/^ //; # since the %vd hack these two lines here are needed
5612 $have =~ s/ $//; # trailing whitespace happens all the time
5613
5614 # My thoughts about why %vd processing should happen here
5615
5616 # Alt1 maintain it as string with leading v:
5617 # read index files do nothing
5618 # compare it use utility for compare
5619 # print it do nothing
5620
5621 # Alt2 maintain it as what it is
5622 # read index files convert
5623 # compare it use utility because there's still a ">" vs "gt" issue
5624 # print it use CPAN::Version for print
5625
5626 # Seems cleaner to hold it in memory as a string starting with a "v"
5627
5628 # If the author of this module made a mistake and wrote a quoted
5629 # "v1.13" instead of v1.13, we simply leave it at that with the
5630 # effect that *we* will treat it like a v-tring while the rest of
5631 # perl won't. Seems sensible when we consider that any action we
5632 # could take now would just add complexity.
5633
5634 $have = CPAN::Version->readable($have);
5635
5636 $have =~ s/\s*//g; # stringify to float around floating point issues
5637 $have; # no stringify needed, \s* above matches always
5638}
5639
5640package CPAN::Tarzip;
5641
5642# CPAN::Tarzip::gzip
5643sub gzip {
5644 my($class,$read,$write) = @_;
5645 if ($CPAN::META->has_inst("Compress::Zlib")) {
5646 my($buffer,$fhw);
5647 $fhw = FileHandle->new($read)
5648 or $CPAN::Frontend->mydie("Could not open $read: $!");
5649 my $gz = Compress::Zlib::gzopen($write, "wb")
5650 or $CPAN::Frontend->mydie("Cannot gzopen $write: $!\n");
5651 $gz->gzwrite($buffer)
5652 while read($fhw,$buffer,4096) > 0 ;
5653 $gz->gzclose() ;
5654 $fhw->close;
5655 return 1;
5656 } else {
5657 system("$CPAN::Config->{gzip} -c $read > $write")==0;
5658 }
5659}
5660
5661
5662# CPAN::Tarzip::gunzip
5663sub gunzip {
5664 my($class,$read,$write) = @_;
5665 if ($CPAN::META->has_inst("Compress::Zlib")) {
5666 my($buffer,$fhw);
5667 $fhw = FileHandle->new(">$write")
5668 or $CPAN::Frontend->mydie("Could not open >$write: $!");
5669 my $gz = Compress::Zlib::gzopen($read, "rb")
5670 or $CPAN::Frontend->mydie("Cannot gzopen $read: $!\n");
5671 $fhw->print($buffer)
5672 while $gz->gzread($buffer) > 0 ;
5673 $CPAN::Frontend->mydie("Error reading from $read: $!\n")
5674 if $gz->gzerror != Compress::Zlib::Z_STREAM_END();
5675 $gz->gzclose() ;
5676 $fhw->close;
5677 return 1;
5678 } else {
5679 system("$CPAN::Config->{gzip} -dc $read > $write")==0;
5680 }
5681}
5682
5683
5684# CPAN::Tarzip::gtest
5685sub gtest {
5686 my($class,$read) = @_;
5687 # After I had reread the documentation in zlib.h, I discovered that
5688 # uncompressed files do not lead to an gzerror (anymore?).
5689 if ( $CPAN::META->has_inst("Compress::Zlib") ) {
5690 my($buffer,$len);
5691 $len = 0;
5692 my $gz = Compress::Zlib::gzopen($read, "rb")
5693 or $CPAN::Frontend->mydie(sprintf("Cannot gzopen %s: %s\n",
5694 $read,
5695 $Compress::Zlib::gzerrno));
5696 while ($gz->gzread($buffer) > 0 ){
5697 $len += length($buffer);
5698 $buffer = "";
5699 }
5700 my $err = $gz->gzerror;
5701 my $success = ! $err || $err == Compress::Zlib::Z_STREAM_END();
5702 if ($len == -s $read){
5703 $success = 0;
5704 CPAN->debug("hit an uncompressed file") if $CPAN::DEBUG;
5705 }
5706 $gz->gzclose();
5707 CPAN->debug("err[$err]success[$success]") if $CPAN::DEBUG;
5708 return $success;
5709 } else {
5710 return system("$CPAN::Config->{gzip} -dt $read")==0;
5711 }
5712}
5713
5714
5715# CPAN::Tarzip::TIEHANDLE
5716sub TIEHANDLE {
5717 my($class,$file) = @_;
5718 my $ret;
5719 $class->debug("file[$file]");
5720 if ($CPAN::META->has_inst("Compress::Zlib")) {
5721 my $gz = Compress::Zlib::gzopen($file,"rb") or
5722 die "Could not gzopen $file";
5723 $ret = bless {GZ => $gz}, $class;
5724 } else {
5725 my $pipe = "$CPAN::Config->{gzip} --decompress --stdout $file |";
5726 my $fh = FileHandle->new($pipe) or die "Could not pipe[$pipe]: $!";
5727 binmode $fh;
5728 $ret = bless {FH => $fh}, $class;
5729 }
5730 $ret;
5731}
5732
5733
5734# CPAN::Tarzip::READLINE
5735sub READLINE {
5736 my($self) = @_;
5737 if (exists $self->{GZ}) {
5738 my $gz = $self->{GZ};
5739 my($line,$bytesread);
5740 $bytesread = $gz->gzreadline($line);
5741 return undef if $bytesread <= 0;
5742 return $line;
5743 } else {
5744 my $fh = $self->{FH};
5745 return scalar <$fh>;
5746 }
5747}
5748
5749
5750# CPAN::Tarzip::READ
5751sub READ {
5752 my($self,$ref,$length,$offset) = @_;
5753 die "read with offset not implemented" if defined $offset;
5754 if (exists $self->{GZ}) {
5755 my $gz = $self->{GZ};
5756 my $byteread = $gz->gzread($$ref,$length);# 30eaf79e8b446ef52464b5422da328a8
5757 return $byteread;
5758 } else {
5759 my $fh = $self->{FH};
5760 return read($fh,$$ref,$length);
5761 }
5762}
5763
5764
5765# CPAN::Tarzip::DESTROY
5766sub DESTROY {
5767 my($self) = @_;
5768 if (exists $self->{GZ}) {
5769 my $gz = $self->{GZ};
5770 $gz->gzclose() if defined $gz; # hard to say if it is allowed
5771 # to be undef ever. AK, 2000-09
5772 } else {
5773 my $fh = $self->{FH};
5774 $fh->close if defined $fh;
5775 }
5776 undef $self;
5777}
5778
5779
5780# CPAN::Tarzip::untar
5781sub untar {
5782 my($class,$file) = @_;
5783 my($prefer) = 0;
5784
5785 if (0) { # makes changing order easier
5786 } elsif ($BUGHUNTING){
5787 $prefer=2;
5788 } elsif (MM->maybe_command($CPAN::Config->{gzip})
5789 &&
5790 MM->maybe_command($CPAN::Config->{'tar'})) {
5791 # should be default until Archive::Tar is fixed
5792 $prefer = 1;
5793 } elsif (
5794 $CPAN::META->has_inst("Archive::Tar")
5795 &&
5796 $CPAN::META->has_inst("Compress::Zlib") ) {
5797 $prefer = 2;
5798 } else {
5799 $CPAN::Frontend->mydie(qq{
5800CPAN.pm needs either both external programs tar and gzip installed or
5801both the modules Archive::Tar and Compress::Zlib. Neither prerequisite
5802is available. Can\'t continue.
5803});
5804 }
5805 if ($prefer==1) { # 1 => external gzip+tar
5806 my($system);
5807 my $is_compressed = $class->gtest($file);
5808 if ($is_compressed) {
5809 $system = "$CPAN::Config->{gzip} --decompress --stdout " .
5810 "< $file | $CPAN::Config->{tar} xvf -";
5811 } else {
5812 $system = "$CPAN::Config->{tar} xvf $file";
5813 }
5814 if (system($system) != 0) {
5815 # people find the most curious tar binaries that cannot handle
5816 # pipes
5817 if ($is_compressed) {
5818 (my $ungzf = $file) =~ s/\.gz(?!\n)\Z//;
5819 if (CPAN::Tarzip->gunzip($file, $ungzf)) {
5820 $CPAN::Frontend->myprint(qq{Uncompressed $file successfully\n});
5821 } else {
5822 $CPAN::Frontend->mydie(qq{Couldn\'t uncompress $file\n});
5823 }
5824 $file = $ungzf;
5825 }
5826 $system = "$CPAN::Config->{tar} xvf $file";
5827 $CPAN::Frontend->myprint(qq{Using Tar:$system:\n});
5828 if (system($system)==0) {
5829 $CPAN::Frontend->myprint(qq{Untarred $file successfully\n});
5830 } else {
5831 $CPAN::Frontend->mydie(qq{Couldn\'t untar $file\n});
5832 }
5833 return 1;
5834 } else {
5835 return 1;
5836 }
5837 } elsif ($prefer==2) { # 2 => modules
5838 my $tar = Archive::Tar->new($file,1);
5839 my $af; # archive file
5840 my @af;
5841 if ($BUGHUNTING) {
5842 # RCS 1.337 had this code, it turned out unacceptable slow but
5843 # it revealed a bug in Archive::Tar. Code is only here to hunt
5844 # the bug again. It should never be enabled in published code.
5845 # GDGraph3d-0.53 was an interesting case according to Larry
5846 # Virden.
5847 warn(">>>Bughunting code enabled<<< " x 20);
5848 for $af ($tar->list_files) {
5849 if ($af =~ m!^(/|\.\./)!) {
5850 $CPAN::Frontend->mydie("ALERT: Archive contains ".
5851 "illegal member [$af]");
5852 }
5853 $CPAN::Frontend->myprint("$af\n");
5854 $tar->extract($af); # slow but effective for finding the bug
5855 return if $CPAN::Signal;
5856 }
5857 } else {
5858 for $af ($tar->list_files) {
5859 if ($af =~ m!^(/|\.\./)!) {
5860 $CPAN::Frontend->mydie("ALERT: Archive contains ".
5861 "illegal member [$af]");
5862 }
5863 $CPAN::Frontend->myprint("$af\n");
5864 push @af, $af;
5865 return if $CPAN::Signal;
5866 }
5867 $tar->extract(@af);
5868 }
5869
5870 Mac::BuildTools::convert_files([$tar->list_files], 1)
5871 if ($^O eq 'MacOS');
5872
5873 return 1;
5874 }
5875}
5876
5877sub unzip {
5878 my($class,$file) = @_;
5879 if ($CPAN::META->has_inst("Archive::Zip")) {
5880 # blueprint of the code from Archive::Zip::Tree::extractTree();
5881 my $zip = Archive::Zip->new();
5882 my $status;
5883 $status = $zip->read($file);
5884 die "Read of file[$file] failed\n" if $status != Archive::Zip::AZ_OK();
5885 $CPAN::META->debug("Successfully read file[$file]") if $CPAN::DEBUG;
5886 my @members = $zip->members();
5887 for my $member ( @members ) {
5888 my $af = $member->fileName();
5889 if ($af =~ m!^(/|\.\./)!) {
5890 $CPAN::Frontend->mydie("ALERT: Archive contains ".
5891 "illegal member [$af]");
5892 }
5893 my $status = $member->extractToFileNamed( $af );
5894 $CPAN::META->debug("af[$af]status[$status]") if $CPAN::DEBUG;
5895 die "Extracting of file[$af] from zipfile[$file] failed\n" if
5896 $status != Archive::Zip::AZ_OK();
5897 return if $CPAN::Signal;
5898 }
5899 return 1;
5900 } else {
5901 my $unzip = $CPAN::Config->{unzip} or
5902 $CPAN::Frontend->mydie("Cannot unzip, no unzip program available");
5903 my @system = ($unzip, $file);
5904 return system(@system) == 0;
5905 }
5906}
5907
5908
5909package CPAN::Version;
5910# CPAN::Version::vcmp courtesy Jost Krieger
5911sub vcmp {
5912 my($self,$l,$r) = @_;
5913 local($^W) = 0;
5914 CPAN->debug("l[$l] r[$r]") if $CPAN::DEBUG;
5915
5916 return 0 if $l eq $r; # short circuit for quicker success
5917
5918 if ($l=~/^v/ <=> $r=~/^v/) {
5919 for ($l,$r) {
5920 next if /^v/;
5921 $_ = $self->float2vv($_);
5922 }
5923 }
5924
5925 return
5926 ($l ne "undef") <=> ($r ne "undef") ||
5927 ($] >= 5.006 &&
5928 $l =~ /^v/ &&
5929 $r =~ /^v/ &&
5930 $self->vstring($l) cmp $self->vstring($r)) ||
5931 $l <=> $r ||
5932 $l cmp $r;
5933}
5934
5935sub vgt {
5936 my($self,$l,$r) = @_;
5937 $self->vcmp($l,$r) > 0;
5938}
5939
5940sub vstring {
5941 my($self,$n) = @_;
5942 $n =~ s/^v// or die "CPAN::Version::vstring() called with invalid arg [$n]";
5943 pack "U*", split /\./, $n;
5944}
5945
5946# vv => visible vstring
5947sub float2vv {
5948 my($self,$n) = @_;
5949 my($rev) = int($n);
5950 $rev ||= 0;
5951 my($mantissa) = $n =~ /\.(\d{1,12})/; # limit to 12 digits to limit
5952 # architecture influence
5953 $mantissa ||= 0;
5954 $mantissa .= "0" while length($mantissa)%3;
5955 my $ret = "v" . $rev;
5956 while ($mantissa) {
5957 $mantissa =~ s/(\d{1,3})// or
5958 die "Panic: length>0 but not a digit? mantissa[$mantissa]";
5959 $ret .= ".".int($1);
5960 }
5961 # warn "n[$n]ret[$ret]";
5962 $ret;
5963}
5964
5965sub readable {
5966 my($self,$n) = @_;
5967 $n =~ /^([\w\-\+\.]+)/;
5968
5969 return $1 if defined $1 && length($1)>0;
5970 # if the first user reaches version v43, he will be treated as "+".
5971 # We'll have to decide about a new rule here then, depending on what
5972 # will be the prevailing versioning behavior then.
5973
5974 if ($] < 5.006) { # or whenever v-strings were introduced
5975 # we get them wrong anyway, whatever we do, because 5.005 will
5976 # have already interpreted 0.2.4 to be "0.24". So even if he
5977 # indexer sends us something like "v0.2.4" we compare wrongly.
5978
5979 # And if they say v1.2, then the old perl takes it as "v12"
5980
5981 $CPAN::Frontend->mywarn("Suspicious version string seen [$n]\n");
5982 return $n;
5983 }
5984 my $better = sprintf "v%vd", $n;
5985 CPAN->debug("n[$n] better[$better]") if $CPAN::DEBUG;
5986 return $better;
5987}
5988
5989package CPAN;
5990
59911;
5992
5993__END__
5994
5995=head1 NAME
5996
5997CPAN - query, download and build perl modules from CPAN sites
5998
5999=head1 SYNOPSIS
6000
6001Interactive mode:
6002
6003 perl -MCPAN -e shell;
6004
6005Batch mode:
6006
6007 use CPAN;
6008
6009 autobundle, clean, install, make, recompile, test
6010
6011=head1 STATUS
6012
6013This module will eventually be replaced by CPANPLUS. CPANPLUS is kind
6014of a modern rewrite from ground up with greater extensibility and more
6015features but no full compatibility. If you're new to CPAN.pm, you
6016probably should investigate if CPANPLUS is the better choice for you.
6017If you're already used to CPAN.pm you're welcome to continue using it,
6018if you accept that its development is mostly (though not completely)
6019stalled.
6020
6021=head1 DESCRIPTION
6022
6023The CPAN module is designed to automate the make and install of perl
6024modules and extensions. It includes some primitive searching capabilities and
6025knows how to use Net::FTP or LWP (or lynx or an external ftp client)
6026to fetch the raw data from the net.
6027
6028Modules are fetched from one or more of the mirrored CPAN
6029(Comprehensive Perl Archive Network) sites and unpacked in a dedicated
6030directory.
6031
6032The CPAN module also supports the concept of named and versioned
6033I<bundles> of modules. Bundles simplify the handling of sets of
6034related modules. See Bundles below.
6035
6036The package contains a session manager and a cache manager. There is
6037no status retained between sessions. The session manager keeps track
6038of what has been fetched, built and installed in the current
6039session. The cache manager keeps track of the disk space occupied by
6040the make processes and deletes excess space according to a simple FIFO
6041mechanism.
6042
6043For extended searching capabilities there's a plugin for CPAN available,
6044L<C<CPAN::WAIT>|CPAN::WAIT>. C<CPAN::WAIT> is a full-text search engine
6045that indexes all documents available in CPAN authors directories. If
6046C<CPAN::WAIT> is installed on your system, the interactive shell of
6047CPAN.pm will enable the C<wq>, C<wr>, C<wd>, C<wl>, and C<wh> commands
6048which send queries to the WAIT server that has been configured for your
6049installation.
6050
6051All other methods provided are accessible in a programmer style and in an
6052interactive shell style.
6053
6054=head2 Interactive Mode
6055
6056The interactive mode is entered by running
6057
6058 perl -MCPAN -e shell
6059
6060which puts you into a readline interface. You will have the most fun if
6061you install Term::ReadKey and Term::ReadLine to enjoy both history and
6062command completion.
6063
6064Once you are on the command line, type 'h' and the rest should be
6065self-explanatory.
6066
6067The function call C<shell> takes two optional arguments, one is the
6068prompt, the second is the default initial command line (the latter
6069only works if a real ReadLine interface module is installed).
6070
6071The most common uses of the interactive modes are
6072
6073=over 2
6074
6075=item Searching for authors, bundles, distribution files and modules
6076
6077There are corresponding one-letter commands C<a>, C<b>, C<d>, and C<m>
6078for each of the four categories and another, C<i> for any of the
6079mentioned four. Each of the four entities is implemented as a class
6080with slightly differing methods for displaying an object.
6081
6082Arguments you pass to these commands are either strings exactly matching
6083the identification string of an object or regular expressions that are
6084then matched case-insensitively against various attributes of the
6085objects. The parser recognizes a regular expression only if you
6086enclose it between two slashes.
6087
6088The principle is that the number of found objects influences how an
6089item is displayed. If the search finds one item, the result is
6090displayed with the rather verbose method C<as_string>, but if we find
6091more than one, we display each object with the terse method
6092<as_glimpse>.
6093
6094=item make, test, install, clean modules or distributions
6095
6096These commands take any number of arguments and investigate what is
6097necessary to perform the action. If the argument is a distribution
6098file name (recognized by embedded slashes), it is processed. If it is
6099a module, CPAN determines the distribution file in which this module
6100is included and processes that, following any dependencies named in
6101the module's Makefile.PL (this behavior is controlled by
6102I<prerequisites_policy>.)
6103
6104Any C<make> or C<test> are run unconditionally. An
6105
6106 install <distribution_file>
6107
6108also is run unconditionally. But for
6109
6110 install <module>
6111
6112CPAN checks if an install is actually needed for it and prints
6113I<module up to date> in the case that the distribution file containing
6114the module doesn't need to be updated.
6115
6116CPAN also keeps track of what it has done within the current session
6117and doesn't try to build a package a second time regardless if it
6118succeeded or not. The C<force> command takes as a first argument the
6119method to invoke (currently: C<make>, C<test>, or C<install>) and executes the
6120command from scratch.
6121
6122Example:
6123
6124 cpan> install OpenGL
6125 OpenGL is up to date.
6126 cpan> force install OpenGL
6127 Running make
6128 OpenGL-0.4/
6129 OpenGL-0.4/COPYRIGHT
6130 [...]
6131
6132A C<clean> command results in a
6133
6134 make clean
6135
6136being executed within the distribution file's working directory.
6137
6138=item get, readme, look module or distribution
6139
6140C<get> downloads a distribution file without further action. C<readme>
6141displays the README file of the associated distribution. C<Look> gets
6142and untars (if not yet done) the distribution file, changes to the
6143appropriate directory and opens a subshell process in that directory.
6144
6145=item ls author
6146
6147C<ls> lists all distribution files in and below an author's CPAN
6148directory. Only those files that contain modules are listed and if
6149there is more than one for any given module, only the most recent one
6150is listed.
6151
6152=item Signals
6153
6154CPAN.pm installs signal handlers for SIGINT and SIGTERM. While you are
6155in the cpan-shell it is intended that you can press C<^C> anytime and
6156return to the cpan-shell prompt. A SIGTERM will cause the cpan-shell
6157to clean up and leave the shell loop. You can emulate the effect of a
6158SIGTERM by sending two consecutive SIGINTs, which usually means by
6159pressing C<^C> twice.
6160
6161CPAN.pm ignores a SIGPIPE. If the user sets inactivity_timeout, a
6162SIGALRM is used during the run of the C<perl Makefile.PL> subprocess.
6163
6164=back
6165
6166=head2 CPAN::Shell
6167
6168The commands that are available in the shell interface are methods in
6169the package CPAN::Shell. If you enter the shell command, all your
6170input is split by the Text::ParseWords::shellwords() routine which
6171acts like most shells do. The first word is being interpreted as the
6172method to be called and the rest of the words are treated as arguments
6173to this method. Continuation lines are supported if a line ends with a
6174literal backslash.
6175
6176=head2 autobundle
6177
6178C<autobundle> writes a bundle file into the
6179C<$CPAN::Config-E<gt>{cpan_home}/Bundle> directory. The file contains
6180a list of all modules that are both available from CPAN and currently
6181installed within @INC. The name of the bundle file is based on the
6182current date and a counter.
6183
6184=head2 recompile
6185
6186recompile() is a very special command in that it takes no argument and
6187runs the make/test/install cycle with brute force over all installed
6188dynamically loadable extensions (aka XS modules) with 'force' in
6189effect. The primary purpose of this command is to finish a network
6190installation. Imagine, you have a common source tree for two different
6191architectures. You decide to do a completely independent fresh
6192installation. You start on one architecture with the help of a Bundle
6193file produced earlier. CPAN installs the whole Bundle for you, but
6194when you try to repeat the job on the second architecture, CPAN
6195responds with a C<"Foo up to date"> message for all modules. So you
6196invoke CPAN's recompile on the second architecture and you're done.
6197
6198Another popular use for C<recompile> is to act as a rescue in case your
6199perl breaks binary compatibility. If one of the modules that CPAN uses
6200is in turn depending on binary compatibility (so you cannot run CPAN
6201commands), then you should try the CPAN::Nox module for recovery.
6202
6203=head2 The four C<CPAN::*> Classes: Author, Bundle, Module, Distribution
6204
6205Although it may be considered internal, the class hierarchy does matter
6206for both users and programmer. CPAN.pm deals with above mentioned four
6207classes, and all those classes share a set of methods. A classical
6208single polymorphism is in effect. A metaclass object registers all
6209objects of all kinds and indexes them with a string. The strings
6210referencing objects have a separated namespace (well, not completely
6211separated):
6212
6213 Namespace Class
6214
6215 words containing a "/" (slash) Distribution
6216 words starting with Bundle:: Bundle
6217 everything else Module or Author
6218
6219Modules know their associated Distribution objects. They always refer
6220to the most recent official release. Developers may mark their releases
6221as unstable development versions (by inserting an underbar into the
6222module version number which will also be reflected in the distribution
6223name when you run 'make dist'), so the really hottest and newest
6224distribution is not always the default. If a module Foo circulates
6225on CPAN in both version 1.23 and 1.23_90, CPAN.pm offers a convenient
6226way to install version 1.23 by saying
6227
6228 install Foo
6229
6230This would install the complete distribution file (say
6231BAR/Foo-1.23.tar.gz) with all accompanying material. But if you would
6232like to install version 1.23_90, you need to know where the
6233distribution file resides on CPAN relative to the authors/id/
6234directory. If the author is BAR, this might be BAR/Foo-1.23_90.tar.gz;
6235so you would have to say
6236
6237 install BAR/Foo-1.23_90.tar.gz
6238
6239The first example will be driven by an object of the class
6240CPAN::Module, the second by an object of class CPAN::Distribution.
6241
6242=head2 Programmer's interface
6243
6244If you do not enter the shell, the available shell commands are both
6245available as methods (C<CPAN::Shell-E<gt>install(...)>) and as
6246functions in the calling package (C<install(...)>).
6247
6248There's currently only one class that has a stable interface -
6249CPAN::Shell. All commands that are available in the CPAN shell are
6250methods of the class CPAN::Shell. Each of the commands that produce
6251listings of modules (C<r>, C<autobundle>, C<u>) also return a list of
6252the IDs of all modules within the list.
6253
6254=over 2
6255
6256=item expand($type,@things)
6257
6258The IDs of all objects available within a program are strings that can
6259be expanded to the corresponding real objects with the
6260C<CPAN::Shell-E<gt>expand("Module",@things)> method. Expand returns a
6261list of CPAN::Module objects according to the C<@things> arguments
6262given. In scalar context it only returns the first element of the
6263list.
6264
6265=item expandany(@things)
6266
6267Like expand, but returns objects of the appropriate type, i.e.
6268CPAN::Bundle objects for bundles, CPAN::Module objects for modules and
6269CPAN::Distribution objects fro distributions.
6270
6271=item Programming Examples
6272
6273This enables the programmer to do operations that combine
6274functionalities that are available in the shell.
6275
6276 # install everything that is outdated on my disk:
6277 perl -MCPAN -e 'CPAN::Shell->install(CPAN::Shell->r)'
6278
6279 # install my favorite programs if necessary:
6280 for $mod (qw(Net::FTP Digest::MD5 Data::Dumper)){
6281 my $obj = CPAN::Shell->expand('Module',$mod);
6282 $obj->install;
6283 }
6284
6285 # list all modules on my disk that have no VERSION number
6286 for $mod (CPAN::Shell->expand("Module","/./")){
6287 next unless $mod->inst_file;
6288 # MakeMaker convention for undefined $VERSION:
6289 next unless $mod->inst_version eq "undef";
6290 print "No VERSION in ", $mod->id, "\n";
6291 }
6292
6293 # find out which distribution on CPAN contains a module:
6294 print CPAN::Shell->expand("Module","Apache::Constants")->cpan_file
6295
6296Or if you want to write a cronjob to watch The CPAN, you could list
6297all modules that need updating. First a quick and dirty way:
6298
6299 perl -e 'use CPAN; CPAN::Shell->r;'
6300
6301If you don't want to get any output in the case that all modules are
6302up to date, you can parse the output of above command for the regular
6303expression //modules are up to date// and decide to mail the output
6304only if it doesn't match. Ick?
6305
6306If you prefer to do it more in a programmer style in one single
6307process, maybe something like this suits you better:
6308
6309 # list all modules on my disk that have newer versions on CPAN
6310 for $mod (CPAN::Shell->expand("Module","/./")){
6311 next unless $mod->inst_file;
6312 next if $mod->uptodate;
6313 printf "Module %s is installed as %s, could be updated to %s from CPAN\n",
6314 $mod->id, $mod->inst_version, $mod->cpan_version;
6315 }
6316
6317If that gives you too much output every day, you maybe only want to
6318watch for three modules. You can write
6319
6320 for $mod (CPAN::Shell->expand("Module","/Apache|LWP|CGI/")){
6321
6322as the first line instead. Or you can combine some of the above
6323tricks:
6324
6325 # watch only for a new mod_perl module
6326 $mod = CPAN::Shell->expand("Module","mod_perl");
6327 exit if $mod->uptodate;
6328 # new mod_perl arrived, let me know all update recommendations
6329 CPAN::Shell->r;
6330
6331=back
6332
6333=head2 Methods in the other Classes
6334
6335The programming interface for the classes CPAN::Module,
6336CPAN::Distribution, CPAN::Bundle, and CPAN::Author is still considered
6337beta and partially even alpha. In the following paragraphs only those
6338methods are documented that have proven useful over a longer time and
6339thus are unlikely to change.
6340
6341=over 4
6342
6343=item CPAN::Author::as_glimpse()
6344
6345Returns a one-line description of the author
6346
6347=item CPAN::Author::as_string()
6348
6349Returns a multi-line description of the author
6350
6351=item CPAN::Author::email()
6352
6353Returns the author's email address
6354
6355=item CPAN::Author::fullname()
6356
6357Returns the author's name
6358
6359=item CPAN::Author::name()
6360
6361An alias for fullname
6362
6363=item CPAN::Bundle::as_glimpse()
6364
6365Returns a one-line description of the bundle
6366
6367=item CPAN::Bundle::as_string()
6368
6369Returns a multi-line description of the bundle
6370
6371=item CPAN::Bundle::clean()
6372
6373Recursively runs the C<clean> method on all items contained in the bundle.
6374
6375=item CPAN::Bundle::contains()
6376
6377Returns a list of objects' IDs contained in a bundle. The associated
6378objects may be bundles, modules or distributions.
6379
6380=item CPAN::Bundle::force($method,@args)
6381
6382Forces CPAN to perform a task that normally would have failed. Force
6383takes as arguments a method name to be called and any number of
6384additional arguments that should be passed to the called method. The
6385internals of the object get the needed changes so that CPAN.pm does
6386not refuse to take the action. The C<force> is passed recursively to
6387all contained objects.
6388
6389=item CPAN::Bundle::get()
6390
6391Recursively runs the C<get> method on all items contained in the bundle
6392
6393=item CPAN::Bundle::inst_file()
6394
6395Returns the highest installed version of the bundle in either @INC or
6396C<$CPAN::Config->{cpan_home}>. Note that this is different from
6397CPAN::Module::inst_file.
6398
6399=item CPAN::Bundle::inst_version()
6400
6401Like CPAN::Bundle::inst_file, but returns the $VERSION
6402
6403=item CPAN::Bundle::uptodate()
6404
6405Returns 1 if the bundle itself and all its members are uptodate.
6406
6407=item CPAN::Bundle::install()
6408
6409Recursively runs the C<install> method on all items contained in the bundle
6410
6411=item CPAN::Bundle::make()
6412
6413Recursively runs the C<make> method on all items contained in the bundle
6414
6415=item CPAN::Bundle::readme()
6416
6417Recursively runs the C<readme> method on all items contained in the bundle
6418
6419=item CPAN::Bundle::test()
6420
6421Recursively runs the C<test> method on all items contained in the bundle
6422
6423=item CPAN::Distribution::as_glimpse()
6424
6425Returns a one-line description of the distribution
6426
6427=item CPAN::Distribution::as_string()
6428
6429Returns a multi-line description of the distribution
6430
6431=item CPAN::Distribution::clean()
6432
6433Changes to the directory where the distribution has been unpacked and
6434runs C<make clean> there.
6435
6436=item CPAN::Distribution::containsmods()
6437
6438Returns a list of IDs of modules contained in a distribution file.
6439Only works for distributions listed in the 02packages.details.txt.gz
6440file. This typically means that only the most recent version of a
6441distribution is covered.
6442
6443=item CPAN::Distribution::cvs_import()
6444
6445Changes to the directory where the distribution has been unpacked and
6446runs something like
6447
6448 cvs -d $cvs_root import -m $cvs_log $cvs_dir $userid v$version
6449
6450there.
6451
6452=item CPAN::Distribution::dir()
6453
6454Returns the directory into which this distribution has been unpacked.
6455
6456=item CPAN::Distribution::force($method,@args)
6457
6458Forces CPAN to perform a task that normally would have failed. Force
6459takes as arguments a method name to be called and any number of
6460additional arguments that should be passed to the called method. The
6461internals of the object get the needed changes so that CPAN.pm does
6462not refuse to take the action.
6463
6464=item CPAN::Distribution::get()
6465
6466Downloads the distribution from CPAN and unpacks it. Does nothing if
6467the distribution has already been downloaded and unpacked within the
6468current session.
6469
6470=item CPAN::Distribution::install()
6471
6472Changes to the directory where the distribution has been unpacked and
6473runs the external command C<make install> there. If C<make> has not
6474yet been run, it will be run first. A C<make test> will be issued in
6475any case and if this fails, the install will be canceled. The
6476cancellation can be avoided by letting C<force> run the C<install> for
6477you.
6478
6479=item CPAN::Distribution::isa_perl()
6480
6481Returns 1 if this distribution file seems to be a perl distribution.
6482Normally this is derived from the file name only, but the index from
6483CPAN can contain a hint to achieve a return value of true for other
6484filenames too.
6485
6486=item CPAN::Distribution::look()
6487
6488Changes to the directory where the distribution has been unpacked and
6489opens a subshell there. Exiting the subshell returns.
6490
6491=item CPAN::Distribution::make()
6492
6493First runs the C<get> method to make sure the distribution is
6494downloaded and unpacked. Changes to the directory where the
6495distribution has been unpacked and runs the external commands C<perl
6496Makefile.PL> and C<make> there.
6497
6498=item CPAN::Distribution::prereq_pm()
6499
6500Returns the hash reference that has been announced by a distribution
6501as the PREREQ_PM hash in the Makefile.PL. Note: works only after an
6502attempt has been made to C<make> the distribution. Returns undef
6503otherwise.
6504
6505=item CPAN::Distribution::readme()
6506
6507Downloads the README file associated with a distribution and runs it
6508through the pager specified in C<$CPAN::Config->{pager}>.
6509
6510=item CPAN::Distribution::test()
6511
6512Changes to the directory where the distribution has been unpacked and
6513runs C<make test> there.
6514
6515=item CPAN::Distribution::uptodate()
6516
6517Returns 1 if all the modules contained in the distribution are
6518uptodate. Relies on containsmods.
6519
6520=item CPAN::Index::force_reload()
6521
6522Forces a reload of all indices.
6523
6524=item CPAN::Index::reload()
6525
6526Reloads all indices if they have been read more than
6527C<$CPAN::Config->{index_expire}> days.
6528
6529=item CPAN::InfoObj::dump()
6530
6531CPAN::Author, CPAN::Bundle, CPAN::Module, and CPAN::Distribution
6532inherit this method. It prints the data structure associated with an
6533object. Useful for debugging. Note: the data structure is considered
6534internal and thus subject to change without notice.
6535
6536=item CPAN::Module::as_glimpse()
6537
6538Returns a one-line description of the module
6539
6540=item CPAN::Module::as_string()
6541
6542Returns a multi-line description of the module
6543
6544=item CPAN::Module::clean()
6545
6546Runs a clean on the distribution associated with this module.
6547
6548=item CPAN::Module::cpan_file()
6549
6550Returns the filename on CPAN that is associated with the module.
6551
6552=item CPAN::Module::cpan_version()
6553
6554Returns the latest version of this module available on CPAN.
6555
6556=item CPAN::Module::cvs_import()
6557
6558Runs a cvs_import on the distribution associated with this module.
6559
6560=item CPAN::Module::description()
6561
6562Returns a 44 character description of this module. Only available for
6563modules listed in The Module List (CPAN/modules/00modlist.long.html
6564or 00modlist.long.txt.gz)
6565
6566=item CPAN::Module::force($method,@args)
6567
6568Forces CPAN to perform a task that normally would have failed. Force
6569takes as arguments a method name to be called and any number of
6570additional arguments that should be passed to the called method. The
6571internals of the object get the needed changes so that CPAN.pm does
6572not refuse to take the action.
6573
6574=item CPAN::Module::get()
6575
6576Runs a get on the distribution associated with this module.
6577
6578=item CPAN::Module::inst_file()
6579
6580Returns the filename of the module found in @INC. The first file found
6581is reported just like perl itself stops searching @INC when it finds a
6582module.
6583
6584=item CPAN::Module::inst_version()
6585
6586Returns the version number of the module in readable format.
6587
6588=item CPAN::Module::install()
6589
6590Runs an C<install> on the distribution associated with this module.
6591
6592=item CPAN::Module::look()
6593
6594Changes to the directory where the distribution associated with this
6595module has been unpacked and opens a subshell there. Exiting the
6596subshell returns.
6597
6598=item CPAN::Module::make()
6599
6600Runs a C<make> on the distribution associated with this module.
6601
6602=item CPAN::Module::manpage_headline()
6603
6604If module is installed, peeks into the module's manpage, reads the
6605headline and returns it. Moreover, if the module has been downloaded
6606within this session, does the equivalent on the downloaded module even
6607if it is not installed.
6608
6609=item CPAN::Module::readme()
6610
6611Runs a C<readme> on the distribution associated with this module.
6612
6613=item CPAN::Module::test()
6614
6615Runs a C<test> on the distribution associated with this module.
6616
6617=item CPAN::Module::uptodate()
6618
6619Returns 1 if the module is installed and up-to-date.
6620
6621=item CPAN::Module::userid()
6622
6623Returns the author's ID of the module.
6624
6625=back
6626
6627=head2 Cache Manager
6628
6629Currently the cache manager only keeps track of the build directory
6630($CPAN::Config->{build_dir}). It is a simple FIFO mechanism that
6631deletes complete directories below C<build_dir> as soon as the size of
6632all directories there gets bigger than $CPAN::Config->{build_cache}
6633(in MB). The contents of this cache may be used for later
6634re-installations that you intend to do manually, but will never be
6635trusted by CPAN itself. This is due to the fact that the user might
6636use these directories for building modules on different architectures.
6637
6638There is another directory ($CPAN::Config->{keep_source_where}) where
6639the original distribution files are kept. This directory is not
6640covered by the cache manager and must be controlled by the user. If
6641you choose to have the same directory as build_dir and as
6642keep_source_where directory, then your sources will be deleted with
6643the same fifo mechanism.
6644
6645=head2 Bundles
6646
6647A bundle is just a perl module in the namespace Bundle:: that does not
6648define any functions or methods. It usually only contains documentation.
6649
6650It starts like a perl module with a package declaration and a $VERSION
6651variable. After that the pod section looks like any other pod with the
6652only difference being that I<one special pod section> exists starting with
6653(verbatim):
6654
6655 =head1 CONTENTS
6656
6657In this pod section each line obeys the format
6658
6659 Module_Name [Version_String] [- optional text]
6660
6661The only required part is the first field, the name of a module
6662(e.g. Foo::Bar, ie. I<not> the name of the distribution file). The rest
6663of the line is optional. The comment part is delimited by a dash just
6664as in the man page header.
6665
6666The distribution of a bundle should follow the same convention as
6667other distributions.
6668
6669Bundles are treated specially in the CPAN package. If you say 'install
6670Bundle::Tkkit' (assuming such a bundle exists), CPAN will install all
6671the modules in the CONTENTS section of the pod. You can install your
6672own Bundles locally by placing a conformant Bundle file somewhere into
6673your @INC path. The autobundle() command which is available in the
6674shell interface does that for you by including all currently installed
6675modules in a snapshot bundle file.
6676
6677=head2 Prerequisites
6678
6679If you have a local mirror of CPAN and can access all files with
6680"file:" URLs, then you only need a perl better than perl5.003 to run
6681this module. Otherwise Net::FTP is strongly recommended. LWP may be
6682required for non-UNIX systems or if your nearest CPAN site is
6683associated with a URL that is not C<ftp:>.
6684
6685If you have neither Net::FTP nor LWP, there is a fallback mechanism
6686implemented for an external ftp command or for an external lynx
6687command.
6688
6689=head2 Finding packages and VERSION
6690
6691This module presumes that all packages on CPAN
6692
6693=over 2
6694
6695=item *
6696
6697declare their $VERSION variable in an easy to parse manner. This
6698prerequisite can hardly be relaxed because it consumes far too much
6699memory to load all packages into the running program just to determine
6700the $VERSION variable. Currently all programs that are dealing with
6701version use something like this
6702
6703 perl -MExtUtils::MakeMaker -le \
6704 'print MM->parse_version(shift)' filename
6705
6706If you are author of a package and wonder if your $VERSION can be
6707parsed, please try the above method.
6708
6709=item *
6710
6711come as compressed or gzipped tarfiles or as zip files and contain a
6712Makefile.PL (well, we try to handle a bit more, but without much
6713enthusiasm).
6714
6715=back
6716
6717=head2 Debugging
6718
6719The debugging of this module is a bit complex, because we have
6720interferences of the software producing the indices on CPAN, of the
6721mirroring process on CPAN, of packaging, of configuration, of
6722synchronicity, and of bugs within CPAN.pm.
6723
6724For code debugging in interactive mode you can try "o debug" which
6725will list options for debugging the various parts of the code. You
6726should know that "o debug" has built-in completion support.
6727
6728For data debugging there is the C<dump> command which takes the same
6729arguments as make/test/install and outputs the object's Data::Dumper
6730dump.
6731
6732=head2 Floppy, Zip, Offline Mode
6733
6734CPAN.pm works nicely without network too. If you maintain machines
6735that are not networked at all, you should consider working with file:
6736URLs. Of course, you have to collect your modules somewhere first. So
6737you might use CPAN.pm to put together all you need on a networked
6738machine. Then copy the $CPAN::Config->{keep_source_where} (but not
6739$CPAN::Config->{build_dir}) directory on a floppy. This floppy is kind
6740of a personal CPAN. CPAN.pm on the non-networked machines works nicely
6741with this floppy. See also below the paragraph about CD-ROM support.
6742
6743=head1 CONFIGURATION
6744
6745When the CPAN module is used for the first time, a configuration
6746dialog tries to determine a couple of site specific options. The
6747result of the dialog is stored in a hash reference C< $CPAN::Config >
6748in a file CPAN/Config.pm.
6749
6750The default values defined in the CPAN/Config.pm file can be
6751overridden in a user specific file: CPAN/MyConfig.pm. Such a file is
6752best placed in $HOME/.cpan/CPAN/MyConfig.pm, because $HOME/.cpan is
6753added to the search path of the CPAN module before the use() or
6754require() statements.
6755
6756The configuration dialog can be started any time later again by
6757issueing the command C< o conf init > in the CPAN shell.
6758
6759Currently the following keys in the hash reference $CPAN::Config are
6760defined:
6761
6762 build_cache size of cache for directories to build modules
6763 build_dir locally accessible directory to build modules
6764 index_expire after this many days refetch index files
6765 cache_metadata use serializer to cache metadata
6766 cpan_home local directory reserved for this package
6767 dontload_hash anonymous hash: modules in the keys will not be
6768 loaded by the CPAN::has_inst() routine
6769 gzip location of external program gzip
6770 histfile file to maintain history between sessions
6771 histsize maximum number of lines to keep in histfile
6772 inactivity_timeout breaks interactive Makefile.PLs after this
6773 many seconds inactivity. Set to 0 to never break.
6774 inhibit_startup_message
6775 if true, does not print the startup message
6776 keep_source_where directory in which to keep the source (if we do)
6777 make location of external make program
6778 make_arg arguments that should always be passed to 'make'
6779 make_install_arg same as make_arg for 'make install'
6780 makepl_arg arguments passed to 'perl Makefile.PL'
6781 pager location of external program more (or any pager)
6782 prerequisites_policy
6783 what to do if you are missing module prerequisites
6784 ('follow' automatically, 'ask' me, or 'ignore')
6785 proxy_user username for accessing an authenticating proxy
6786 proxy_pass password for accessing an authenticating proxy
6787 scan_cache controls scanning of cache ('atstart' or 'never')
6788 tar location of external program tar
6789 term_is_latin if true internal UTF-8 is translated to ISO-8859-1
6790 (and nonsense for characters outside latin range)
6791 unzip location of external program unzip
6792 urllist arrayref to nearby CPAN sites (or equivalent locations)
6793 wait_list arrayref to a wait server to try (See CPAN::WAIT)
6794 ftp_proxy, } the three usual variables for configuring
6795 http_proxy, } proxy requests. Both as CPAN::Config variables
6796 no_proxy } and as environment variables configurable.
6797
6798You can set and query each of these options interactively in the cpan
6799shell with the command set defined within the C<o conf> command:
6800
6801=over 2
6802
6803=item C<o conf E<lt>scalar optionE<gt>>
6804
6805prints the current value of the I<scalar option>
6806
6807=item C<o conf E<lt>scalar optionE<gt> E<lt>valueE<gt>>
6808
6809Sets the value of the I<scalar option> to I<value>
6810
6811=item C<o conf E<lt>list optionE<gt>>
6812
6813prints the current value of the I<list option> in MakeMaker's
6814neatvalue format.
6815
6816=item C<o conf E<lt>list optionE<gt> [shift|pop]>
6817
6818shifts or pops the array in the I<list option> variable
6819
6820=item C<o conf E<lt>list optionE<gt> [unshift|push|splice] E<lt>listE<gt>>
6821
6822works like the corresponding perl commands.
6823
6824=back
6825
6826=head2 Note on urllist parameter's format
6827
6828urllist parameters are URLs according to RFC 1738. We do a little
6829guessing if your URL is not compliant, but if you have problems with
6830file URLs, please try the correct format. Either:
6831
6832 file://localhost/whatever/ftp/pub/CPAN/
6833
6834or
6835
6836 file:///home/ftp/pub/CPAN/
6837
6838=head2 urllist parameter has CD-ROM support
6839
6840The C<urllist> parameter of the configuration table contains a list of
6841URLs that are to be used for downloading. If the list contains any
6842C<file> URLs, CPAN always tries to get files from there first. This
6843feature is disabled for index files. So the recommendation for the
6844owner of a CD-ROM with CPAN contents is: include your local, possibly
6845outdated CD-ROM as a C<file> URL at the end of urllist, e.g.
6846
6847 o conf urllist push file://localhost/CDROM/CPAN
6848
6849CPAN.pm will then fetch the index files from one of the CPAN sites
6850that come at the beginning of urllist. It will later check for each
6851module if there is a local copy of the most recent version.
6852
6853Another peculiarity of urllist is that the site that we could
6854successfully fetch the last file from automatically gets a preference
6855token and is tried as the first site for the next request. So if you
6856add a new site at runtime it may happen that the previously preferred
6857site will be tried another time. This means that if you want to disallow
6858a site for the next transfer, it must be explicitly removed from
6859urllist.
6860
6861=head1 SECURITY
6862
6863There's no strong security layer in CPAN.pm. CPAN.pm helps you to
6864install foreign, unmasked, unsigned code on your machine. We compare
6865to a checksum that comes from the net just as the distribution file
6866itself. If somebody has managed to tamper with the distribution file,
6867they may have as well tampered with the CHECKSUMS file. Future
6868development will go towards strong authentication.
6869
6870=head1 EXPORT
6871
6872Most functions in package CPAN are exported per default. The reason
6873for this is that the primary use is intended for the cpan shell or for
6874one-liners.
6875
6876=head1 POPULATE AN INSTALLATION WITH LOTS OF MODULES
6877
6878Populating a freshly installed perl with my favorite modules is pretty
6879easy if you maintain a private bundle definition file. To get a useful
6880blueprint of a bundle definition file, the command autobundle can be used
6881on the CPAN shell command line. This command writes a bundle definition
6882file for all modules that are installed for the currently running perl
6883interpreter. It's recommended to run this command only once and from then
6884on maintain the file manually under a private name, say
6885Bundle/my_bundle.pm. With a clever bundle file you can then simply say
6886
6887 cpan> install Bundle::my_bundle
6888
6889then answer a few questions and then go out for a coffee.
6890
6891Maintaining a bundle definition file means keeping track of two
6892things: dependencies and interactivity. CPAN.pm sometimes fails on
6893calculating dependencies because not all modules define all MakeMaker
6894attributes correctly, so a bundle definition file should specify
6895prerequisites as early as possible. On the other hand, it's a bit
6896annoying that many distributions need some interactive configuring. So
6897what I try to accomplish in my private bundle file is to have the
6898packages that need to be configured early in the file and the gentle
6899ones later, so I can go out after a few minutes and leave CPAN.pm
6900untended.
6901
6902=head1 WORKING WITH CPAN.pm BEHIND FIREWALLS
6903
6904Thanks to Graham Barr for contributing the following paragraphs about
6905the interaction between perl, and various firewall configurations. For
6906further informations on firewalls, it is recommended to consult the
6907documentation that comes with the ncftp program. If you are unable to
6908go through the firewall with a simple Perl setup, it is very likely
6909that you can configure ncftp so that it works for your firewall.
6910
6911=head2 Three basic types of firewalls
6912
6913Firewalls can be categorized into three basic types.
6914
6915=over 4
6916
6917=item http firewall
6918
6919This is where the firewall machine runs a web server and to access the
6920outside world you must do it via the web server. If you set environment
6921variables like http_proxy or ftp_proxy to a values beginning with http://
6922or in your web browser you have to set proxy information then you know
6923you are running an http firewall.
6924
6925To access servers outside these types of firewalls with perl (even for
6926ftp) you will need to use LWP.
6927
6928=item ftp firewall
6929
6930This where the firewall machine runs an ftp server. This kind of
6931firewall will only let you access ftp servers outside the firewall.
6932This is usually done by connecting to the firewall with ftp, then
6933entering a username like "[email protected]"
6934
6935To access servers outside these type of firewalls with perl you
6936will need to use Net::FTP.
6937
6938=item One way visibility
6939
6940I say one way visibility as these firewalls try to make themselves look
6941invisible to the users inside the firewall. An FTP data connection is
6942normally created by sending the remote server your IP address and then
6943listening for the connection. But the remote server will not be able to
6944connect to you because of the firewall. So for these types of firewall
6945FTP connections need to be done in a passive mode.
6946
6947There are two that I can think off.
6948
6949=over 4
6950
6951=item SOCKS
6952
6953If you are using a SOCKS firewall you will need to compile perl and link
6954it with the SOCKS library, this is what is normally called a 'socksified'
6955perl. With this executable you will be able to connect to servers outside
6956the firewall as if it is not there.
6957
6958=item IP Masquerade
6959
6960This is the firewall implemented in the Linux kernel, it allows you to
6961hide a complete network behind one IP address. With this firewall no
6962special compiling is needed as you can access hosts directly.
6963
6964For accessing ftp servers behind such firewalls you may need to set
6965the environment variable C<FTP_PASSIVE> to a true value, e.g.
6966
6967 env FTP_PASSIVE=1 perl -MCPAN -eshell
6968
6969or
6970
6971 perl -MCPAN -e '$ENV{FTP_PASSIVE} = 1; shell'
6972
6973
6974=back
6975
6976=back
6977
6978=head2 Configuring lynx or ncftp for going through a firewall
6979
6980If you can go through your firewall with e.g. lynx, presumably with a
6981command such as
6982
6983 /usr/local/bin/lynx -pscott:tiger
6984
6985then you would configure CPAN.pm with the command
6986
6987 o conf lynx "/usr/local/bin/lynx -pscott:tiger"
6988
6989That's all. Similarly for ncftp or ftp, you would configure something
6990like
6991
6992 o conf ncftp "/usr/bin/ncftp -f /home/scott/ncftplogin.cfg"
6993
6994Your mileage may vary...
6995
6996=head1 FAQ
6997
6998=over 4
6999
7000=item 1)
7001
7002I installed a new version of module X but CPAN keeps saying,
7003I have the old version installed
7004
7005Most probably you B<do> have the old version installed. This can
7006happen if a module installs itself into a different directory in the
7007@INC path than it was previously installed. This is not really a
7008CPAN.pm problem, you would have the same problem when installing the
7009module manually. The easiest way to prevent this behaviour is to add
7010the argument C<UNINST=1> to the C<make install> call, and that is why
7011many people add this argument permanently by configuring
7012
7013 o conf make_install_arg UNINST=1
7014
7015=item 2)
7016
7017So why is UNINST=1 not the default?
7018
7019Because there are people who have their precise expectations about who
7020may install where in the @INC path and who uses which @INC array. In
7021fine tuned environments C<UNINST=1> can cause damage.
7022
7023=item 3)
7024
7025I want to clean up my mess, and install a new perl along with
7026all modules I have. How do I go about it?
7027
7028Run the autobundle command for your old perl and optionally rename the
7029resulting bundle file (e.g. Bundle/mybundle.pm), install the new perl
7030with the Configure option prefix, e.g.
7031
7032 ./Configure -Dprefix=/usr/local/perl-5.6.78.9
7033
7034Install the bundle file you produced in the first step with something like
7035
7036 cpan> install Bundle::mybundle
7037
7038and you're done.
7039
7040=item 4)
7041
7042When I install bundles or multiple modules with one command
7043there is too much output to keep track of.
7044
7045You may want to configure something like
7046
7047 o conf make_arg "| tee -ai /root/.cpan/logs/make.out"
7048 o conf make_install_arg "| tee -ai /root/.cpan/logs/make_install.out"
7049
7050so that STDOUT is captured in a file for later inspection.
7051
7052
7053=item 5)
7054
7055I am not root, how can I install a module in a personal directory?
7056
7057You will most probably like something like this:
7058
7059 o conf makepl_arg "LIB=~/myperl/lib \
7060 INSTALLMAN1DIR=~/myperl/man/man1 \
7061 INSTALLMAN3DIR=~/myperl/man/man3"
7062 install Sybase::Sybperl
7063
7064You can make this setting permanent like all C<o conf> settings with
7065C<o conf commit>.
7066
7067You will have to add ~/myperl/man to the MANPATH environment variable
7068and also tell your perl programs to look into ~/myperl/lib, e.g. by
7069including
7070
7071 use lib "$ENV{HOME}/myperl/lib";
7072
7073or setting the PERL5LIB environment variable.
7074
7075Another thing you should bear in mind is that the UNINST parameter
7076should never be set if you are not root.
7077
7078=item 6)
7079
7080How to get a package, unwrap it, and make a change before building it?
7081
7082 look Sybase::Sybperl
7083
7084=item 7)
7085
7086I installed a Bundle and had a couple of fails. When I
7087retried, everything resolved nicely. Can this be fixed to work
7088on first try?
7089
7090The reason for this is that CPAN does not know the dependencies of all
7091modules when it starts out. To decide about the additional items to
7092install, it just uses data found in the generated Makefile. An
7093undetected missing piece breaks the process. But it may well be that
7094your Bundle installs some prerequisite later than some depending item
7095and thus your second try is able to resolve everything. Please note,
7096CPAN.pm does not know the dependency tree in advance and cannot sort
7097the queue of things to install in a topologically correct order. It
7098resolves perfectly well IFF all modules declare the prerequisites
7099correctly with the PREREQ_PM attribute to MakeMaker. For bundles which
7100fail and you need to install often, it is recommended sort the Bundle
7101definition file manually. It is planned to improve the metadata
7102situation for dependencies on CPAN in general, but this will still
7103take some time.
7104
7105=item 8)
7106
7107In our intranet we have many modules for internal use. How
7108can I integrate these modules with CPAN.pm but without uploading
7109the modules to CPAN?
7110
7111Have a look at the CPAN::Site module.
7112
7113=item 9)
7114
7115When I run CPAN's shell, I get error msg about line 1 to 4,
7116setting meta input/output via the /etc/inputrc file.
7117
7118Some versions of readline are picky about capitalization in the
7119/etc/inputrc file and specifically RedHat 6.2 comes with a
7120/etc/inputrc that contains the word C<on> in lowercase. Change the
7121occurrences of C<on> to C<On> and the bug should disappear.
7122
7123=item 10)
7124
7125Some authors have strange characters in their names.
7126
7127Internally CPAN.pm uses the UTF-8 charset. If your terminal is
7128expecting ISO-8859-1 charset, a converter can be activated by setting
7129term_is_latin to a true value in your config file. One way of doing so
7130would be
7131
7132 cpan> ! $CPAN::Config->{term_is_latin}=1
7133
7134Extended support for converters will be made available as soon as perl
7135becomes stable with regard to charset issues.
7136
7137=back
7138
7139=head1 BUGS
7140
7141We should give coverage for B<all> of the CPAN and not just the PAUSE
7142part, right? In this discussion CPAN and PAUSE have become equal --
7143but they are not. PAUSE is authors/, modules/ and scripts/. CPAN is
7144PAUSE plus the clpa/, doc/, misc/, ports/, and src/.
7145
7146Future development should be directed towards a better integration of
7147the other parts.
7148
7149If a Makefile.PL requires special customization of libraries, prompts
7150the user for special input, etc. then you may find CPAN is not able to
7151build the distribution. In that case, you should attempt the
7152traditional method of building a Perl module package from a shell.
7153
7154=head1 AUTHOR
7155
7156Andreas Koenig E<lt>[email protected]<gt>
7157
7158=head1 TRANSLATIONS
7159
7160Kawai,Takanori provides a Japanese translation of this manpage at
7161http://member.nifty.ne.jp/hippo2000/perltips/CPAN.htm
7162
7163=head1 SEE ALSO
7164
7165perl(1), CPAN::Nox(3)
7166
7167=cut
7168
Note: See TracBrowser for help on using the repository browser.