projects / p5sagit/p5-mst-13.2.git / blame
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | history | HEAD
Efficiency patchlet for pp_aassign()
[p5sagit/p5-mst-13.2.git] / lib / CPAN.pm
CommitLineData
5f05dabc 1package CPAN;
2use vars qw{$META $Signal $Cwd $End $Suppress_readline};
3
da199366 4$VERSION = '1.15';
5f05dabc 5
da199366 6# $Id: CPAN.pm,v 1.106 1997/01/24 12:26:36 k Exp $
5f05dabc 7
da199366 8# my $version = substr q$Revision: 1.106 $, 10; # only used during development
5f05dabc 9
10use Carp ();
11use Config ();
12use Cwd ();
13use DirHandle;
14use Exporter ();
15use ExtUtils::MakeMaker ();
16use File::Basename ();
10b2abe6 17use File::Copy ();
5f05dabc 18use File::Find;
19use File::Path ();
da199366 20use FileHandle ();
5f05dabc 21use Safe ();
10b2abe6 22use Text::ParseWords ();
5f05dabc 23
24$Cwd = Cwd::cwd();
25
26END { $End++; &cleanup; }
27
28%CPAN::DEBUG = qw(
29 CPAN 1
30 Index 2
31 InfoObj 4
32 Author 8
33 Distribution 16
34 Bundle 32
35 Module 64
36 CacheMgr 128
37 Complete 256
38 FTP 512
39 Shell 1024
40 Eval 2048
41 Config 4096
42 );
43
44$CPAN::DEBUG ||= 0;
da199366 45$CPAN::Signal ||= 0;
5f05dabc 46
47package CPAN;
10b2abe6 48use vars qw($VERSION @EXPORT $AUTOLOAD $DEBUG $META);
5f05dabc 49use strict qw(vars);
50
10b2abe6 51@CPAN::ISA = qw(CPAN::Debug Exporter MY); # the MY class from
52 # MakeMaker, gives us
53 # catfile and catdir
5f05dabc 54
10b2abe6 55$META ||= new CPAN; # In case we reeval ourselves we
56 # need a ||
5f05dabc 57
da199366 58CPAN::Config->load unless defined $CPAN::No_Config_is_ok;
5f05dabc 59
da199366 60@EXPORT = qw(
61 autobundle bundle expand force get
62 install make readme recompile shell test clean
63 );
5f05dabc 64
10b2abe6 65
66
67#-> sub CPAN::autobundle ;
5f05dabc 68sub autobundle;
10b2abe6 69#-> sub CPAN::bundle ;
5f05dabc 70sub bundle;
10b2abe6 71#-> sub CPAN::expand ;
5f05dabc 72sub expand;
10b2abe6 73#-> sub CPAN::force ;
5f05dabc 74sub force;
10b2abe6 75#-> sub CPAN::install ;
5f05dabc 76sub install;
10b2abe6 77#-> sub CPAN::make ;
5f05dabc 78sub make;
10b2abe6 79#-> sub CPAN::shell ;
5f05dabc 80sub shell;
10b2abe6 81#-> sub CPAN::clean ;
5f05dabc 82sub clean;
10b2abe6 83#-> sub CPAN::test ;
5f05dabc 84sub test;
85
10b2abe6 86#-> sub CPAN::AUTOLOAD ;
5f05dabc 87sub AUTOLOAD {
88 my($l) = $AUTOLOAD;
89 $l =~ s/.*:://;
90 my(%EXPORT);
91 @EXPORT{@EXPORT} = '';
92 if (exists $EXPORT{$l}){
93 CPAN::Shell->$l(@_);
94 } else {
95 warn "CPAN doesn't know how to autoload $AUTOLOAD :-(
96Nothing Done.
97";
98 CPAN::Shell->h;
99 }
100}
101
10b2abe6 102#-> sub CPAN::all ;
5f05dabc 103sub all {
104 my($mgr,$class) = @_;
105 CPAN->debug("mgr[$mgr] class[$class]") if $CPAN::DEBUG;
106 CPAN::Index->reload;
107 values %{ $META->{$class} };
108}
109
110# Called by shell, not in batch mode. Not clean XXX
10b2abe6 111#-> sub CPAN::checklock ;
5f05dabc 112sub checklock {
113 my($self) = @_;
114 my $lockfile = CPAN->catfile($CPAN::Config->{cpan_home},".lock");
115 if (-f $lockfile && -M _ > 0) {
da199366 116 my $fh = FileHandle->new($lockfile);
5f05dabc 117 my $other = <$fh>;
118 $fh->close;
119 if (defined $other && $other) {
120 chomp $other;
121 return if $$==$other; # should never happen
122 print qq{There seems to be running another CPAN process ($other). Trying to contact...\n};
123 if (kill 0, $other) {
124 Carp::croak qq{Other job is running.\n}.
125 qq{You may want to kill it and delete the lockfile, maybe. On UNIX try:\n}.
126 qq{ kill $other\n}.
127 qq{ rm $lockfile\n};
128 } elsif (-w $lockfile) {
129 my($ans)=
130 ExtUtils::MakeMaker::prompt
131 (qq{Other job not responding. Shall I overwrite the lockfile? (Y/N)},"y");
132 print("Ok, bye\n"), exit unless $ans =~ /^y/i;
133 } else {
134 Carp::croak(
135 qq{Lockfile $lockfile not writeable by you. Cannot proceed.\n}.
136 qq{ On UNIX try:\n}.
137 qq{ rm $lockfile\n}.
138 qq{ and then rerun us.\n}
139 );
140 }
141 }
142 }
143 File::Path::mkpath($CPAN::Config->{cpan_home});
144 my $fh;
da199366 145 unless ($fh = FileHandle->new(">$lockfile")) {
5f05dabc 146 if ($! =~ /Permission/) {
147 my $incc = $INC{'CPAN/Config.pm'};
148 my $myincc = MY->catfile($ENV{HOME},'.cpan','CPAN','MyConfig.pm');
149 print qq{
150
151Your configuration suggests that CPAN.pm should use a working
152directory of
153 $CPAN::Config->{cpan_home}
154Unfortunately we could not create the lock file
155 $lockfile
156due to permission problems.
157
158Please make sure that the configuration variable
159 \$CPAN::Config->{cpan_home}
160points to a directory where you can write a .lock file. You can set
161this variable in either
162 $incc
163or
164 $myincc
165
166};
167 }
168 Carp::croak "Could not open >$lockfile: $!";
169 }
170 print $fh $$, "\n";
171 $self->{LOCK} = $lockfile;
172 $fh->close;
173 $SIG{'TERM'} = sub { &cleanup; die "Got SIGTERM, leaving"; };
da199366 174 $SIG{'INT'} = sub {
175 my $s = $Signal == 2 ? "a second" : "another";
176 &cleanup, die "Got $s SIGINT" if $Signal;
177 $Signal = 1;
178 };
5f05dabc 179 $SIG{'__DIE__'} = \&cleanup;
180 print STDERR "Signal handler set.\n" unless $CPAN::Config->{'inhibit_startup_message'};
181}
182
10b2abe6 183#-> sub CPAN::DESTROY ;
5f05dabc 184sub DESTROY {
185 &cleanup; # need an eval?
186}
187
10b2abe6 188#-> sub CPAN::exists ;
5f05dabc 189sub exists {
190 my($mgr,$class,$id) = @_;
191 CPAN::Index->reload;
192 Carp::croak "exists called without class argument" unless $class;
193 $id ||= "";
194 exists $META->{$class}{$id};
195}
196
10b2abe6 197#-> sub CPAN::hasFTP ;
5f05dabc 198sub hasFTP {
199 my($self,$arg) = @_;
200 if (defined $arg) {
201 return $self->{'hasFTP'} = $arg;
202 } elsif (not defined $self->{'hasFTP'}) {
203 eval {require Net::FTP;};
204 $self->{'hasFTP'} = $@ ? 0 : 1;
205 }
206 return $self->{'hasFTP'};
207}
208
10b2abe6 209#-> sub CPAN::hasLWP ;
5f05dabc 210sub hasLWP {
211 my($self,$arg) = @_;
212 if (defined $arg) {
213 return $self->{'hasLWP'} = $arg;
214 } elsif (not defined $self->{'hasLWP'}) {
215 eval {require LWP;};
216 $LWP::VERSION ||= 0;
217 $self->{'hasLWP'} = $LWP::VERSION >= 4.98;
218 }
219 return $self->{'hasLWP'};
220}
221
10b2abe6 222#-> sub CPAN::hasMD5 ;
5f05dabc 223sub hasMD5 {
224 my($self,$arg) = @_;
225 if (defined $arg) {
226 $self->{'hasMD5'} = $arg;
227 } elsif (not defined $self->{'hasMD5'}) {
228 eval {require MD5;};
229 if ($@) {
da199366 230 print "MD5 security checks disabled because MD5 not installed.
231 Please consider installing MD5\n";
5f05dabc 232 $self->{'hasMD5'} = 0;
233 } else {
234 $self->{'hasMD5'}++;
235 }
236 }
237 return $self->{'hasMD5'};
238}
239
10b2abe6 240#-> sub CPAN::instance ;
5f05dabc 241sub instance {
242 my($mgr,$class,$id) = @_;
243 CPAN::Index->reload;
244 Carp::croak "instance called without class argument" unless $class;
245 $id ||= "";
246 $META->{$class}{$id} ||= $class->new(ID => $id );
247}
248
10b2abe6 249#-> sub CPAN::new ;
5f05dabc 250sub new {
251 bless {}, shift;
252}
253
10b2abe6 254#-> sub CPAN::cleanup ;
5f05dabc 255sub cleanup {
256 local $SIG{__DIE__} = '';
257 my $i = 0; my $ineval = 0; my $sub;
258 while ((undef,undef,undef,$sub) = caller(++$i)) {
259 $ineval = 1, last if $sub eq '(eval)';
260 }
261 return if $ineval && !$End;
262 return unless defined $META->{'LOCK'};
263 return unless -f $META->{'LOCK'};
264 unlink $META->{'LOCK'};
265 print STDERR "Lockfile removed.\n";
266# my $mess = Carp::longmess(@_);
267# die @_;
268}
269
10b2abe6 270#-> sub CPAN::shell ;
5f05dabc 271sub shell {
272 $Suppress_readline ||= ! -t STDIN;
273
274 my $prompt = "cpan> ";
275 local($^W) = 1;
276 my $term;
277 unless ($Suppress_readline) {
278 require Term::ReadLine;
279 import Term::ReadLine;
280 $term = new Term::ReadLine 'CPAN Monitor';
281 $readline::rl_completion_function =
282 $readline::rl_completion_function = 'CPAN::Complete::complete';
283 }
284
285 no strict;
286 $META->checklock();
287 my $cwd = Cwd::cwd();
288 # How should we determine if we have more than stub ReadLine enabled?
289 my $rl_avail = $Suppress_readline ? "suppressed" :
290 defined &Term::ReadLine::Perl::readline ? "enabled" :
10b2abe6 291 "available (get Term::ReadKey and Term::ReadLine)";
5f05dabc 292
293 print qq{
294cpan shell -- CPAN exploration and modules installation (v$CPAN::VERSION)
295Readline support $rl_avail
296
297} unless $CPAN::Config->{'inhibit_startup_message'} ;
298 while () {
299 if ($Suppress_readline) {
300 print $prompt;
301 last unless defined (chomp($_ = <>));
302 } else {
303 last unless defined ($_ = $term->readline($prompt));
304 }
305 s/^\s//;
306 next if /^$/;
307 $_ = 'h' if $_ eq '?';
308 if (/^\!/) {
309 s/^\!//;
310 my($eval) = $_;
311 package CPAN::Eval;
312 use vars qw($import_done);
313 CPAN->import(':DEFAULT') unless $import_done++;
314 CPAN->debug("eval[$eval]") if $CPAN::DEBUG;
315 eval($eval);
316 warn $@ if $@;
317 } elsif (/^q(?:uit)?$/i) {
318 last;
319 } elsif (/./) {
10b2abe6 320 my(@line);
da199366 321 if ($] < 5.00322) { # parsewords had a bug at until recently
322 @line = split;
323 } else {
324 eval { @line = Text::ParseWords::shellwords($_) };
325 warn($@), next if $@;
326 }
327 $CPAN::META->debug("line[".join("|",@line)."]") if $CPAN::DEBUG;
5f05dabc 328 my $command = shift @line;
329 eval { CPAN::Shell->$command(@line) };
330 warn $@ if $@;
331 }
332 } continue {
333 &cleanup, die if $Signal;
334 chdir $cwd;
335 print "\n";
336 }
337}
338
339package CPAN::Shell;
da199366 340use vars qw($AUTOLOAD $redef);
10b2abe6 341@CPAN::Shell::ISA = qw(CPAN::Debug);
5f05dabc 342
343# private function ro re-eval this module (handy during development)
10b2abe6 344#-> sub CPAN::Shell::AUTOLOAD ;
5f05dabc 345sub AUTOLOAD {
346 warn "CPAN::Shell doesn't know how to autoload $AUTOLOAD :-(
347Nothing Done.
348";
349 CPAN::Shell->h;
350}
351
10b2abe6 352#-> sub CPAN::Shell::h ;
5f05dabc 353sub h {
354 my($class,$about) = @_;
355 if (defined $about) {
356 print "Detailed help not yet implemented\n";
357 } else {
358 print q{
359command arguments description
360a string authors
361b or display bundles
362d /regex/ info distributions
363m or about modules
364i none anything of above
365
366r as reinstall recommendations
367u above uninstalled distributions
da199366 368See manpage for autobundle, recompile, force, look, etc.
5f05dabc 369
da199366 370make make
371test modules, make test (implies make)
372install dists, bundles, make install (implies test)
373clean "r" or "u" make clean
374readme display the README file
5f05dabc 375
376reload index|cpan load most recent indices/CPAN.pm
377h or ? display this menu
378o various set and query options
379! perl-code eval a perl command
380q quit the shell subroutine
381};
382 }
383}
384
10b2abe6 385#-> sub CPAN::Shell::a ;
5f05dabc 386sub a { print shift->format_result('Author',@_);}
10b2abe6 387#-> sub CPAN::Shell::b ;
5f05dabc 388sub b {
389 my($self,@which) = @_;
da199366 390 CPAN->debug("which[@which]") if $CPAN::DEBUG;
10b2abe6 391 my($incdir,$bdir,$dh);
392 foreach $incdir ($CPAN::Config->{'cpan_home'},@INC) {
393 $bdir = $CPAN::META->catdir($incdir,"Bundle");
394 if ($dh = DirHandle->new($bdir)) { # may fail
395 my($entry);
396 for $entry ($dh->read) {
397 next if -d $CPAN::META->catdir($bdir,$entry);
398 next unless $entry =~ s/\.pm$//;
399 $CPAN::META->instance('CPAN::Bundle',"Bundle::$entry");
400 }
401 }
5f05dabc 402 }
403 print $self->format_result('Bundle',@which);
404}
10b2abe6 405#-> sub CPAN::Shell::d ;
5f05dabc 406sub d { print shift->format_result('Distribution',@_);}
10b2abe6 407#-> sub CPAN::Shell::m ;
5f05dabc 408sub m { print shift->format_result('Module',@_);}
409
10b2abe6 410#-> sub CPAN::Shell::i ;
5f05dabc 411sub i {
412 my($self) = shift;
413 my(@args) = @_;
414 my(@type,$type,@m);
415 @type = qw/Author Bundle Distribution Module/;
416 @args = '/./' unless @args;
417 my(@result);
418 for $type (@type) {
419 push @result, $self->expand($type,@args);
420 }
421 my $result = @result==1 ? $result[0]->as_string : join "", map {$_->as_glimpse} @result;
422 $result ||= "No objects found of any type for argument @args\n";
423 print $result;
424}
425
10b2abe6 426#-> sub CPAN::Shell::o ;
5f05dabc 427sub o {
428 my($self,$o_type,@o_what) = @_;
429 $o_type ||= "";
10b2abe6 430 CPAN->debug("o_type[$o_type] o_what[".join(" | ",@o_what)."]\n");
5f05dabc 431 if ($o_type eq 'conf') {
432 shift @o_what if @o_what && $o_what[0] eq 'help';
433 if (!@o_what) {
434 my($k,$v);
435 print "CPAN::Config options:\n";
436 for $k (sort keys %CPAN::Config::can) {
437 $v = $CPAN::Config::can{$k};
438 printf " %-18s %s\n", $k, $v;
439 }
440 print "\n";
441 for $k (sort keys %$CPAN::Config) {
442 $v = $CPAN::Config->{$k};
443 if (ref $v) {
444 printf " %-18s\n", $k;
445 print map {"\t$_\n"} @{$v};
446 } else {
447 printf " %-18s %s\n", $k, $v;
448 }
449 }
450 print "\n";
451 } elsif (!CPAN::Config->edit(@o_what)) {
452 print qq[Type 'o conf' to view configuration edit options\n\n];
453 }
454 } elsif ($o_type eq 'debug') {
455 my(%valid);
456 @o_what = () if defined $o_what[0] && $o_what[0] =~ /help/i;
457 if (@o_what) {
458 while (@o_what) {
459 my($what) = shift @o_what;
460 if ( exists $CPAN::DEBUG{$what} ) {
461 $CPAN::DEBUG |= $CPAN::DEBUG{$what};
462 } elsif ($what =~ /^\d/) {
463 $CPAN::DEBUG = $what;
464 } elsif (lc $what eq 'all') {
465 my($max) = 0;
466 for (values %CPAN::DEBUG) {
467 $max += $_;
468 }
469 $CPAN::DEBUG = $max;
470 } else {
471 for (keys %CPAN::DEBUG) {
472 next unless lc($_) eq lc($what);
473 $CPAN::DEBUG |= $CPAN::DEBUG{$_};
474 }
da199366 475 print "unknown argument [$what]\n";
5f05dabc 476 }
477 }
478 } else {
479 print "Valid options for debug are ".join(", ",sort(keys %CPAN::DEBUG), 'all').
480 " or a number. Completion works on the options. Case is ignored.\n\n";
481 }
482 if ($CPAN::DEBUG) {
483 print "Options set for debugging:\n";
484 my($k,$v);
485 for $k (sort {$CPAN::DEBUG{$a} <=> $CPAN::DEBUG{$b}} keys %CPAN::DEBUG) {
486 $v = $CPAN::DEBUG{$k};
487 printf " %-14s(%s)\n", $k, $v if $v & $CPAN::DEBUG;
488 }
489 } else {
490 print "Debugging turned off completely.\n";
491 }
492 } else {
493 print qq{
494Known options:
495 conf set or get configuration variables
496 debug set or get debugging options
497};
498 }
499}
500
10b2abe6 501#-> sub CPAN::Shell::reload ;
5f05dabc 502sub reload {
503 if ($_[1] =~ /cpan/i) {
504 CPAN->debug("reloading the whole CPAN.pm") if $CPAN::DEBUG;
da199366 505 my $fh = FileHandle->new($INC{'CPAN.pm'});
506 local($/);
5f05dabc 507 undef $/;
da199366 508 $redef = 0;
509 local($SIG{__WARN__})
510 = sub {
511 if ( $_[0] =~ /Subroutine \w+ redefined/ ) {
512 ++$redef;
513 local($|) = 1;
514 print ".";
515 return;
516 }
517 warn @_;
518 };
5f05dabc 519 eval <$fh>;
520 warn $@ if $@;
da199366 521 print "\n$redef subroutines redefined\n";
5f05dabc 522 } elsif ($_[1] =~ /index/) {
523 CPAN::Index->force_reload;
524 }
525}
526
10b2abe6 527#-> sub CPAN::Shell::_binary_extensions ;
5f05dabc 528sub _binary_extensions {
529 my($self) = shift @_;
530 my(@result,$module,%seen,%need,$headerdone);
531 for $module ($self->expand('Module','/./')) {
532 my $file = $module->cpan_file;
533 next if $file eq "N/A";
534 next if $file =~ /^Contact Author/;
535 next if $file =~ /perl5[._-]\d{3}(?:[\d_]+)?\.tar[._-]gz$/;
536 next unless $module->xs_file;
da199366 537 local($|) = 1;
538 print ".";
5f05dabc 539 push @result, $module;
540 }
541# print join " | ", @result;
da199366 542 print "\n";
5f05dabc 543 return @result;
544}
545
10b2abe6 546#-> sub CPAN::Shell::recompile ;
5f05dabc 547sub recompile {
548 my($self) = shift @_;
549 my($module,@module,$cpan_file,%dist);
550 @module = $self->_binary_extensions();
551 for $module (@module){ # we force now and compile later, so we don't do it twice
552 $cpan_file = $module->cpan_file;
553 my $pack = $CPAN::META->instance('CPAN::Distribution',$cpan_file);
554 $pack->force;
555 $dist{$cpan_file}++;
556 }
557 for $cpan_file (sort keys %dist) {
558 print " CPAN: Recompiling $cpan_file\n\n";
559 my $pack = $CPAN::META->instance('CPAN::Distribution',$cpan_file);
560 $pack->install;
561 $CPAN::Signal = 0; # it's tempting to reset Signal, so we can
562 # stop a package from recompiling,
563 # e.g. IO-1.12 when we have perl5.003_10
564 }
565}
566
10b2abe6 567#-> sub CPAN::Shell::_u_r_common ;
5f05dabc 568sub _u_r_common {
569 my($self) = shift @_;
570 my($what) = shift @_;
571 CPAN->debug("self[$self] what[$what] args[@_]") if $CPAN::DEBUG;
572 Carp::croak "Usage: \$obj->_u_r_common($what)" unless defined $what;
573 Carp::croak "Usage: \$obj->_u_r_common(a|r|u)" unless $what =~ /^[aru]$/;
574 my(@args) = @_;
575 @args = '/./' unless @args;
576 my(@result,$module,%seen,%need,$headerdone,$version_zeroes);
577 $version_zeroes = 0;
578 my $sprintf = "%-25s %9s %9s %s\n";
579 for $module ($self->expand('Module',@args)) {
580 my $file = $module->cpan_file;
581 next unless defined $file; # ??
582 my($latest) = $module->cpan_version || 0;
583 my($inst_file) = $module->inst_file;
584 my($have);
585 if ($inst_file){
586 if ($what eq "a") {
587 $have = $module->inst_version;
588 } elsif ($what eq "r") {
589 $have = $module->inst_version;
590 local($^W) = 0;
591 $version_zeroes++ unless $have;
592 next if $have >= $latest;
593 } elsif ($what eq "u") {
594 next;
595 }
596 } else {
597 if ($what eq "a") {
598 next;
599 } elsif ($what eq "r") {
600 next;
601 } elsif ($what eq "u") {
602 $have = "-";
603 }
604 }
da199366 605 return if $CPAN::Signal; # this is sometimes lengthy
5f05dabc 606 $seen{$file} ||= 0;
607 if ($what eq "a") {
608 push @result, sprintf "%s %s\n", $module->id, $have;
609 } elsif ($what eq "r") {
610 push @result, $module->id;
611 next if $seen{$file}++;
612 } elsif ($what eq "u") {
613 push @result, $module->id;
614 next if $seen{$file}++;
615 next if $file =~ /^Contact/;
616 }
617 unless ($headerdone++){
618 print "\n";
619 printf $sprintf, "Package namespace", "installed", "latest", "in CPAN file";
620 }
621 $latest = substr($latest,0,8) if length($latest) > 8;
622 $have = substr($have,0,8) if length($have) > 8;
623 printf $sprintf, $module->id, $have, $latest, $file;
624 $need{$module->id}++;
5f05dabc 625 }
626 unless (%need) {
627 if ($what eq "u") {
628 print "No modules found for @args\n";
629 } elsif ($what eq "r") {
630 print "All modules are up to date for @args\n";
631 }
632 }
633 if ($what eq "r" && $version_zeroes) {
634 my $s = $version_zeroes>1 ? "s have" : " has";
635 print qq{$version_zeroes installed module$s no version number to compare\n};
636 }
637 @result;
638}
639
10b2abe6 640#-> sub CPAN::Shell::r ;
5f05dabc 641sub r {
642 shift->_u_r_common("r",@_);
643}
644
10b2abe6 645#-> sub CPAN::Shell::u ;
5f05dabc 646sub u {
647 shift->_u_r_common("u",@_);
648}
649
10b2abe6 650#-> sub CPAN::Shell::autobundle ;
5f05dabc 651sub autobundle {
652 my($self) = shift;
653 my(@bundle) = $self->_u_r_common("a",@_);
654 my($todir) = $CPAN::META->catdir($CPAN::Config->{'cpan_home'},"Bundle");
655 File::Path::mkpath($todir);
656 unless (-d $todir) {
657 print "Couldn't mkdir $todir for some reason\n";
658 return;
659 }
660 my($y,$m,$d) = (localtime)[5,4,3];
661 $y+=1900;
662 $m++;
663 my($c) = 0;
664 my($me) = sprintf "Snapshot_%04d_%02d_%02d_%02d", $y, $m, $d, $c;
665 my($to) = $CPAN::META->catfile($todir,"$me.pm");
666 while (-f $to) {
667 $me = sprintf "Snapshot_%04d_%02d_%02d_%02d", $y, $m, $d, ++$c;
668 $to = $CPAN::META->catfile($todir,"$me.pm");
669 }
da199366 670 my($fh) = FileHandle->new(">$to") or Carp::croak "Can't open >$to: $!";
5f05dabc 671 $fh->print(
672 "package Bundle::$me;\n\n",
673 "\$VERSION = '0.01';\n\n",
674 "1;\n\n",
675 "__END__\n\n",
676 "=head1 NAME\n\n",
677 "Bundle::$me - Snapshot of installation on ",
678 $Config::Config{'myhostname'},
679 " on ",
680 scalar(localtime),
681 "\n\n=head1 SYNOPSIS\n\n",
682 "perl -MCPAN -e 'install Bundle::$me'\n\n",
683 "=head1 CONTENTS\n\n",
684 join("\n", @bundle),
685 "\n\n=head1 CONFIGURATION\n\n",
686 Config->myconfig,
687 "\n\n=head1 AUTHOR\n\n",
688 "This Bundle has been generated automatically by the autobundle routine in CPAN.pm.\n",
689 );
690 $fh->close;
691 print "\nWrote bundle file
692 $to\n\n";
693}
694
10b2abe6 695#-> sub CPAN::Shell::expand ;
5f05dabc 696sub expand {
697 shift;
698 my($type,@args) = @_;
699 my($arg,@m);
700 for $arg (@args) {
701 my $regex;
702 if ($arg =~ m|^/(.*)/$|) {
703 $regex = $1;
704 }
705 my $class = "CPAN::$type";
706 my $obj;
707 if (defined $regex) {
708 for $obj ( sort {$a->id cmp $b->id} $CPAN::META->all($class)) {
da199366 709 push @m, $obj
710 if
711 $obj->id =~ /$regex/i
712 or
713 (
714 (
715 $] < 5.00303 ### provide sort of compatibility with 5.003
716 ||
717 $obj->can('name')
718 )
719 &&
720 $obj->name =~ /$regex/i
721 );
5f05dabc 722 }
723 } else {
724 my($xarg) = $arg;
725 if ( $type eq 'Bundle' ) {
726 $xarg =~ s/^(Bundle::)?(.*)/Bundle::$2/;
727 }
728 if ($CPAN::META->exists($class,$xarg)) {
729 $obj = $CPAN::META->instance($class,$xarg);
da199366 730 } elsif ($CPAN::META->exists($class,$arg)) {
5f05dabc 731 $obj = $CPAN::META->instance($class,$arg);
732 } else {
733 next;
734 }
735 push @m, $obj;
736 }
737 }
738 return @m;
739}
740
10b2abe6 741#-> sub CPAN::Shell::format_result ;
5f05dabc 742sub format_result {
743 my($self) = shift;
744 my($type,@args) = @_;
745 @args = '/./' unless @args;
746 my(@result) = $self->expand($type,@args);
747 my $result = @result==1 ? $result[0]->as_string : join "", map {$_->as_glimpse} @result;
748 $result ||= "No objects of type $type found for argument @args\n";
749 $result;
750}
751
10b2abe6 752#-> sub CPAN::Shell::rematein ;
5f05dabc 753sub rematein {
754 shift;
755 my($meth,@some) = @_;
756 my $pragma = "";
757 if ($meth eq 'force') {
758 $pragma = $meth;
759 $meth = shift @some;
760 }
761 CPAN->debug("pragma[$pragma]meth[$meth] some[@some]") if $CPAN::DEBUG;
762 my($s,@s);
763 foreach $s (@some) {
764 my $obj;
765 if (ref $s) {
766 $obj = $s;
767 } elsif ($s =~ m|/|) { # looks like a file
768 $obj = $CPAN::META->instance('CPAN::Distribution',$s);
769 } elsif ($s =~ m|^Bundle::|) {
770 $obj = $CPAN::META->instance('CPAN::Bundle',$s);
771 } else {
772 $obj = $CPAN::META->instance('CPAN::Module',$s) if $CPAN::META->exists('CPAN::Module',$s);
773 }
774 if (ref $obj) {
775 CPAN->debug(qq{pragma[$pragma] meth[$meth] obj[$obj] as_string\[}.$obj->as_string.qq{\]}) if $CPAN::DEBUG;
da199366 776 $obj->$pragma()
777 if
778 $pragma
779 &&
780 ($] < 5.00303 || $obj->can($pragma)); ### compatibility with 5.003
5f05dabc 781 $obj->$meth();
da199366 782 } elsif ($CPAN::META->exists('CPAN::Author',$s)) {
783 $obj = $CPAN::META->instance('CPAN::Author',$s);
784 print "Don't be silly, you can't $meth ", $obj->fullname, " ;-)\n";
5f05dabc 785 } else {
786 print "Warning: Cannot $meth $s, don't know what it is\n";
787 }
788 }
789}
790
10b2abe6 791#-> sub CPAN::Shell::force ;
5f05dabc 792sub force { shift->rematein('force',@_); }
da199366 793#-> sub CPAN::Shell::get ;
794sub get { shift->rematein('get',@_); }
10b2abe6 795#-> sub CPAN::Shell::readme ;
5f05dabc 796sub readme { shift->rematein('readme',@_); }
10b2abe6 797#-> sub CPAN::Shell::make ;
5f05dabc 798sub make { shift->rematein('make',@_); }
10b2abe6 799#-> sub CPAN::Shell::test ;
5f05dabc 800sub test { shift->rematein('test',@_); }
10b2abe6 801#-> sub CPAN::Shell::install ;
5f05dabc 802sub install { shift->rematein('install',@_); }
da199366 803#-> sub CPAN::Shell::clean ;
804sub clean { shift->rematein('clean',@_); }
805#-> sub CPAN::Shell::look ;
806sub look { shift->rematein('look',@_); }
5f05dabc 807
808package CPAN::FTP;
10b2abe6 809use vars qw($Ua);
810@CPAN::FTP::ISA = qw(CPAN::Debug);
5f05dabc 811
10b2abe6 812#-> sub CPAN::FTP::ftp_get ;
5f05dabc 813sub ftp_get {
814 my($class,$host,$dir,$file,$target) = @_;
815 $class->debug(
816 qq[Going to fetch file [$file] from dir [$dir]
817 on host [$host] as local [$target]\n]
818 ) if $CPAN::DEBUG;
819 my $ftp = Net::FTP->new($host);
da199366 820 return 0 unless defined $ftp;
5f05dabc 821 $ftp->debug(1) if $CPAN::DEBUG{'FTP'} & $CPAN::DEBUG;
822 $class->debug(qq[Going to ->login("anonymous","$Config::Config{'cf_email'}")\n]);
823 unless ( $ftp->login("anonymous",$Config::Config{'cf_email'}) ){
824 warn "Couldn't login on $host";
825 return;
826 }
827 # print qq[Going to ->cwd("$dir")\n];
828 unless ( $ftp->cwd($dir) ){
829 warn "Couldn't cwd $dir";
830 return;
831 }
832 $ftp->binary;
10b2abe6 833 $class->debug(qq[Going to ->get("$file","$target")\n]) if $CPAN::DEBUG;
5f05dabc 834 unless ( $ftp->get($file,$target) ){
835 warn "Couldn't fetch $file from $host";
836 return;
837 }
da199366 838 $ftp->quit; # it's ok if this fails
839 return 1;
5f05dabc 840}
841
10b2abe6 842#-> sub CPAN::FTP::localize ;
5f05dabc 843sub localize {
844 my($self,$file,$aslocal,$force) = @_;
845 $force ||= 0;
846 Carp::croak "Usage: ->localize(cpan_file,as_local_file[,$force])" unless defined $aslocal;
847 $self->debug("file [$file] aslocal [$aslocal]") if $CPAN::DEBUG;
848
849 return $aslocal if -f $aslocal && -r _ && ! $force;
850
851 my($aslocal_dir) = File::Basename::dirname($aslocal);
852 File::Path::mkpath($aslocal_dir);
853 print STDERR qq{Warning: You are not allowed to write into directory "$aslocal_dir".
854 I\'ll continue, but if you face any problems, they may be due
855 to insufficient permissions.\n} unless -w $aslocal_dir;
856
857 # Inheritance is not easier to manage than a few if/else branches
858 if ($CPAN::META->hasLWP) {
859 require LWP::UserAgent;
860 unless ($Ua) {
861 $Ua = new LWP::UserAgent;
da199366 862 my($var);
863 $Ua->proxy('ftp', $var)
864 if $var = $CPAN::Config->{'ftp_proxy'} || $ENV{'ftp_proxy'};
865 $Ua->proxy('http', $var)
866 if $var = $CPAN::Config->{'http_proxy'} || $ENV{'http_proxy'};
867 $Ua->no_proxy($var)
868 if $var = $CPAN::Config->{'no_proxy'} || $ENV{'no_proxy'};
5f05dabc 869 }
870 }
871
872 # Try the list of urls for each single object. We keep a record
873 # where we did get a file from
874 for (0..$#{$CPAN::Config->{urllist}}) {
875 my $url = $CPAN::Config->{urllist}[$_];
876 $url .= "/" unless substr($url,-1) eq "/";
877 $url .= $file;
878 $self->debug("localizing[$url]") if $CPAN::DEBUG;
879 if ($url =~ /^file:/) {
880 my $l;
881 if ($CPAN::META->hasLWP) {
882 require URI::URL;
883 my $u = new URI::URL $url;
884 $l = $u->path;
10b2abe6 885 } else { # works only on Unix, is poorly constructed, but
886 # hopefully better than nothing.
887 # RFC 1738 says fileurl BNF is
888 # fileurl = "file://" [ host | "localhost" ] "/" fpath
889 # Thanks to "Mark D. Baushke" <mdb@cisco.com> for the code
890 ($l = $url) =~ s,^file://[^/]+,,; # discard the host part
891 $l =~ s/^file://; # assume they meant file://localhost
5f05dabc 892 }
893 return $l if -f $l && -r _;
894 }
895
896 if ($CPAN::META->hasLWP) {
da199366 897 print "Fetching $url with LWP\n";
5f05dabc 898 my $res = $Ua->mirror($url, $aslocal);
899 if ($res->is_success) {
900 return $aslocal;
901 }
10b2abe6 902 }
903 if ($url =~ m|^ftp://(.*?)/(.*)/(.*)|) {
da199366 904 # that's the nice and easy way thanks to Graham
5f05dabc 905 my($host,$dir,$getfile) = ($1,$2,$3);
10b2abe6 906 if ($CPAN::META->hasFTP) {
907 $dir =~ s|/+|/|g;
908 $self->debug("Going to fetch file [$getfile]
909 from dir [$dir]
910 on host [$host]
911 as local [$aslocal]") if $CPAN::DEBUG;
912 CPAN::FTP->ftp_get($host,$dir,$getfile,$aslocal) && return $aslocal;
da199366 913 warn "Net::FTP failed for some reason\n";
914 } else {
915 warn qq{
916 Please, install Net::FTP as soon as possible. Just type
917 install Net::FTP
918 Thank you.
919
920}
921 }
922
923 # Came back if Net::FTP couldn't establish connection (or failed otherwise)
924 # Maybe they are behind a firewall, but they gave us
925 # a socksified (or other) ftp program...
926 my($netrcfile,$fh);
927 if (-x $CPAN::Config->{'ftp'}) {
928 my $timestamp = 0;
929 my($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,
930 $ctime,$blksize,$blocks) = stat($aslocal);
931 $timestamp = $mtime if defined $mtime;
932
10b2abe6 933 my($netrc) = CPAN::FTP::netrc->new;
da199366 934 my($verbose) = $CPAN::DEBUG{'FTP'} & $CPAN::DEBUG ? " -v" : "";
935
936 my $targetfile = File::Basename::basename($aslocal);
937 my(@dialog);
938 push(
939 @dialog,
940 "lcd $aslocal_dir",
941 "cd /",
942 map("cd $_", split "/", $dir), # RFC 1738
943 "bin",
944 "get $getfile $targetfile",
945 "quit"
946 );
947 if (! $netrc->netrc) {
948 warn "No ~/.netrc file found";
949 } elsif ($netrc->hasdefault || $netrc->contains($host)) {
950 CPAN->debug(
951 sprint(
952 "hasdef[%d]cont($host)[%d]",
953 $netrc->hasdefault,
954 $netrc->contains($host)
955 )
956 ) if $CPAN::DEBUG;
957 if ($netrc->protected) {
958 print(
959 qq{
960 Trying with external ftp to get
961 $url
10b2abe6 962 As this requires some features that are not thoroughly tested, we\'re
da199366 963 not sure, that we get it right....
964
965}
966 );
967 my $fh = FileHandle->new;
968 $fh->open("|$CPAN::Config->{'ftp'}$verbose $host")
969 or die "Couldn't open ftp: $!";
970 # pilot is blind now
971 CPAN->debug("dialog [".(join "|",@dialog)."]") if $CPAN::DEBUG;
972 foreach (@dialog) { $fh->print("$_\n") }
973 $fh->close; # Wait for process to complete
974 ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
975 $atime,$mtime,$ctime,$blksize,$blocks) = stat($aslocal);
976 if ($mtime > $timestamp) {
977 print "GOT $aslocal\n";
978 return $aslocal;
979 } else {
980 print "Hmm... Still failed!\n";
981 }
982 } else {
983 warn "Your $netrcfile is not correctly protected.\n";
10b2abe6 984 }
da199366 985 } else {
986 warn "Your ~/.netrc neither contains $host
987 nor does it have a default entry\n";
988 }
989
990 # OK, they don't have a valid ~/.netrc. Use 'ftp -n' then and
991 # login manually to host, using e-mail as password.
992 print qq{Issuing "ftp$verbose -n"\n};
993 unshift @dialog, "open $host", "user anonymous $Config::Config{'cf_email'}";
994 CPAN->debug("dialog [".(join "|",@dialog)."]") if $CPAN::DEBUG;
995 $fh = FileHandle->new;
996 $fh->open("|$CPAN::Config->{'ftp'} -n") or
997 die "Cannot fork: $!\n";
998 foreach (@dialog) { $fh->print("$_\n") }
999 $fh->close;
1000 ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
1001 $atime,$mtime,$ctime,$blksize,$blocks) = stat($aslocal);
1002 if ($mtime > $timestamp) {
1003 print "GOT $aslocal\n";
10b2abe6 1004 return $aslocal;
1005 } else {
da199366 1006 print "Bad luck... Still failed!\n";
1007 }
10b2abe6 1008 }
42d3b621 1009 sleep 2;
5f05dabc 1010 }
da199366 1011
1012 # what, still not succeeded?
10b2abe6 1013 if (-x $CPAN::Config->{'lynx'}) {
10b2abe6 1014 my($want_compressed);
1015 print(
1016 qq{
1017 Trying with lynx to get $url
10b2abe6 1018}
1019 );
1020 $want_compressed = $aslocal =~ s/\.gz//;
1021 my($system) = "$CPAN::Config->{'lynx'} -source '$url' > $aslocal";
1022 if (system($system)==0) {
1023 if ($want_compressed) {
1024 $system = "$CPAN::Config->{'gzip'} -dt $aslocal";
1025 if (system($system)==0) {
1026 rename $aslocal, "$aslocal.gz";
1027 } else {
1028 $system = "$CPAN::Config->{'gzip'} $aslocal";
1029 system($system);
1030 }
1031 return "$aslocal.gz";
1032 } else {
1033 $system = "$CPAN::Config->{'gzip'} -dt $aslocal";
1034 if (system($system)==0) {
1035 $system = "$CPAN::Config->{'gzip'} -d $aslocal";
1036 system($system);
1037 } else {
1038 # should be fine, eh?
1039 }
1040 return $aslocal;
1041 }
1042 }
1043 }
1044 warn "Can't access URL $url.
1045 Either get LWP or Net::FTP
1046 or an external lynx or ftp";
5f05dabc 1047 }
1048 Carp::croak("Cannot fetch $file from anywhere");
1049}
1050
10b2abe6 1051package CPAN::FTP::netrc;
1052
1053sub new {
1054 my($class) = @_;
1055 my $file = MY->catfile($ENV{HOME},".netrc");
da199366 1056
1057 my($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
1058 $atime,$mtime,$ctime,$blksize,$blocks)
1059 = stat($file);
1060 my $protected = 0;
1061
42d3b621 1062 my($fh,@machines,$hasdefault);
1063 $hasdefault = 0;
da199366 1064 $fh = FileHandle->new or die "Could not create a filehandle";
1065
1066 if($fh->open($file)){
1067 $protected = ($mode & 077) == 0;
10b2abe6 1068 local($/) = "";
42d3b621 1069 NETRC: while (<$fh>) {
da199366 1070 my(@tokens) = split " ", $_;
42d3b621 1071 TOKEN: while (@tokens) {
1072 my($t) = shift @tokens;
da199366 1073 if ($t eq "default"){
1074 $hasdefault++;
1075 warn "saw a default entry before tokens[@tokens]";
1076 last NETRC;
1077 }
42d3b621 1078 last TOKEN if $t eq "macdef";
1079 if ($t eq "machine") {
1080 push @machines, shift @tokens;
1081 }
1082 }
10b2abe6 1083 }
1084 } else {
da199366 1085 $file = $hasdefault = $protected = "";
10b2abe6 1086 }
da199366 1087
10b2abe6 1088 bless {
42d3b621 1089 'mach' => [@machines],
1090 'netrc' => $file,
1091 'hasdefault' => $hasdefault,
da199366 1092 'protected' => $protected,
10b2abe6 1093 }, $class;
1094}
1095
42d3b621 1096sub hasdefault { shift->{'hasdefault'} }
da199366 1097sub netrc { shift->{'netrc'} }
1098sub protected { shift->{'protected'} }
10b2abe6 1099sub contains {
1100 my($self,$mach) = @_;
da199366 1101 for ( @{$self->{'mach'}} ) {
1102 return 1 if $_ eq $mach;
1103 }
1104 return 0;
10b2abe6 1105}
1106
5f05dabc 1107package CPAN::Complete;
10b2abe6 1108@CPAN::Complete::ISA = qw(CPAN::Debug);
5f05dabc 1109
10b2abe6 1110#-> sub CPAN::Complete::complete ;
5f05dabc 1111sub complete {
1112 my($word,$line,$pos) = @_;
1113 $word ||= "";
1114 $line ||= "";
1115 $pos ||= 0;
1116 CPAN->debug("word [$word] line[$line] pos[$pos]") if $CPAN::DEBUG;
1117 $line =~ s/^\s*//;
da199366 1118 if ($line =~ s/^(force\s*)//) {
1119 $pos -= length($1);
1120 }
5f05dabc 1121 my @return;
1122 if ($pos == 0) {
da199366 1123 @return = grep(
1124 /^$word/,
1125 sort qw(
1126 ! a b d h i m o q r u autobundle clean
1127 make test install force reload look
1128 )
1129 );
1130 } elsif ( $line !~ /^[\!abdhimorutl]/ ) {
5f05dabc 1131 @return = ();
1132 } elsif ($line =~ /^a\s/) {
1133 @return = completex('CPAN::Author',$word);
1134 } elsif ($line =~ /^b\s/) {
1135 @return = completex('CPAN::Bundle',$word);
1136 } elsif ($line =~ /^d\s/) {
1137 @return = completex('CPAN::Distribution',$word);
da199366 1138 } elsif ($line =~ /^([mru]|make|clean|test|install|readme|look)\s/ ) {
5f05dabc 1139 @return = (completex('CPAN::Module',$word),completex('CPAN::Bundle',$word));
1140 } elsif ($line =~ /^i\s/) {
1141 @return = complete_any($word);
1142 } elsif ($line =~ /^reload\s/) {
1143 @return = complete_reload($word,$line,$pos);
1144 } elsif ($line =~ /^o\s/) {
1145 @return = complete_option($word,$line,$pos);
1146 } else {
1147 @return = ();
1148 }
1149 return @return;
1150}
1151
10b2abe6 1152#-> sub CPAN::Complete::completex ;
5f05dabc 1153sub completex {
1154 my($class, $word) = @_;
1155 grep /^\Q$word\E/, map { $_->id } $CPAN::META->all($class);
1156}
1157
10b2abe6 1158#-> sub CPAN::Complete::complete_any ;
5f05dabc 1159sub complete_any {
1160 my($word) = shift;
1161 return (
1162 completex('CPAN::Author',$word),
1163 completex('CPAN::Bundle',$word),
1164 completex('CPAN::Distribution',$word),
1165 completex('CPAN::Module',$word),
1166 );
1167}
1168
10b2abe6 1169#-> sub CPAN::Complete::complete_reload ;
5f05dabc 1170sub complete_reload {
1171 my($word,$line,$pos) = @_;
1172 $word ||= "";
1173 my(@words) = split " ", $line;
1174 CPAN->debug("word[$word] line[$line] pos[$pos]") if $CPAN::DEBUG;
1175 my(@ok) = qw(cpan index);
1176 return @ok if @words==1;
1177 return grep /^\Q$word\E/, @ok if @words==2 && $word;
1178}
1179
10b2abe6 1180#-> sub CPAN::Complete::complete_option ;
5f05dabc 1181sub complete_option {
1182 my($word,$line,$pos) = @_;
1183 $word ||= "";
1184 my(@words) = split " ", $line;
1185 CPAN->debug("word[$word] line[$line] pos[$pos]") if $CPAN::DEBUG;
1186 my(@ok) = qw(conf debug);
1187 return @ok if @words==1;
1188 return grep /^\Q$word\E/, @ok if @words==2 && $word;
1189 if (0) {
1190 } elsif ($words[1] eq 'index') {
1191 return ();
1192 } elsif ($words[1] eq 'conf') {
1193 return CPAN::Config::complete(@_);
1194 } elsif ($words[1] eq 'debug') {
1195 return sort grep /^\Q$word\E/, sort keys %CPAN::DEBUG, 'all';
1196 }
1197}
1198
1199package CPAN::Index;
10b2abe6 1200use vars qw($last_time);
1201@CPAN::Index::ISA = qw(CPAN::Debug);
5f05dabc 1202$last_time ||= 0;
1203
10b2abe6 1204#-> sub CPAN::Index::force_reload ;
5f05dabc 1205sub force_reload {
1206 my($class) = @_;
1207 $CPAN::Index::last_time = 0;
1208 $class->reload(1);
1209}
1210
10b2abe6 1211#-> sub CPAN::Index::reload ;
5f05dabc 1212sub reload {
1213 my($cl,$force) = @_;
1214 my $time = time;
1215
1216 # XXX check if a newer one is available. (We currently read it from time to time)
1217 return if $last_time + $CPAN::Config->{index_expire}*86400 > $time;
1218 $last_time = $time;
1219
1220 $cl->read_authindex($cl->reload_x("authors/01mailrc.txt.gz","01mailrc.gz",$force));
1221 return if $CPAN::Signal; # this is sometimes lengthy
1222 $cl->read_modpacks($cl->reload_x("modules/02packages.details.txt.gz","02packag.gz",$force));
1223 return if $CPAN::Signal; # this is sometimes lengthy
1224 $cl->read_modlist($cl->reload_x("modules/03modlist.data.gz","03mlist.gz",$force));
1225}
1226
10b2abe6 1227#-> sub CPAN::Index::reload_x ;
5f05dabc 1228sub reload_x {
1229 my($cl,$wanted,$localname,$force) = @_;
1230 $force ||= 0;
1231 my $abs_wanted = CPAN->catfile($CPAN::Config->{'keep_source_where'},$localname);
1232 if (-f $abs_wanted && -M $abs_wanted < $CPAN::Config->{'index_expire'} && !$force) {
1233 my($s) = $CPAN::Config->{'index_expire'} != 1;
1234 $cl->debug(qq{$abs_wanted younger than $CPAN::Config->{'index_expire'} day$s. I\'ll use that.\n});
1235 return $abs_wanted;
1236 } else {
1237 $force ||= 1;
1238 }
1239 return CPAN::FTP->localize($wanted,$abs_wanted,$force);
1240}
1241
10b2abe6 1242#-> sub CPAN::Index::read_authindex ;
5f05dabc 1243sub read_authindex {
1244 my($cl,$index_target) = @_;
1245 my $pipe = "$CPAN::Config->{gzip} --decompress --stdout $index_target";
1246 warn "Going to read $index_target\n";
da199366 1247 my $fh = FileHandle->new("$pipe|");
5f05dabc 1248 while (<$fh>) {
1249 chomp;
1250 my($userid,$fullname,$email) = /alias\s+(\S+)\s+\"([^\"\<]+)\s+<([^\>]+)\>\"/;
1251 next unless $userid && $fullname && $email;
1252
1253 # instantiate an author object
1254 my $userobj = $CPAN::META->instance('CPAN::Author',$userid);
1255 $userobj->set('FULLNAME' => $fullname, 'EMAIL' => $email);
1256 return if $CPAN::Signal;
1257 }
1258 $fh->close;
1259 $? and Carp::croak "FAILED $pipe: exit status [$?]";
1260}
1261
10b2abe6 1262#-> sub CPAN::Index::read_modpacks ;
5f05dabc 1263sub read_modpacks {
1264 my($cl,$index_target) = @_;
1265 my $pipe = "$CPAN::Config->{gzip} --decompress --stdout $index_target";
1266 warn "Going to read $index_target\n";
da199366 1267 my $fh = FileHandle->new("$pipe|");
5f05dabc 1268 while (<$fh>) {
1269 next if 1../^\s*$/;
1270 chomp;
1271 my($mod,$version,$dist) = split;
1272 $version =~ s/^\+//;
1273
1274 # if it as a bundle, instatiate a bundle object
10b2abe6 1275 my($bundle);
1276 if ($mod =~ /^Bundle::(.*)/) {
1277 $bundle = $1;
1278 }
5f05dabc 1279
1280 if ($mod eq 'CPAN') {
1281 local($^W)=0;
1282 if ($version > $CPAN::VERSION){
1283 print qq{
1284 Hey, you know what? There\'s a new CPAN.pm version (v$version)
1285 available! I\'d suggest--provided you have time--you try
1286 install CPAN
1287 reload cpan
1288 without quitting the current session. It should be a seemless upgrade
1289 while we are running...
1290};
1291 sleep 2;
1292 print qq{\n};
1293 }
1294 }
1295
1296 my($id);
1297 if ($bundle){
1298 $id = $CPAN::META->instance('CPAN::Bundle',$mod);
1299 $id->set('CPAN_VERSION' => $version, 'CPAN_FILE' => $dist);
1300# This "next" makes us faster but if the job is running long, we ignore
1301# rereads which is bad. So we have to be a bit slower again.
1302# } elsif ($CPAN::META->exists('CPAN::Module',$mod)) {
1303# next;
1304 } else {
1305 # instantiate a module object
1306 $id = $CPAN::META->instance('CPAN::Module',$mod);
1307 $id->set('CPAN_VERSION' => $version, 'CPAN_FILE' => $dist);
1308 }
1309
1310 # determine the author
1311 my($userid) = $dist =~ /([^\/]+)/;
1312 $id->set('CPAN_USERID' => $userid) if $userid =~ /\w/;
1313
1314 # instantiate a distribution object
1315 unless ($CPAN::META->exists('CPAN::Distribution',$dist)) {
1316 $CPAN::META->instance(
1317 'CPAN::Distribution' => $dist
1318 )->set(
1319 'CPAN_USERID' => $userid
1320 )
1321 if $userid =~ /\w/;
1322 }
1323
1324 return if $CPAN::Signal;
1325 }
1326 $fh->close;
1327 $? and Carp::croak "FAILED $pipe: exit status [$?]";
1328}
1329
10b2abe6 1330#-> sub CPAN::Index::read_modlist ;
5f05dabc 1331sub read_modlist {
1332 my($cl,$index_target) = @_;
1333 my $pipe = "$CPAN::Config->{gzip} --decompress --stdout $index_target";
1334 warn "Going to read $index_target\n";
da199366 1335 my $fh = FileHandle->new("$pipe|");
5f05dabc 1336 my $eval = "";
1337 while (<$fh>) {
1338 next if 1../^\s*$/;
1339 next if /use vars/; # will go away in 03...
1340 $eval .= $_;
1341 return if $CPAN::Signal;
1342 }
1343 $eval .= q{CPAN::Modulelist->data;};
1344 local($^W) = 0;
1345 my($comp) = Safe->new("CPAN::Safe1");
1346 my $ret = $comp->reval($eval);
1347 Carp::confess($@) if $@;
1348 return if $CPAN::Signal;
1349 for (keys %$ret) {
1350 my $obj = $CPAN::META->instance(CPAN::Module,$_);
1351 $obj->set(%{$ret->{$_}});
1352 return if $CPAN::Signal;
1353 }
1354}
1355
1356package CPAN::InfoObj;
10b2abe6 1357@CPAN::InfoObj::ISA = qw(CPAN::Debug);
5f05dabc 1358
10b2abe6 1359#-> sub CPAN::InfoObj::new ;
5f05dabc 1360sub new { my $this = bless {}, shift; %$this = @_; $this }
1361
10b2abe6 1362#-> sub CPAN::InfoObj::set ;
5f05dabc 1363sub set {
1364 my($self,%att) = @_;
1365 my(%oldatt) = %$self;
1366 %$self = (%oldatt, %att);
1367}
1368
10b2abe6 1369#-> sub CPAN::InfoObj::id ;
5f05dabc 1370sub id { shift->{'ID'} }
1371
10b2abe6 1372#-> sub CPAN::InfoObj::as_glimpse ;
5f05dabc 1373sub as_glimpse {
1374 my($self) = @_;
1375 my(@m);
1376 my $class = ref($self);
1377 $class =~ s/^CPAN:://;
1378 push @m, sprintf "%-15s %s\n", $class, $self->{ID};
1379 join "", @m;
1380}
1381
10b2abe6 1382#-> sub CPAN::InfoObj::as_string ;
5f05dabc 1383sub as_string {
1384 my($self) = @_;
1385 my(@m);
1386 my $class = ref($self);
1387 $class =~ s/^CPAN:://;
1388 push @m, $class, " id = $self->{ID}\n";
1389 for (sort keys %$self) {
1390 next if $_ eq 'ID';
1391 my $extra = "";
1392 $_ eq "CPAN_USERID" and $extra = " (".$self->author.")";
da199366 1393 if (ref($self->{$_}) eq "ARRAY") { # Should we setup a language interface? XXX
5f05dabc 1394 push @m, sprintf " %-12s %s%s\n", $_, "@{$self->{$_}}", $extra;
1395 } else {
1396 push @m, sprintf " %-12s %s%s\n", $_, $self->{$_}, $extra;
1397 }
1398 }
1399 join "", @m, "\n";
1400}
1401
10b2abe6 1402#-> sub CPAN::InfoObj::author ;
5f05dabc 1403sub author {
1404 my($self) = @_;
1405 $CPAN::META->instance(CPAN::Author,$self->{CPAN_USERID})->fullname;
1406}
1407
1408package CPAN::Author;
10b2abe6 1409@CPAN::Author::ISA = qw(CPAN::Debug CPAN::InfoObj);
5f05dabc 1410
10b2abe6 1411#-> sub CPAN::Author::as_glimpse ;
5f05dabc 1412sub as_glimpse {
1413 my($self) = @_;
1414 my(@m);
1415 my $class = ref($self);
1416 $class =~ s/^CPAN:://;
1417 push @m, sprintf "%-15s %s (%s)\n", $class, $self->{ID}, $self->fullname;
1418 join "", @m;
1419}
1420
10b2abe6 1421# Dead code, I would have liked to have,,, but it was never reached,,,
1422#sub make {
1423# my($self) = @_;
1424# return "Don't be silly, you can't make $self->{FULLNAME} ;-)\n";
1425#}
1426
1427#-> sub CPAN::Author::fullname ;
5f05dabc 1428sub fullname { shift->{'FULLNAME'} }
1429*name = \&fullname;
10b2abe6 1430#-> sub CPAN::Author::email ;
5f05dabc 1431sub email { shift->{'EMAIL'} }
1432
1433package CPAN::Distribution;
10b2abe6 1434@CPAN::Distribution::ISA = qw(CPAN::Debug CPAN::InfoObj);
5f05dabc 1435
10b2abe6 1436#-> sub CPAN::Distribution::called_for ;
5f05dabc 1437sub called_for {
1438 my($self,$id) = @_;
1439 $self->{'CALLED_FOR'} = $id if defined $id;
1440 return $self->{'CALLED_FOR'};
1441}
1442
10b2abe6 1443#-> sub CPAN::Distribution::get ;
5f05dabc 1444sub get {
1445 my($self) = @_;
1446 EXCUSE: {
1447 my @e;
1448 exists $self->{'build_dir'} and push @e, "Unwrapped into directory $self->{'build_dir'}";
1449 print join "", map {" $_\n"} @e and return if @e;
1450 }
1451 my($local_file);
1452 my($local_wanted) =
1453 CPAN->catfile(
1454 $CPAN::Config->{keep_source_where},
1455 "authors",
1456 "id",
1457 split("/",$self->{ID})
1458 );
1459
1460 $self->debug("Doing localize") if $CPAN::DEBUG;
1461 $local_file = CPAN::FTP->localize("authors/id/$self->{ID}", $local_wanted);
1462 $self->{localfile} = $local_file;
1463 my $builddir = $CPAN::META->{cachemgr}->dir;
1464 $self->debug("doing chdir $builddir") if $CPAN::DEBUG;
1465 chdir $builddir or Carp::croak("Couldn't chdir $builddir: $!");
1466 my $packagedir;
1467
1468 $self->debug("local_file[$local_file]") if $CPAN::DEBUG;
da199366 1469 if ($CPAN::META->hasMD5) {
1470 $self->verifyMD5;
1471 }
5f05dabc 1472 if ($local_file =~ /(\.tar\.(gz|Z)|\.tgz|\.zip)$/i){
1473 $self->debug("Removing tmp") if $CPAN::DEBUG;
1474 File::Path::rmtree("tmp");
1475 mkdir "tmp", 0777 or Carp::croak "Couldn't mkdir tmp: $!";
1476 chdir "tmp";
1477 $self->debug("Changed directory to tmp") if $CPAN::DEBUG;
1478 if ($local_file =~ /z$/i){
1479 $self->{archived} = "tar";
1480 if (system("$CPAN::Config->{gzip} --decompress --stdout $local_file | $CPAN::Config->{tar} xvf -")==0) {
1481 $self->{unwrapped} = "YES";
1482 } else {
1483 $self->{unwrapped} = "NO";
1484 }
1485 } elsif ($local_file =~ /zip$/i) {
1486 $self->{archived} = "zip";
1487 if (system("$CPAN::Config->{unzip} $local_file")==0) {
1488 $self->{unwrapped} = "YES";
1489 } else {
1490 $self->{unwrapped} = "NO";
1491 }
1492 }
1493 # Let's check if the package has its own directory.
1494 opendir DIR, "." or Carp::croak("Weird: couldn't opendir .: $!");
1495 my @readdir = grep $_ !~ /^\.\.?$/, readdir DIR; ### MAC??
1496 closedir DIR;
1497 my ($distdir,$packagedir);
1498 if (@readdir == 1 && -d $readdir[0]) {
1499 $distdir = $readdir[0];
1500 $packagedir = $CPAN::META->catdir($builddir,$distdir);
1501 -d $packagedir and print "Removing previously used $packagedir\n";
1502 File::Path::rmtree($packagedir);
10b2abe6 1503 rename($distdir,$packagedir) or Carp::confess("Couldn't rename $distdir to $packagedir: $!");
5f05dabc 1504 } else {
1505 my $pragmatic_dir = $self->{'CPAN_USERID'} . '000';
1506 $pragmatic_dir =~ s/\W_//g;
1507 $pragmatic_dir++ while -d "../$pragmatic_dir";
1508 $packagedir = $CPAN::META->catdir($builddir,$pragmatic_dir);
1509 File::Path::mkpath($packagedir);
1510 my($f);
1511 for $f (@readdir) { # is already without "." and ".."
1512 my $to = $CPAN::META->catdir($packagedir,$f);
10b2abe6 1513 rename($f,$to) or Carp::confess("Couldn't rename $f to $to: $!");
5f05dabc 1514 }
1515 }
1516 $self->{'build_dir'} = $packagedir;
1517
1518 chdir "..";
1519 $self->debug("Changed directory to .. (self is $self [".$self->as_string."])") if $CPAN::DEBUG;
1520 File::Path::rmtree("tmp");
1521 if ($CPAN::Config->{keep_source_where} =~ /^no/i ){
1522 print "Going to unlink $local_file\n";
1523 unlink $local_file or Carp::carp "Couldn't unlink $local_file";
1524 }
1525 my($makefilepl) = $CPAN::META->catfile($packagedir,"Makefile.PL");
1526 unless (-f $makefilepl) {
1527 my($configure) = $CPAN::META->catfile($packagedir,"Configure");
1528 if (-f $configure) {
1529 # do we have anything to do?
1530 $self->{'configure'} = $configure;
1531 } else {
da199366 1532 my $fh = FileHandle->new(">$makefilepl") or Carp::croak("Could not open >$makefilepl");
5f05dabc 1533 my $cf = $self->called_for || "unknown";
1534 $fh->print(qq{
1535# This Makefile.PL has been autogenerated by the module CPAN.pm
1536# Autogenerated on: }.scalar localtime().qq{
1537 use ExtUtils::MakeMaker;
1538 WriteMakefile(NAME => q[$cf]);
1539});
1540 print qq{Package comes without Makefile.PL.\n}.
1541 qq{ Writing one on our own (calling it $cf)\n};
1542 }
1543 }
1544 } else {
1545 $self->{archived} = "NO";
1546 }
1547 return $self;
1548}
1549
10b2abe6 1550#-> sub CPAN::Distribution::new ;
5f05dabc 1551sub new {
1552 my($class,%att) = @_;
1553
1554 $CPAN::META->{cachemgr} ||= CPAN::CacheMgr->new();
1555
1556 my $this = { %att };
1557 return bless $this, $class;
1558}
1559
da199366 1560#-> sub CPAN::Distribution::look ;
1561sub look {
1562 my($self) = @_;
1563 if ( $CPAN::Config->{'shell'} ) {
1564 print qq{
1565Trying to open a subshell in the build directory...
1566};
1567 } else {
1568 print qq{
1569Your configuration does not define a value for subshells.
1570Please define it with "o conf shell <your shell>"
1571};
1572 return;
1573 }
1574 my $dist = $self->id;
1575 my $dir = $self->dir or $self->get;
1576 $dir = $self->dir;
1577 my $pwd = Cwd::cwd();
1578 chdir($dir);
1579 print qq{Working directory is $dir.\n};
1580 system($CPAN::Config->{'shell'})==0 or die "Subprocess shell error";
1581 chdir($pwd);
1582}
1583
10b2abe6 1584#-> sub CPAN::Distribution::readme ;
5f05dabc 1585sub readme {
1586 my($self) = @_;
da199366 1587 my($dist) = $self->id;
1588 my($sans,$suffix) = $dist =~ /(.+)\.(tgz|tar[\._-]gz|tar\.Z|zip)$/;
1589 $self->debug("sans[$sans] suffix[$suffix]\n") if $CPAN::DEBUG;
1590 my($local_file);
1591 my($local_wanted) =
1592 CPAN->catfile(
1593 $CPAN::Config->{keep_source_where},
1594 "authors",
1595 "id",
1596 split("/","$sans.readme"),
1597 );
1598 $self->debug("Doing localize") if $CPAN::DEBUG;
1599 $local_file = CPAN::FTP->localize("authors/id/$sans.readme", $local_wanted);
1600 my $fh_pager = FileHandle->new;
1601 $fh_pager->open("|$CPAN::Config->{'pager'}") or die "Could not open pager $CPAN::Config->{'pager'}: $!";
1602 my $fh_readme = FileHandle->new;
1603 $fh_readme->open($local_file) or die "Could not open $local_file: $!";
1604 $fh_pager->print(<$fh_readme>);
5f05dabc 1605}
1606
10b2abe6 1607#-> sub CPAN::Distribution::verifyMD5 ;
5f05dabc 1608sub verifyMD5 {
1609 my($self) = @_;
1610 EXCUSE: {
1611 my @e;
1612 $self->{MD5_STATUS} and push @e, "MD5 Checksum was ok";
1613 print join "", map {" $_\n"} @e and return if @e;
1614 }
1615 my($local_file);
1616 my(@local) = split("/",$self->{ID});
1617 my($basename) = pop @local;
1618 push @local, "CHECKSUMS";
1619 my($local_wanted) =
1620 CPAN->catfile(
1621 $CPAN::Config->{keep_source_where},
1622 "authors",
1623 "id",
1624 @local
1625 );
1626 local($") = "/";
1627 if (
1628 -f $local_wanted
1629 &&
1630 $self->MD5_check_file($local_wanted,$basename)
1631 ) {
1632 return $self->{MD5_STATUS}="OK";
1633 }
1634 $local_file = CPAN::FTP->localize("authors/id/@local", $local_wanted, 'force>:-{');
1635 my($checksum_pipe);
1636 if ($local_file) {
1637 # fine
1638 } else {
1639 $local[-1] .= ".gz";
1640 $local_file = CPAN::FTP->localize(
1641 "authors/id/@local",
1642 "$local_wanted.gz",
1643 'force>:-{'
1644 );
1645 my $system = "$CPAN::Config->{gzip} --decompress $local_file";
1646 system($system)==0 or die "Could not uncompress $local_file";
1647 $local_file =~ s/\.gz$//;
1648 }
1649 $self->MD5_check_file($local_file,$basename);
1650}
1651
10b2abe6 1652#-> sub CPAN::Distribution::MD5_check_file ;
5f05dabc 1653sub MD5_check_file {
1654 my($self,$lfile,$basename) = @_;
1655 my($cksum);
da199366 1656 my $fh = new FileHandle;
5f05dabc 1657 local($/)=undef;
1658 if (open $fh, $lfile){
1659 my $eval = <$fh>;
1660 close $fh;
1661 my($comp) = Safe->new();
1662 $cksum = $comp->reval($eval);
1663 Carp::confess($@) if $@;
1664 if ($cksum->{$basename}->{md5}) {
1665 $self->debug("Found checksum for $basename: $cksum->{$basename}->{md5}\n") if $CPAN::DEBUG;
1666 my $file = $self->{localfile};
1667 my $pipe = "$CPAN::Config->{gzip} --decompress --stdout $self->{localfile}|";
1668 if (
1669 open($fh, $file) && $self->eq_MD5($fh,$cksum->{$basename}->{md5})
1670 or
1671 open($fh, $pipe) && $self->eq_MD5($fh,$cksum->{$basename}->{'md5-ungz'})
1672 ){
1673 print "Checksum for $file ok\n";
1674 return $self->{MD5_STATUS}="OK";
1675 } else {
1676 die join(
1677 "",
1678 "\nChecksum mismatch for distribution file. Please investigate.\n\n",
1679 $self->as_string,
1680 $CPAN::META->instance('CPAN::Author',$self->{CPAN_USERID})->as_string,
1681 "Please contact the author or your CPAN site admin"
1682 );
1683 }
1684 close $fh if fileno($fh);
1685 } else {
1686 print "No md5 checksum for $basename in local $lfile\n";
1687 return;
1688 }
1689 } else {
1690 Carp::carp "Could not open $lfile for reading";
1691 }
1692}
1693
10b2abe6 1694#-> sub CPAN::Distribution::eq_MD5 ;
5f05dabc 1695sub eq_MD5 {
1696 my($self,$fh,$expectMD5) = @_;
1697 my $md5 = new MD5;
1698 $md5->addfile($fh);
1699 my $hexdigest = $md5->hexdigest;
1700 $hexdigest eq $expectMD5;
1701}
1702
10b2abe6 1703#-> sub CPAN::Distribution::force ;
5f05dabc 1704sub force {
1705 my($self) = @_;
1706 $self->{'force_update'}++;
1707 delete $self->{'MD5_STATUS'};
1708 delete $self->{'archived'};
1709 delete $self->{'build_dir'};
1710 delete $self->{'localfile'};
1711 delete $self->{'make'};
1712 delete $self->{'install'};
1713 delete $self->{'unwrapped'};
1714 delete $self->{'writemakefile'};
1715}
1716
10b2abe6 1717#-> sub CPAN::Distribution::make ;
5f05dabc 1718sub make {
1719 my($self) = @_;
1720 $self->debug($self->id) if $CPAN::DEBUG;
1721 print "Running make\n";
1722 $self->get;
5f05dabc 1723 EXCUSE: {
1724 my @e;
1725 $self->{archived} eq "NO" and push @e, "Is neither a tar nor a zip archive.";
1726 $self->{unwrapped} eq "NO" and push @e, "had problems unarchiving. Please build manually";
1727 exists $self->{writemakefile} && $self->{writemakefile} eq "NO" and push @e, "Had some problem writing Makefile";
1728 defined $self->{'make'} and push @e, "Has already been processed within this session";
1729 print join "", map {" $_\n"} @e and return if @e;
1730 }
da199366 1731 print "\n CPAN.pm: Going to build ".$self->id."\n\n";
5f05dabc 1732 my $builddir = $self->dir;
1733 chdir $builddir or Carp::croak("Couldn't chdir $builddir: $!");
1734 $self->debug("Changed directory to $builddir") if $CPAN::DEBUG;
1735
1736 my $system;
1737 if ($self->{'configure'}) {
1738 $system = $self->{'configure'};
1739 } else {
1740 my($perl) = $^X =~ /^\.\// ? "$CPAN::Cwd/$^X" : $^X; # XXX subclassing folks, forgive me!
1741 $system = "$perl Makefile.PL $CPAN::Config->{makepl_arg}";
1742 }
10b2abe6 1743 $SIG{ALRM} = sub { die "inactivity_timeout reached\n" };
1744 my($ret,$pid);
1745 $@ = "";
1746 if ($CPAN::Config->{inactivity_timeout}) {
1747 eval {
1748 alarm $CPAN::Config->{inactivity_timeout};
1749 #$SIG{CHLD} = \&REAPER;
1750 if (defined($pid=fork)) {
1751 if ($pid) { #parent
1752 wait;
1753 } else { #child
1754 exec $system;
1755 }
1756 } else {
1757 print "Cannot fork: $!";
1758 return;
1759 }
1760 $ret = system($system);
1761 };
1762 alarm 0;
1763 } else {
1764 $ret = system($system);
1765 }
1766 if ($@){
1767 kill 9, $pid;
1768 waitpid $pid, 0;
1769 print $@;
1770 $self->{writemakefile} = "NO - $@";
1771 $@ = "";
1772 return;
1773 } elsif ($ret != 0) {
5f05dabc 1774 $self->{writemakefile} = "NO";
1775 return;
1776 }
1777 $self->{writemakefile} = "YES";
1778 return if $CPAN::Signal;
1779 $system = join " ", $CPAN::Config->{'make'}, $CPAN::Config->{make_arg};
1780 if (system($system)==0) {
1781 print " $system -- OK\n";
1782 $self->{'make'} = "YES";
1783 } else {
1784 $self->{writemakefile} = "YES";
1785 $self->{'make'} = "NO";
1786 print " $system -- NOT OK\n";
1787 }
1788}
1789
10b2abe6 1790#-> sub CPAN::Distribution::test ;
5f05dabc 1791sub test {
1792 my($self) = @_;
1793 $self->make;
1794 return if $CPAN::Signal;
1795 print "Running make test\n";
1796 EXCUSE: {
1797 my @e;
1798 exists $self->{'make'} or push @e, "Make had some problems, maybe interrupted? Won't test";
1799 exists $self->{'make'} and $self->{'make'} eq 'NO' and push @e, "Oops, make had returned bad status";
1800 exists $self->{'build_dir'} or push @e, "Has no own directory";
1801 print join "", map {" $_\n"} @e and return if @e;
1802 }
1803 chdir $self->{'build_dir'} or Carp::croak("Couldn't chdir to $self->{'build_dir'}");
1804 $self->debug("Changed directory to $self->{'build_dir'}") if $CPAN::DEBUG;
1805 my $system = join " ", $CPAN::Config->{'make'}, "test";
1806 if (system($system)==0) {
1807 print " $system -- OK\n";
1808 $self->{'make_test'} = "YES";
1809 } else {
1810 $self->{'make_test'} = "NO";
1811 print " $system -- NOT OK\n";
1812 }
1813}
1814
10b2abe6 1815#-> sub CPAN::Distribution::clean ;
5f05dabc 1816sub clean {
1817 my($self) = @_;
1818 print "Running make clean\n";
1819 EXCUSE: {
1820 my @e;
1821 exists $self->{'build_dir'} or push @e, "Has no own directory";
1822 print join "", map {" $_\n"} @e and return if @e;
1823 }
1824 chdir $self->{'build_dir'} or Carp::croak("Couldn't chdir to $self->{'build_dir'}");
1825 $self->debug("Changed directory to $self->{'build_dir'}") if $CPAN::DEBUG;
1826 my $system = join " ", $CPAN::Config->{'make'}, "clean";
1827 if (system($system)==0) {
1828 print " $system -- OK\n";
1829 $self->force;
1830 } else {
1831 # Hmmm, what to do if make clean failed?
1832 }
1833}
1834
10b2abe6 1835#-> sub CPAN::Distribution::install ;
5f05dabc 1836sub install {
1837 my($self) = @_;
1838 $self->test;
1839 return if $CPAN::Signal;
1840 print "Running make install\n";
da199366 1841 EXCUSE: {
1842 my @e;
1843 exists $self->{'build_dir'} or push @e, "Has no own directory";
1844 exists $self->{'make'} or push @e, "Make had some problems, maybe interrupted? Won't install";
1845 exists $self->{'make'} and $self->{'make'} eq 'NO' and push @e, "Oops, make had returned bad status";
1846 exists $self->{'install'} and push @e, $self->{'install'} eq "YES" ? "Already done" : "Already tried without success";
1847 print join "", map {" $_\n"} @e and return if @e;
1848 }
5f05dabc 1849 chdir $self->{'build_dir'} or Carp::croak("Couldn't chdir to $self->{'build_dir'}");
1850 $self->debug("Changed directory to $self->{'build_dir'}") if $CPAN::DEBUG;
1851 my $system = join " ", $CPAN::Config->{'make'}, "install", $CPAN::Config->{make_install_arg};
da199366 1852 my($pipe) = FileHandle->new("$system 2>&1 |");
5f05dabc 1853 my($makeout) = "";
da199366 1854 while (<$pipe>){
5f05dabc 1855 print;
1856 $makeout .= $_;
1857 }
1858 $pipe->close;
1859 if ($?==0) {
1860 print " $system -- OK\n";
1861 $self->{'install'} = "YES";
1862 } else {
1863 $self->{'install'} = "NO";
1864 print " $system -- NOT OK\n";
1865 if ($makeout =~ /permission/s && $> > 0) {
1866 print " You may have to su to root to install the package\n";
1867 }
1868 }
1869}
1870
10b2abe6 1871#-> sub CPAN::Distribution::dir ;
5f05dabc 1872sub dir {
1873 shift->{'build_dir'};
1874}
1875
1876package CPAN::Bundle;
10b2abe6 1877@CPAN::Bundle::ISA = qw(CPAN::Debug CPAN::InfoObj CPAN::Module);
5f05dabc 1878
10b2abe6 1879#-> sub CPAN::Bundle::as_string ;
5f05dabc 1880sub as_string {
1881 my($self) = @_;
1882 $self->contains;
1883 return $self->SUPER::as_string;
1884}
1885
10b2abe6 1886#-> sub CPAN::Bundle::contains ;
5f05dabc 1887sub contains {
1888 my($self) = @_;
1889 my($parsefile) = $self->inst_file;
1890 unless ($parsefile) {
1891 # Try to get at it in the cpan directory
1892 $self->debug("no parsefile") if $CPAN::DEBUG;
1893 my $dist = $CPAN::META->instance('CPAN::Distribution',$self->{'CPAN_FILE'});
1894 $self->debug($dist->as_string) if $CPAN::DEBUG;
1895 $dist->get;
1896 $self->debug($dist->as_string) if $CPAN::DEBUG;
1897 my($todir) = $CPAN::META->catdir($CPAN::Config->{'cpan_home'},"Bundle");
1898 File::Path::mkpath($todir);
1899 my($me,$from,$to);
1900 ($me = $self->id) =~ s/.*://;
1901 $from = $CPAN::META->catfile($dist->{'build_dir'},"$me.pm");
1902 $to = $CPAN::META->catfile($todir,"$me.pm");
10b2abe6 1903 File::Copy::copy($from, $to) or Carp::confess("Couldn't copy $from to $to: $!");
5f05dabc 1904 $parsefile = $to;
1905 }
1906 my @result;
da199366 1907 my $fh = new FileHandle;
5f05dabc 1908 local $/ = "\n";
1909 open($fh,$parsefile) or die "Could not open '$parsefile': $!";
1910 my $inpod = 0;
1911 while (<$fh>) {
1912 $inpod = /^=(?!head1\s+CONTENTS)/ ? 0 : /^=head1\s+CONTENTS/ ? 1 : $inpod;
1913 next unless $inpod;
1914 next if /^=/;
1915 next if /^\s+$/;
1916 chomp;
1917 push @result, (split " ", $_, 2)[0];
1918 }
1919 close $fh;
1920 delete $self->{STATUS};
1921 $self->{CONTAINS} = [@result];
1922 @result;
1923}
1924
10b2abe6 1925#-> sub CPAN::Bundle::inst_file ;
5f05dabc 1926sub inst_file {
1927 my($self) = @_;
1928 my($me,$inst_file);
1929 ($me = $self->id) =~ s/.*://;
1930 $inst_file = $CPAN::META->catfile($CPAN::Config->{'cpan_home'},"Bundle", "$me.pm");
1931 return $self->{'INST_FILE'} = $inst_file if -f $inst_file;
1932 $inst_file = $self->SUPER::inst_file;
1933 return $self->{'INST_FILE'} = $inst_file if -f $inst_file;
1934 return $self->{'INST_FILE'}; # even if undefined?
1935}
1936
10b2abe6 1937#-> sub CPAN::Bundle::rematein ;
5f05dabc 1938sub rematein {
1939 my($self,$meth) = @_;
1940 $self->debug("self[$self] meth[$meth]") if $CPAN::DEBUG;
1941 my($s);
1942 for $s ($self->contains) {
1943 $CPAN::META->instance('CPAN::Module',$s)->$meth();
1944 }
1945}
1946
10b2abe6 1947#-> sub CPAN::Bundle::force ;
1948sub force { shift->rematein('force',@_); }
da199366 1949#-> sub CPAN::Bundle::get ;
1950sub get { shift->rematein('get',@_); }
1951#-> sub CPAN::Bundle::make ;
1952sub make { shift->rematein('make',@_); }
1953#-> sub CPAN::Bundle::test ;
1954sub test { shift->rematein('test',@_); }
10b2abe6 1955#-> sub CPAN::Bundle::install ;
5f05dabc 1956sub install { shift->rematein('install',@_); }
10b2abe6 1957#-> sub CPAN::Bundle::clean ;
5f05dabc 1958sub clean { shift->rematein('clean',@_); }
5f05dabc 1959
10b2abe6 1960#-> sub CPAN::Bundle::readme ;
5f05dabc 1961sub readme {
1962 my($self) = @_;
1963 my($file) = $self->cpan_file or print("No File found for bundle ", $self->id, "\n"), return;
1964 $self->debug("self[$self] file[$file]") if $CPAN::DEBUG;
1965 $CPAN::META->instance('CPAN::Distribution',$file)->readme;
5f05dabc 1966}
1967
1968package CPAN::Module;
10b2abe6 1969@CPAN::Module::ISA = qw(CPAN::Debug CPAN::InfoObj);
5f05dabc 1970
10b2abe6 1971#-> sub CPAN::Module::as_glimpse ;
5f05dabc 1972sub as_glimpse {
1973 my($self) = @_;
1974 my(@m);
1975 my $class = ref($self);
1976 $class =~ s/^CPAN:://;
1977 push @m, sprintf "%-15s %-15s (%s)\n", $class, $self->{ID}, $self->cpan_file;
1978 join "", @m;
1979}
1980
10b2abe6 1981#-> sub CPAN::Module::as_string ;
5f05dabc 1982sub as_string {
1983 my($self) = @_;
1984 my(@m);
1985 CPAN->debug($self) if $CPAN::DEBUG;
1986 my $class = ref($self);
1987 $class =~ s/^CPAN:://;
1988 local($^W) = 0;
1989 push @m, $class, " id = $self->{ID}\n";
1990 my $sprintf = " %-12s %s\n";
1991 push @m, sprintf $sprintf, 'DESCRIPTION', $self->{description} if $self->{description};
1992 my $sprintf2 = " %-12s %s (%s)\n";
1993 my($userid);
1994 if ($userid = $self->{'CPAN_USERID'} || $self->{'userid'}){
1995 push @m, sprintf(
1996 $sprintf2,
1997 'CPAN_USERID',
1998 $userid,
1999 $CPAN::META->instance(CPAN::Author,$userid)->fullname
2000 )
2001 }
2002 push @m, sprintf $sprintf, 'CPAN_VERSION', $self->{CPAN_VERSION} if $self->{CPAN_VERSION};
2003 push @m, sprintf $sprintf, 'CPAN_FILE', $self->{CPAN_FILE} if $self->{CPAN_FILE};
2004 my $sprintf3 = " %-12s %1s%1s%1s%1s (%s,%s,%s,%s)\n";
2005 my(%statd,%stats,%statl,%stati);
2006 @statd{qw,? i c a b R M S,} = qw,unknown idea pre-alpha alpha beta released mature standard,;
2007 @stats{qw,? m d u n,} = qw,unknown mailing-list developer comp.lang.perl.* none,;
2008 @statl{qw,? p c + o,} = qw,unknown perl C C++ other,;
2009 @stati{qw,? f r O,} = qw,unknown functions references+ties object-oriented,;
2010 $statd{' '} = 'unknown';
2011 $stats{' '} = 'unknown';
2012 $statl{' '} = 'unknown';
2013 $stati{' '} = 'unknown';
2014 push @m, sprintf(
2015 $sprintf3,
2016 'DSLI_STATUS',
2017 $self->{statd},
2018 $self->{stats},
2019 $self->{statl},
2020 $self->{stati},
2021 $statd{$self->{statd}},
2022 $stats{$self->{stats}},
2023 $statl{$self->{statl}},
2024 $stati{$self->{stati}}
2025 ) if $self->{statd};
2026 my $local_file = $self->inst_file;
2027 if ($local_file && ! exists $self->{MANPAGE}) {
da199366 2028 my $fh = FileHandle->new($local_file) or Carp::croak("Couldn't open $local_file: $!");
5f05dabc 2029 my $inpod = 0;
2030 my(@result);
2031 local $/ = "\n";
2032 while (<$fh>) {
2033 $inpod = /^=(?!head1\s+NAME)/ ? 0 : /^=head1\s+NAME/ ? 1 : $inpod;
2034 next unless $inpod;
2035 next if /^=/;
2036 next if /^\s+$/;
2037 chomp;
2038 push @result, $_;
2039 }
2040 close $fh;
2041 $self->{MANPAGE} = join " ", @result;
2042 }
2043 push @m, sprintf $sprintf, 'MANPAGE', $self->{MANPAGE} if $self->{MANPAGE};
2044 push @m, sprintf $sprintf, 'INST_FILE', $local_file || "(not installed)";
2045 push @m, sprintf $sprintf, 'INST_VERSION', $self->inst_version if $local_file;
2046 join "", @m, "\n";
2047}
2048
10b2abe6 2049#-> sub CPAN::Module::cpan_file ;
5f05dabc 2050sub cpan_file {
2051 my $self = shift;
2052 CPAN->debug($self->id) if $CPAN::DEBUG;
2053 unless (defined $self->{'CPAN_FILE'}) {
2054 CPAN::Index->reload;
2055 }
2056 if (defined $self->{'CPAN_FILE'}){
2057 return $self->{'CPAN_FILE'};
2058 } elsif (defined $self->{'userid'}) {
2059 return "Contact Author ".$self->{'userid'}."=".$CPAN::META->instance(CPAN::Author,$self->{'userid'})->fullname
2060 } else {
2061 return "N/A";
2062 }
2063}
2064
2065*name = \&cpan_file;
2066
10b2abe6 2067#-> sub CPAN::Module::cpan_version ;
5f05dabc 2068sub cpan_version { shift->{'CPAN_VERSION'} }
2069
10b2abe6 2070#-> sub CPAN::Module::force ;
5f05dabc 2071sub force {
2072 my($self) = @_;
2073 $self->{'force_update'}++;
2074}
2075
10b2abe6 2076#-> sub CPAN::Module::rematein ;
5f05dabc 2077sub rematein {
2078 my($self,$meth) = @_;
2079 $self->debug($self->id) if $CPAN::DEBUG;
2080 my $cpan_file = $self->cpan_file;
2081 return if $cpan_file eq "N/A";
2082 return if $cpan_file =~ /^Contact Author/;
2083 my $pack = $CPAN::META->instance('CPAN::Distribution',$cpan_file);
2084 $pack->called_for($self->id);
2085 $pack->force if exists $self->{'force_update'};
2086 $pack->$meth();
2087 delete $self->{'force_update'};
2088}
2089
10b2abe6 2090#-> sub CPAN::Module::readme ;
5f05dabc 2091sub readme { shift->rematein('readme') }
da199366 2092#-> sub CPAN::Module::look ;
2093sub look { shift->rematein('look') }
2094#-> sub CPAN::Module::get ;
2095sub get { shift->rematein('get',@_); }
10b2abe6 2096#-> sub CPAN::Module::make ;
5f05dabc 2097sub make { shift->rematein('make') }
10b2abe6 2098#-> sub CPAN::Module::test ;
5f05dabc 2099sub test { shift->rematein('test') }
10b2abe6 2100#-> sub CPAN::Module::install ;
5f05dabc 2101sub install {
2102 my($self) = @_;
2103 my($doit) = 0;
2104 my($latest) = $self->cpan_version;
2105 $latest ||= 0;
2106 my($inst_file) = $self->inst_file;
2107 my($have) = 0;
2108 if (defined $inst_file) {
2109 $have = $self->inst_version;
2110 }
2111 if ($inst_file && $have >= $latest && not exists $self->{'force_update'}) {
2112 print $self->id, " is up to date.\n";
2113 } else {
2114 $doit = 1;
2115 }
2116 $self->rematein('install') if $doit;
2117}
da199366 2118#-> sub CPAN::Module::clean ;
2119sub clean { shift->rematein('clean') }
5f05dabc 2120
10b2abe6 2121#-> sub CPAN::Module::inst_file ;
5f05dabc 2122sub inst_file {
2123 my($self) = @_;
2124 my($dir,@packpath);
2125 @packpath = split /::/, $self->{ID};
2126 $packpath[-1] .= ".pm";
2127 foreach $dir (@INC) {
2128 my $pmfile = CPAN->catfile($dir,@packpath);
2129 if (-f $pmfile){
2130 return $pmfile;
2131 }
2132 }
2133}
2134
10b2abe6 2135#-> sub CPAN::Module::xs_file ;
5f05dabc 2136sub xs_file {
2137 my($self) = @_;
2138 my($dir,@packpath);
2139 @packpath = split /::/, $self->{ID};
2140 push @packpath, $packpath[-1];
2141 $packpath[-1] .= "." . $Config::Config{'dlext'};
2142 foreach $dir (@INC) {
2143 my $xsfile = CPAN->catfile($dir,'auto',@packpath);
2144 if (-f $xsfile){
2145 return $xsfile;
2146 }
2147 }
2148}
2149
10b2abe6 2150#-> sub CPAN::Module::inst_version ;
5f05dabc 2151sub inst_version {
2152 my($self) = @_;
2153 my $parsefile = $self->inst_file or return 0;
da199366 2154 local($^W) = 0 if $] < 5.00303 && $ExtUtils::MakeMaker::VERSION < 5.38;
5f05dabc 2155 my $have = MY->parse_version($parsefile);
2156 $have ||= 0;
2157 $have =~ s/\s+//g;
2158 $have ||= 0;
2159 $have;
2160}
2161
2162package CPAN::CacheMgr;
10b2abe6 2163use vars qw($Du);
2164@CPAN::CacheMgr::ISA = qw(CPAN::Debug CPAN::InfoObj);
5f05dabc 2165use File::Find;
2166
10b2abe6 2167#-> sub CPAN::CacheMgr::as_string ;
5f05dabc 2168sub as_string {
2169 eval { require Data::Dumper };
2170 if ($@) {
2171 return shift->SUPER::as_string;
2172 } else {
2173 return Data::Dumper::Dumper(shift);
2174 }
2175}
2176
10b2abe6 2177#-> sub CPAN::CacheMgr::cachesize ;
5f05dabc 2178sub cachesize {
2179 shift->{DU};
2180}
2181
2182# sub check {
2183# my($self,@dirs) = @_;
2184# return unless -d $self->{ID};
2185# my $dir;
2186# @dirs = $self->dirs unless @dirs;
2187# for $dir (@dirs) {
2188# $self->disk_usage($dir);
2189# }
2190# }
2191
10b2abe6 2192#-> sub CPAN::CacheMgr::clean_cache ;
5f05dabc 2193sub clean_cache {
2194 my $self = shift;
2195 my $dir;
2196 while ($self->{DU} > $self->{'MAX'} and $dir = shift @{$self->{FIFO}}) {
2197 $self->force_clean_cache($dir);
2198 }
2199 $self->debug("leaving clean_cache with $self->{DU}") if $CPAN::DEBUG;
2200}
2201
10b2abe6 2202#-> sub CPAN::CacheMgr::dir ;
5f05dabc 2203sub dir {
2204 shift->{ID};
2205}
2206
10b2abe6 2207#-> sub CPAN::CacheMgr::entries ;
5f05dabc 2208sub entries {
2209 my($self,$dir) = @_;
2210 $dir ||= $self->{ID};
2211 my($cwd) = Cwd::cwd();
2212 chdir $dir or Carp::croak("Can't chdir to $dir: $!");
2213 my $dh = DirHandle->new(".") or Carp::croak("Couldn't opendir $dir: $!");
2214 my(@entries);
2215 for ($dh->read) {
2216 next if $_ eq "." || $_ eq "..";
2217 if (-f $_) {
2218 push @entries, $CPAN::META->catfile($dir,$_);
2219 } elsif (-d _) {
2220 push @entries, $CPAN::META->catdir($dir,$_);
2221 } else {
2222 print STDERR "Warning: weird direntry in $dir: $_\n";
2223 }
2224 }
2225 chdir $cwd or Carp::croak("Can't chdir to $cwd: $!");
2226 sort {-M $b <=> -M $a} @entries;
2227}
2228
10b2abe6 2229#-> sub CPAN::CacheMgr::disk_usage ;
5f05dabc 2230sub disk_usage {
2231 my($self,$dir) = @_;
2232 if (! defined $dir or $dir eq "") {
2233 $self->debug("Cannot determine disk usage for some reason") if $CPAN::DEBUG;
2234 return;
2235 }
2236 return if defined $self->{SIZE}{$dir};
2237 local($Du) = 0;
2238 find(
2239 sub {
2240 return if -l $_;
2241 $Du += -s;
2242 },
2243 $dir
2244 );
2245 $self->{SIZE}{$dir} = $Du/1024/1024;
2246 push @{$self->{FIFO}}, $dir;
2247 $self->debug("measured $dir is $Du") if $CPAN::DEBUG;
2248 $self->{DU} += $Du/1024/1024;
2249 if ($self->{DU} > $self->{'MAX'} ) {
2250 printf "...Hold on a sec... CPAN's cleaning the cache: %.2f MB > %.2f MB\n",
2251 $self->{DU}, $self->{'MAX'};
2252 $self->clean_cache;
2253 } else {
2254 $self->debug("NOT have to clean the cache: $self->{DU} <= $self->{'MAX'}") if $CPAN::DEBUG;
2255 $self->debug($self->as_string) if $CPAN::DEBUG;
2256 }
2257 $self->{DU};
2258}
2259
10b2abe6 2260#-> sub CPAN::CacheMgr::force_clean_cache ;
5f05dabc 2261sub force_clean_cache {
2262 my($self,$dir) = @_;
2263 $self->debug("have to rmtree $dir, will free $self->{SIZE}{$dir}") if $CPAN::DEBUG;
2264 File::Path::rmtree($dir);
2265 $self->{DU} -= $self->{SIZE}{$dir};
2266 delete $self->{SIZE}{$dir};
2267}
2268
10b2abe6 2269#-> sub CPAN::CacheMgr::new ;
5f05dabc 2270sub new {
2271 my $class = shift;
2272 my $self = { ID => $CPAN::Config->{'build_dir'}, MAX => $CPAN::Config->{'build_cache'}, DU => 0 };
2273 File::Path::mkpath($self->{ID});
2274 my $dh = DirHandle->new($self->{ID});
2275 bless $self, $class;
2276 $self->debug("dir [$self->{ID}]") if $CPAN::DEBUG;
2277 my $e;
2278 for $e ($self->entries) {
2279 next if $e eq ".." || $e eq ".";
2280 $self->debug("Have to check size $e") if $CPAN::DEBUG;
2281 $self->disk_usage($e);
2282 }
2283 $self;
2284}
2285
2286package CPAN::Debug;
2287
10b2abe6 2288#-> sub CPAN::Debug::debug ;
5f05dabc 2289sub debug {
2290 my($self,$arg) = @_;
2291 my($caller,$func,$line,@rest) = caller(1); # caller(0) eg Complete, caller(1) eg readline
2292 ($caller) = caller(0);
2293 $caller =~ s/.*:://;
2294# print "caller[$caller]func[$func]line[$line]rest[@rest]\n";
2295# print "CPAN::DEBUG{caller}[$CPAN::DEBUG{$caller}]CPAN::DEBUG[$CPAN::DEBUG]\n";
2296 if ($CPAN::DEBUG{$caller} & $CPAN::DEBUG){
2297 if (ref $arg) {
2298 eval { require Data::Dumper };
2299 if ($@) {
2300 print $arg->as_string;
2301 } else {
2302 print Data::Dumper::Dumper($arg);
2303 }
2304 } else {
2305 print "Debug($caller:$func,$line,@rest): $arg\n"
2306 }
2307 }
2308}
2309
2310package CPAN::Config;
2311import ExtUtils::MakeMaker 'neatvalue';
2312use vars qw(%can);
2313
2314%can = (
2315 'commit' => "Commit changes to disk",
2316 'defaults' => "Reload defaults from disk",
2317);
2318
10b2abe6 2319#-> sub CPAN::Config::edit ;
5f05dabc 2320sub edit {
2321 my($class,@args) = @_;
2322 return unless @args;
10b2abe6 2323 CPAN->debug("class[$class]args[".join(" | ",@args)."]");
5f05dabc 2324 my($o,$str,$func,$args,$key_exists);
2325 $o = shift @args;
2326 if($can{$o}) {
2327 $class->$o(@args);
2328 return 1;
10b2abe6 2329 } else {
2330 if (ref($CPAN::Config->{$o}) eq ARRAY) {
5f05dabc 2331 $func = shift @args;
2332 # Let's avoid eval, it's easier to comprehend without.
2333 if ($func eq "push") {
2334 push @{$CPAN::Config->{$o}}, @args;
2335 } elsif ($func eq "pop") {
2336 pop @{$CPAN::Config->{$o}};
2337 } elsif ($func eq "shift") {
2338 shift @{$CPAN::Config->{$o}};
2339 } elsif ($func eq "unshift") {
2340 unshift @{$CPAN::Config->{$o}}, @args;
2341 } elsif ($func eq "splice") {
2342 splice @{$CPAN::Config->{$o}}, @args;
2343 } else {
2344 $CPAN::Config->{$o} = [@args];
2345 }
2346 } else {
da199366 2347 $CPAN::Config->{$o} = $args[0] if defined $args[0];
10b2abe6 2348 print " $o ";
2349 print defined $CPAN::Config->{$o} ? $CPAN::Config->{$o} : "UNDEFINED";
5f05dabc 2350 }
5f05dabc 2351 }
2352}
2353
10b2abe6 2354#-> sub CPAN::Config::commit ;
5f05dabc 2355sub commit {
2356 my($self, $configpm) = @_;
2357 my $mode;
2358 # mkpath!?
2359
da199366 2360 my($fh) = FileHandle->new;
5f05dabc 2361 $configpm ||= cfile();
2362 if (-f $configpm) {
2363 $mode = (stat $configpm)[2];
2364 if ($mode && ! -w _) {
2365 print "$configpm is not writable\n" and return;
2366 }
2367 #chmod 0644, $configpm; #?
2368 }
2369
2370 my $msg = <<EOF unless $configpm =~ /MyConfig/;
2371
2372# This is CPAN.pm's systemwide configuration file. This file provides
2373# defaults for users, and the values can be changed in a per-user configuration
2374# file. The user-config file is being looked for as ~/.cpan/CPAN/MyConfig.pm.
2375
2376EOF
2377 $msg ||= "\n";
2378 open $fh, ">$configpm" or warn "Couldn't open >$configpm: $!";
2379 print $fh qq[$msg\$CPAN::Config = \{\n];
2380 foreach (sort keys %$CPAN::Config) {
2381 print $fh " '$_' => ", ExtUtils::MakeMaker::neatvalue($CPAN::Config->{$_}), ",\n";
2382 }
2383
2384 print $fh "};\n1;\n__END__\n";
2385 close $fh;
2386
2387 #$mode = 0444 | ( $mode & 0111 ? 0111 : 0 );
2388 #chmod $mode, $configpm;
2389 $self->defaults;
2390 print "commit: wrote $configpm\n";
2391 1;
2392}
2393
2394*default = \&defaults;
10b2abe6 2395#-> sub CPAN::Config::defaults ;
5f05dabc 2396sub defaults {
2397 my($self) = @_;
2398 $self->unload;
2399 $self->load;
2400 1;
2401}
2402
2403my $dot_cpan;
10b2abe6 2404#-> sub CPAN::Config::load ;
5f05dabc 2405sub load {
2406 my($self) = @_;
2407 eval {require CPAN::Config;}; # We eval, because of some MakeMaker problems
2408 unshift @INC, $CPAN::META->catdir($ENV{HOME},".cpan") unless $dot_cpan++;
2409 eval {require CPAN::MyConfig;}; # where you can override system wide settings
2410 unless ( $self->load_succeeded ) {
2411 require CPAN::FirstTime;
2412 my($configpm,$fh);
2413 if (defined $INC{"CPAN/Config.pm"} && -w $INC{"CPAN/Config.pm"}) {
2414 $configpm = $INC{"CPAN/Config.pm"};
2415 } elsif (defined $INC{"CPAN/MyConfig.pm"} && -w $INC{"CPAN/MyConfig.pm"}) {
2416 $configpm = $INC{"CPAN/MyConfig.pm"};
2417 } else {
2418 my($path_to_cpan) = File::Basename::dirname($INC{"CPAN.pm"});
2419 my($configpmdir) = MY->catdir($path_to_cpan,"CPAN");
2420 my($configpmtest) = MY->catfile($configpmdir,"Config.pm");
2421 if (-d $configpmdir || File::Path::mkpath($configpmdir)) {
5f05dabc 2422 if (-w $configpmtest or -w $configpmdir) {
2423 $configpm = $configpmtest;
2424 }
2425 }
2426 unless ($configpm) {
2427 $configpmdir = MY->catdir($ENV{HOME},".cpan","CPAN");
2428 File::Path::mkpath($configpmdir);
2429 $configpmtest = MY->catfile($configpmdir,"MyConfig.pm");
2430 if (-w $configpmtest or -w $configpmdir) {
2431 $configpm = $configpmtest;
2432 } else {
2433 warn "WARNING: CPAN.pm is unable to create a configuration file.\n";
2434 }
2435 }
2436 }
2437 warn "Calling CPAN::FirstTime::init($configpm)";
2438 CPAN::FirstTime::init($configpm);
2439 }
2440}
2441
10b2abe6 2442#-> sub CPAN::Config::load_succeeded ;
5f05dabc 2443sub load_succeeded {
2444 my($miss) = 0;
2445 for (qw(
2446 cpan_home keep_source_where build_dir build_cache index_expire
2447 gzip tar unzip make pager makepl_arg make_arg make_install_arg
da199366 2448 urllist inhibit_startup_message ftp_proxy http_proxy no_proxy
5f05dabc 2449 )) {
da199366 2450 unless (defined $CPAN::Config->{$_}){
2451 $miss++;
2452 CPAN->debug("undefined configuration parameter $_") if $CPAN::DEBUG;
2453 }
5f05dabc 2454 }
2455 return !$miss;
2456}
2457
10b2abe6 2458#-> sub CPAN::Config::unload ;
5f05dabc 2459sub unload {
2460 delete $INC{'CPAN/MyConfig.pm'};
2461 delete $INC{'CPAN/Config.pm'};
2462}
2463
10b2abe6 2464#-> sub CPAN::Config::cfile ;
5f05dabc 2465sub cfile {
2466 $INC{'CPAN/MyConfig.pm'} || $INC{'CPAN/Config.pm'};
2467}
2468
2469*h = \&help;
10b2abe6 2470#-> sub CPAN::Config::help ;
5f05dabc 2471sub help {
2472 print <<EOF;
2473Known options:
2474 defaults reload default config values from disk
2475 commit commit session changes to disk
2476
2477You may edit key values in the follow fashion:
2478
2479 o conf build_cache 15
2480
2481 o conf build_dir "/foo/bar"
2482
2483 o conf urllist shift
2484
2485 o conf urllist unshift ftp://ftp.foo.bar/
2486
2487EOF
2488 undef; #don't reprint CPAN::Config
2489}
2490
10b2abe6 2491#-> sub CPAN::Config::complete ;
5f05dabc 2492sub complete {
2493 my($word,$line,$pos) = @_;
2494 $word ||= "";
2495 my(@words) = split " ", $line;
2496 my(@o_conf) = (sort keys %CPAN::Config::can, sort keys %$CPAN::Config);
2497 return (@o_conf) unless @words>2;
2498 if($words[2] =~ /->(.*)/) {
2499 my $meth = $1;
2500 my(@methods) = qw(shift unshift push pop splice);
2501 return @methods unless $meth;
2502 return sort grep /^\Q$meth\E/, @methods;
2503 }
2504 return sort grep /^\Q$word\E/, @o_conf;
2505}
2506
25071;
2508
2509=head1 NAME
2510
2511CPAN - query, download and build perl modules from CPAN sites
2512
2513=head1 SYNOPSIS
2514
2515Interactive mode:
2516
2517 perl -MCPAN -e shell;
2518
2519Batch mode:
2520
2521 use CPAN;
2522
10b2abe6 2523 autobundle, clean, install, make, recompile, test
5f05dabc 2524
2525=head1 DESCRIPTION
2526
10b2abe6 2527The CPAN module is designed to automate the make and install of perl
42d3b621 2528modules and extensions. It includes some searching capabilities and
2529knows how to use Net::FTP or LWP (or lynx or an external ftp client)
2530to fetch the raw data from the net.
5f05dabc 2531
2532Modules are fetched from one or more of the mirrored CPAN
2533(Comprehensive Perl Archive Network) sites and unpacked in a dedicated
2534directory.
2535
2536The CPAN module also supports the concept of named and versioned
2537'bundles' of modules. Bundles simplify the handling of sets of
2538related modules. See BUNDLES below.
2539
2540The package contains a session manager and a cache manager. There is
2541no status retained between sessions. The session manager keeps track
2542of what has been fetched, built and installed in the current
2543session. The cache manager keeps track of the disk space occupied by
42d3b621 2544the make processes and deletes excess space according to a simple FIFO
2545mechanism.
5f05dabc 2546
10b2abe6 2547All methods provided are accessible in a programmer style and in an
2548interactive shell style.
2549
5f05dabc 2550=head2 Interactive Mode
2551
2552The interactive mode is entered by running
2553
2554 perl -MCPAN -e shell
2555
2556which puts you into a readline interface. You will have most fun if
2557you install Term::ReadKey and Term::ReadLine to enjoy both history and
2558completion.
2559
2560Once you are on the command line, type 'h' and the rest should be
2561self-explanatory.
2562
10b2abe6 2563The most common uses of the interactive modes are
2564
2565=over 2
2566
2567=item Searching for authors, bundles, distribution files and modules
2568
2569There are corresponding one-letter commands C<a>, C<b>, C<d>, and C<m>
42d3b621 2570for each of the four categories and another, C<i> for any of the
2571mentioned four. Each of the four entities is implemented as a class
2572with slightly differing methods for displaying an object.
10b2abe6 2573
2574Arguments you pass to these commands are either strings matching exact
2575the identification string of an object or regular expressions that are
2576then matched case-insensitively against various attributes of the
2577objects. The parser recognizes a regualar expression only if you
2578enclose it between two slashes.
2579
2580The principle is that the number of found objects influences how an
2581item is displayed. If the search finds one item, we display the result
2582of object-E<gt>as_string, but if we find more than one, we display
2583each as object-E<gt>as_glimpse. E.g.
2584
2585 cpan> a ANDK
2586 Author id = ANDK
2587 EMAIL a.koenig@franz.ww.TU-Berlin.DE
2588 FULLNAME Andreas König
2589
2590
2591 cpan> a /andk/
2592 Author id = ANDK
2593 EMAIL a.koenig@franz.ww.TU-Berlin.DE
2594 FULLNAME Andreas König
2595
2596
2597 cpan> a /and.*rt/
2598 Author ANDYD (Andy Dougherty)
2599 Author MERLYN (Randal L. Schwartz)
2600
da199366 2601=item make, test, install, clean modules or distributions
10b2abe6 2602
da199366 2603These commands do indeed exist just as written above. Each of them
2604takes any number of arguments and investigates for each what it might
2605be. Is it a distribution file (recognized by embedded slashes), this
2606file is being processed. Is it a module, CPAN determines the
10b2abe6 2607distribution file where this module is included and processes that.
2608
da199366 2609Any C<make>, C<test>, and C<readme> are run unconditionally. A
42d3b621 2610
2611 C<install E<lt>distribution_fileE<gt>>
2612
2613also is run unconditionally. But for
2614
2615 C<install E<lt>moduleE<gt>>
2616
2617CPAN checks if an install is actually needed for it and prints
2618I<Foo up to date> in case the module doesnE<39>t need to be updated.
10b2abe6 2619
2620CPAN also keeps track of what it has done within the current session
2621and doesnE<39>t try to build a package a second time regardless if it
2622succeeded or not. The C<force > command takes as first argument the
2623method to invoke (currently: make, test, or install) and executes the
2624command from scratch.
2625
2626Example:
2627
2628 cpan> install OpenGL
2629 OpenGL is up to date.
2630 cpan> force install OpenGL
2631 Running make
2632 OpenGL-0.4/
2633 OpenGL-0.4/COPYRIGHT
2634 [...]
2635
da199366 2636=item readme, look module or distribution
2637
2638These two commands take only one argument, be it a module or a
2639distribution file. C<readme> displays the README of the associated
2640distribution file. C<Look> gets and untars (if not yet done) the
2641distribution file, changes to the appropriate directory and opens a
2642subshell process in that directory.
2643
10b2abe6 2644=back
2645
5f05dabc 2646=head2 CPAN::Shell
2647
2648The commands that are available in the shell interface are methods in
2649the package CPAN::Shell. If you enter the shell command, all your
10b2abe6 2650input is split by the Text::ParseWords::shellwords() routine which
2651acts like most shells do. The first word is being interpreted as the
2652method to be called and the rest of the words are treated as arguments
2653to this method.
2654
da199366 2655=head2 autobundle
2656
2657C<autobundle> writes a bundle file into the
2658C<$CPAN::Config-E<gt>{cpan_home}/Bundle> directory. The file contains
2659a list of all modules that are both available from CPAN and currently
2660installed within @INC. The name of the bundle file is based on the
2661current date and a counter.
2662
2663=head2 recompile
2664
2665recompile() is a very special command in that it takes no argument and
2666runs the make/test/install cycle with brute force over all installed
2667dynamically loadable extensions (aka XS modules) with 'force' in
2668effect. Primary purpose of this command is to finish a network
2669installation. Imagine, you have a common source tree for two different
2670architectures. You decide to do a completely independent fresh
2671installation. You start on one architecture with the help of a Bundle
2672file produced earlier. CPAN installs the whole Bundle for you, but
2673when you try to repeat the job on the second architecture, CPAN
2674responds with a C<"Foo up to date"> message for all modules. So you
2675will be glad to run recompile in the second architecture and
2676youE<39>re done.
2677
2678Another popular use for C<recompile> is to act as a rescue in case your
2679perl breaks binary compatibility. If one of the modules that CPAN uses
2680is in turn depending on binary compatibility (so you cannot run CPAN
2681commands), then you should try the CPAN::Nox module for recovery.
2682
10b2abe6 2683=head2 ProgrammerE<39>s interface
5f05dabc 2684
10b2abe6 2685If you do not enter the shell, the available shell commands are both
2686available as methods (C<CPAN::Shell-E<gt>install(...)>) and as
2687functions in the calling package (C<install(...)>). The
2688programmerE<39>s interface has beta status. Do not heavily rely on it,
42d3b621 2689changes may still be necessary.
5f05dabc 2690
2691=head2 Cache Manager
2692
2693Currently the cache manager only keeps track of the build directory
2694($CPAN::Config->{build_dir}). It is a simple FIFO mechanism that
42d3b621 2695deletes complete directories below C<build_dir> as soon as the size of
5f05dabc 2696all directories there gets bigger than $CPAN::Config->{build_cache}
2697(in MB). The contents of this cache may be used for later
2698re-installations that you intend to do manually, but will never be
10b2abe6 2699trusted by CPAN itself. This is due to the fact that the user might
2700use these directories for building modules on different architectures.
5f05dabc 2701
2702There is another directory ($CPAN::Config->{keep_source_where}) where
2703the original distribution files are kept. This directory is not
2704covered by the cache manager and must be controlled by the user. If
2705you choose to have the same directory as build_dir and as
2706keep_source_where directory, then your sources will be deleted with
2707the same fifo mechanism.
2708
2709=head2 Bundles
2710
2711A bundle is just a perl module in the namespace Bundle:: that does not
2712define any functions or methods. It usually only contains documentation.
2713
2714It starts like a perl module with a package declaration and a $VERSION
2715variable. After that the pod section looks like any other pod with the
10b2abe6 2716only difference, that I<one special pod section> exists starting with
2717(verbatim):
5f05dabc 2718
2719 =head1 CONTENTS
2720
2721In this pod section each line obeys the format
2722
2723 Module_Name [Version_String] [- optional text]
2724
2725The only required part is the first field, the name of a module
2726(eg. Foo::Bar, ie. I<not> the name of the distribution file). The rest
2727of the line is optional. The comment part is delimited by a dash just
2728as in the man page header.
2729
2730The distribution of a bundle should follow the same convention as
42d3b621 2731other distributions.
5f05dabc 2732
2733Bundles are treated specially in the CPAN package. If you say 'install
2734Bundle::Tkkit' (assuming such a bundle exists), CPAN will install all
2735the modules in the CONTENTS section of the pod. You can install your
2736own Bundles locally by placing a conformant Bundle file somewhere into
2737your @INC path. The autobundle() command which is available in the
2738shell interface does that for you by including all currently installed
2739modules in a snapshot bundle file.
2740
10b2abe6 2741There is a meaningless Bundle::Demo available on CPAN. Try to install
2742it, it usually does no harm, just demonstrates what the Bundle
2743interface looks like.
2744
da199366 2745=head2 Prerequisites
5f05dabc 2746
da199366 2747If you have a local mirror of CPAN and can access all files with
2748"file:" URLs, then you only need a perl better than perl5.003 to run
2749this module. Otherwise Net::FTP is strongly recommended. LWP may be
2750required for non-UNIX systems or if your nearest CPAN site is
2751associated with an URL that is not C<ftp:>.
5f05dabc 2752
da199366 2753If you have neither Net::FTP nor LWP, there is a fallback mechanism
2754implemented for an external ftp command or for an external lynx
2755command.
5f05dabc 2756
da199366 2757This module presumes that all packages on CPAN
5f05dabc 2758
da199366 2759=over 2
2760
2761=item *
2762
2763declare their $VERSION variable in an easy to parse manner. This
2764prerequisite can hardly be relaxed because it consumes by far too much
2765memory to load all packages into the running program just to determine
2766the $VERSION variable . Currently all programs that are dealing with
2767version use something like this
2768
2769 perl -MExtUtils::MakeMaker -le \
2770 'print MM->parse_version($ARGV[0])' filename
2771
2772If you are author of a package and wonder if your $VERSION can be
2773parsed, please try the above method.
2774
2775=item *
2776
2777come as compressed or gzipped tarfiles or as zip files and contain a
2778Makefile.PL (well we try to handle a bit more, but without much
2779enthusiasm).
2780
2781=back
2782
2783=head2 Debugging
2784
2785The debugging of this module is pretty difficult, because we have
2786interferences of the software producing the indices on CPAN, of the
2787mirroring process on CPAN, of packaging, of configuration, of
2788synchronicity, and of bugs within CPAN.pm.
2789
2790In interactive mode you can try "o debug" which will list options for
2791debugging the various parts of the package. The output may not be very
2792useful for you as it's just a byproduct of my own testing, but if you
2793have an idea which part of the package may have a bug, it's sometimes
2794worth to give it a try and send me more specific output. You should
2795know that "o debug" has built-in completion support.
2796
2797=head2 Floppy, Zip, and all that Jazz
2798
2799CPAN.pm works nicely without network too. If you maintain machines
2800that are not networked at all, you should consider working with file:
2801URLs. Of course, you have to collect your modules somewhere first. So
2802you might use CPAN.pm to put together all you need on a networked
2803machine. Then copy the $CPAN::Config->{keep_source_where} (but not
2804$CPAN::Config->{build_dir}) directory on a floppy. This floppy is kind
2805of a personal CPAN. CPAN.pm on the non-networked machines works nicely
2806with this floppy.
10b2abe6 2807
5f05dabc 2808=head1 CONFIGURATION
2809
2810When the CPAN module is installed a site wide configuration file is
2811created as CPAN/Config.pm. The default values defined there can be
2812overridden in another configuration file: CPAN/MyConfig.pm. You can
2813store this file in $HOME/.cpan/CPAN/MyConfig.pm if you want, because
2814$HOME/.cpan is added to the search path of the CPAN module before the
2815use() or require() statements.
2816
2817Currently the following keys in the hash reference $CPAN::Config are
2818defined:
2819
42d3b621 2820 build_cache size of cache for directories to build modules
2821 build_dir locally accessible directory to build modules
2822 index_expire after how many days refetch index files
2823 cpan_home local directory reserved for this package
2824 gzip location of external program gzip
2825 inactivity_timeout breaks interactive Makefile.PLs after that
2826 many seconds inactivity. Set to 0 to never break.
5f05dabc 2827 inhibit_startup_message
42d3b621 2828 if true, does not print the startup message
2829 keep_source keep the source in a local directory?
2830 keep_source_where where keep the source (if we do)
2831 make location of external program make
2832 make_arg arguments that should always be passed to 'make'
2833 make_install_arg same as make_arg for 'make install'
2834 makepl_arg arguments passed to 'perl Makefile.PL'
2835 pager location of external program more (or any pager)
2836 tar location of external program tar
2837 unzip location of external program unzip
2838 urllist arrayref to nearby CPAN sites (or equivalent locations)
5f05dabc 2839
2840You can set and query each of these options interactively in the cpan
2841shell with the command set defined within the C<o conf> command:
2842
2843=over 2
2844
2845=item o conf E<lt>scalar optionE<gt>
2846
2847prints the current value of the I<scalar option>
2848
2849=item o conf E<lt>scalar optionE<gt> E<lt>valueE<gt>
2850
2851Sets the value of the I<scalar option> to I<value>
2852
2853=item o conf E<lt>list optionE<gt>
2854
2855prints the current value of the I<list option> in MakeMaker's
2856neatvalue format.
2857
2858=item o conf E<lt>list optionE<gt> [shift|pop]
2859
2860shifts or pops the array in the I<list option> variable
2861
2862=item o conf E<lt>list optionE<gt> [unshift|push|splice] E<lt>listE<gt>
2863
42d3b621 2864works like the corresponding perl commands.
5f05dabc 2865
2866=back
2867
2868=head1 SECURITY
2869
2870There's no strong security layer in CPAN.pm. CPAN.pm helps you to
2871install foreign, unmasked, unsigned code on your machine. We compare
2872to a checksum that comes from the net just as the distribution file
2873itself. If somebody has managed to tamper with the distribution file,
2874they may have as well tampered with the CHECKSUMS file. Future
42d3b621 2875development will go towards strong authentification.
5f05dabc 2876
2877=head1 EXPORT
2878
2879Most functions in package CPAN are exported per default. The reason
2880for this is that the primary use is intended for the cpan shell or for
2881oneliners.
2882
da199366 2883=head1 BUGS
5f05dabc 2884
da199366 2885we should give coverage for _all_ of the CPAN and not just the
2886__PAUSE__ part, right? In this discussion CPAN and PAUSE have become
2887equal -- but they are not. PAUSE is authors/ and modules/. CPAN is
2888PAUSE plus the clpa/, doc/, misc/, ports/, src/, scripts/.
5f05dabc 2889
da199366 2890Future development should be directed towards a better intergration of
2891the other parts.
5f05dabc 2892
2893=head1 AUTHOR
2894
2895Andreas König E<lt>a.koenig@mind.deE<gt>
2896
2897=head1 SEE ALSO
2898
2899perl(1), CPAN::Nox(3)
2900
2901=cut
2902
Unnamed repository; edit this file to name it for gitweb.