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