This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Use "proto" instead of "_" in sdbm.h
[perl5.git] / lib / CPAN.pm
CommitLineData
5f05dabc 1package CPAN;
2use vars qw{$META $Signal $Cwd $End $Suppress_readline};
3
4$VERSION = '1.02';
5
6# $Id: CPAN.pm,v 1.77 1996/12/11 01:26:43 k Exp $
7
8# my $version = substr q$Revision: 1.77 $, 10; # only used during development
9
10BEGIN {require 5.003;}
11require UNIVERSAL if $] == 5.003;
12
13use Carp ();
14use Config ();
15use Cwd ();
16use DirHandle;
17use Exporter ();
18use ExtUtils::MakeMaker ();
19use File::Basename ();
20use File::Find;
21use File::Path ();
22use IO::File ();
23use Safe ();
24
25$Cwd = Cwd::cwd();
26
27END { $End++; &cleanup; }
28
29%CPAN::DEBUG = qw(
30 CPAN 1
31 Index 2
32 InfoObj 4
33 Author 8
34 Distribution 16
35 Bundle 32
36 Module 64
37 CacheMgr 128
38 Complete 256
39 FTP 512
40 Shell 1024
41 Eval 2048
42 Config 4096
43 );
44
45$CPAN::DEBUG ||= 0;
46
47package CPAN;
48use vars qw($VERSION @ISA @EXPORT $AUTOLOAD $DEBUG $META);
49use strict qw(vars);
50
51@ISA = qw(CPAN::Debug Exporter MY); # the MY class from MakeMaker, gives us catfile and catdir
52
53$META ||= new CPAN; # In case we reeval ourselves we need a ||
54
55CPAN::Config->load;
56
57@EXPORT = qw(autobundle bundle expand force install make recompile shell test clean);
58
59sub autobundle;
60sub bundle;
61sub bundles;
62sub expand;
63sub force;
64sub install;
65sub make;
66sub shell;
67sub clean;
68sub test;
69
70sub AUTOLOAD {
71 my($l) = $AUTOLOAD;
72 $l =~ s/.*:://;
73 my(%EXPORT);
74 @EXPORT{@EXPORT} = '';
75 if (exists $EXPORT{$l}){
76 CPAN::Shell->$l(@_);
77 } else {
78 warn "CPAN doesn't know how to autoload $AUTOLOAD :-(
79Nothing Done.
80";
81 CPAN::Shell->h;
82 }
83}
84
85sub all {
86 my($mgr,$class) = @_;
87 CPAN->debug("mgr[$mgr] class[$class]") if $CPAN::DEBUG;
88 CPAN::Index->reload;
89 values %{ $META->{$class} };
90}
91
92# Called by shell, not in batch mode. Not clean XXX
93sub checklock {
94 my($self) = @_;
95 my $lockfile = CPAN->catfile($CPAN::Config->{cpan_home},".lock");
96 if (-f $lockfile && -M _ > 0) {
97 my $fh = IO::File->new($lockfile);
98 my $other = <$fh>;
99 $fh->close;
100 if (defined $other && $other) {
101 chomp $other;
102 return if $$==$other; # should never happen
103 print qq{There seems to be running another CPAN process ($other). Trying to contact...\n};
104 if (kill 0, $other) {
105 Carp::croak qq{Other job is running.\n}.
106 qq{You may want to kill it and delete the lockfile, maybe. On UNIX try:\n}.
107 qq{ kill $other\n}.
108 qq{ rm $lockfile\n};
109 } elsif (-w $lockfile) {
110 my($ans)=
111 ExtUtils::MakeMaker::prompt
112 (qq{Other job not responding. Shall I overwrite the lockfile? (Y/N)},"y");
113 print("Ok, bye\n"), exit unless $ans =~ /^y/i;
114 } else {
115 Carp::croak(
116 qq{Lockfile $lockfile not writeable by you. Cannot proceed.\n}.
117 qq{ On UNIX try:\n}.
118 qq{ rm $lockfile\n}.
119 qq{ and then rerun us.\n}
120 );
121 }
122 }
123 }
124 File::Path::mkpath($CPAN::Config->{cpan_home});
125 my $fh;
126 unless ($fh = IO::File->new(">$lockfile")) {
127 if ($! =~ /Permission/) {
128 my $incc = $INC{'CPAN/Config.pm'};
129 my $myincc = MY->catfile($ENV{HOME},'.cpan','CPAN','MyConfig.pm');
130 print qq{
131
132Your configuration suggests that CPAN.pm should use a working
133directory of
134 $CPAN::Config->{cpan_home}
135Unfortunately we could not create the lock file
136 $lockfile
137due to permission problems.
138
139Please make sure that the configuration variable
140 \$CPAN::Config->{cpan_home}
141points to a directory where you can write a .lock file. You can set
142this variable in either
143 $incc
144or
145 $myincc
146
147};
148 }
149 Carp::croak "Could not open >$lockfile: $!";
150 }
151 print $fh $$, "\n";
152 $self->{LOCK} = $lockfile;
153 $fh->close;
154 $SIG{'TERM'} = sub { &cleanup; die "Got SIGTERM, leaving"; };
155 $SIG{'INT'} = sub { &cleanup, die "Got a second SIGINT" if $Signal; $Signal = 1; };
156 $SIG{'__DIE__'} = \&cleanup;
157 print STDERR "Signal handler set.\n" unless $CPAN::Config->{'inhibit_startup_message'};
158}
159
160sub DESTROY {
161 &cleanup; # need an eval?
162}
163
164sub exists {
165 my($mgr,$class,$id) = @_;
166 CPAN::Index->reload;
167 Carp::croak "exists called without class argument" unless $class;
168 $id ||= "";
169 exists $META->{$class}{$id};
170}
171
172sub hasFTP {
173 my($self,$arg) = @_;
174 if (defined $arg) {
175 return $self->{'hasFTP'} = $arg;
176 } elsif (not defined $self->{'hasFTP'}) {
177 eval {require Net::FTP;};
178 $self->{'hasFTP'} = $@ ? 0 : 1;
179 }
180 return $self->{'hasFTP'};
181}
182
183sub hasLWP {
184 my($self,$arg) = @_;
185 if (defined $arg) {
186 return $self->{'hasLWP'} = $arg;
187 } elsif (not defined $self->{'hasLWP'}) {
188 eval {require LWP;};
189 $LWP::VERSION ||= 0;
190 $self->{'hasLWP'} = $LWP::VERSION >= 4.98;
191 }
192 return $self->{'hasLWP'};
193}
194
195sub hasMD5 {
196 my($self,$arg) = @_;
197 if (defined $arg) {
198 $self->{'hasMD5'} = $arg;
199 } elsif (not defined $self->{'hasMD5'}) {
200 eval {require MD5;};
201 if ($@) {
202 print "MD5 security checks disabled because MD5 not installed. Please consider installing MD5\n";
203 $self->{'hasMD5'} = 0;
204 } else {
205 $self->{'hasMD5'}++;
206 }
207 }
208 return $self->{'hasMD5'};
209}
210
211sub instance {
212 my($mgr,$class,$id) = @_;
213 CPAN::Index->reload;
214 Carp::croak "instance called without class argument" unless $class;
215 $id ||= "";
216 $META->{$class}{$id} ||= $class->new(ID => $id );
217}
218
219sub new {
220 bless {}, shift;
221}
222
223sub cleanup {
224 local $SIG{__DIE__} = '';
225 my $i = 0; my $ineval = 0; my $sub;
226 while ((undef,undef,undef,$sub) = caller(++$i)) {
227 $ineval = 1, last if $sub eq '(eval)';
228 }
229 return if $ineval && !$End;
230 return unless defined $META->{'LOCK'};
231 return unless -f $META->{'LOCK'};
232 unlink $META->{'LOCK'};
233 print STDERR "Lockfile removed.\n";
234# my $mess = Carp::longmess(@_);
235# die @_;
236}
237
238sub shell {
239 $Suppress_readline ||= ! -t STDIN;
240
241 my $prompt = "cpan> ";
242 local($^W) = 1;
243 my $term;
244 unless ($Suppress_readline) {
245 require Term::ReadLine;
246 import Term::ReadLine;
247 $term = new Term::ReadLine 'CPAN Monitor';
248 $readline::rl_completion_function =
249 $readline::rl_completion_function = 'CPAN::Complete::complete';
250 }
251
252 no strict;
253 $META->checklock();
254 my $cwd = Cwd::cwd();
255 # How should we determine if we have more than stub ReadLine enabled?
256 my $rl_avail = $Suppress_readline ? "suppressed" :
257 defined &Term::ReadLine::Perl::readline ? "enabled" :
258 "available (get Term::ReadKey and Term::ReadLine::Perl)";
259
260 print qq{
261cpan shell -- CPAN exploration and modules installation (v$CPAN::VERSION)
262Readline support $rl_avail
263
264} unless $CPAN::Config->{'inhibit_startup_message'} ;
265 while () {
266 if ($Suppress_readline) {
267 print $prompt;
268 last unless defined (chomp($_ = <>));
269 } else {
270 last unless defined ($_ = $term->readline($prompt));
271 }
272 s/^\s//;
273 next if /^$/;
274 $_ = 'h' if $_ eq '?';
275 if (/^\!/) {
276 s/^\!//;
277 my($eval) = $_;
278 package CPAN::Eval;
279 use vars qw($import_done);
280 CPAN->import(':DEFAULT') unless $import_done++;
281 CPAN->debug("eval[$eval]") if $CPAN::DEBUG;
282 eval($eval);
283 warn $@ if $@;
284 } elsif (/^q(?:uit)?$/i) {
285 last;
286 } elsif (/./) {
287 my @line = split;
288 my $command = shift @line;
289 eval { CPAN::Shell->$command(@line) };
290 warn $@ if $@;
291 }
292 } continue {
293 &cleanup, die if $Signal;
294 chdir $cwd;
295 print "\n";
296 }
297}
298
299package CPAN::Shell;
300use vars qw(@ISA $AUTOLOAD);
301@ISA = qw(CPAN::Debug);
302
303# private function ro re-eval this module (handy during development)
304sub AUTOLOAD {
305 warn "CPAN::Shell doesn't know how to autoload $AUTOLOAD :-(
306Nothing Done.
307";
308 CPAN::Shell->h;
309}
310
311sub h {
312 my($class,$about) = @_;
313 if (defined $about) {
314 print "Detailed help not yet implemented\n";
315 } else {
316 print q{
317command arguments description
318a string authors
319b or display bundles
320d /regex/ info distributions
321m or about modules
322i none anything of above
323
324r as reinstall recommendations
325u above uninstalled distributions
326See manpage for autobundle() and recompile()
327
328make modules, make
329test dists, bundles, make test (implies make)
330install "r" or "u" make install (implies test)
331clean make clean
332
333reload index|cpan load most recent indices/CPAN.pm
334h or ? display this menu
335o various set and query options
336! perl-code eval a perl command
337q quit the shell subroutine
338};
339 }
340}
341
342sub a { print shift->format_result('Author',@_);}
343sub b {
344 my($self,@which) = @_;
345 my($bdir) = $CPAN::META->catdir($CPAN::Config->{'cpan_home'},"Bundle");
346 my($dh) = DirHandle->new($bdir); # may fail!
347 my($entry);
348 for $entry ($dh->read) {
349 next if -d $CPAN::META->catdir($bdir,$entry);
350 next unless $entry =~ s/\.pm$//;
351 $CPAN::META->instance('CPAN::Bundle',"Bundle::$entry");
352 }
353 print $self->format_result('Bundle',@which);
354}
355sub d { print shift->format_result('Distribution',@_);}
356sub m { print shift->format_result('Module',@_);}
357
358sub i {
359 my($self) = shift;
360 my(@args) = @_;
361 my(@type,$type,@m);
362 @type = qw/Author Bundle Distribution Module/;
363 @args = '/./' unless @args;
364 my(@result);
365 for $type (@type) {
366 push @result, $self->expand($type,@args);
367 }
368 my $result = @result==1 ? $result[0]->as_string : join "", map {$_->as_glimpse} @result;
369 $result ||= "No objects found of any type for argument @args\n";
370 print $result;
371}
372
373sub o {
374 my($self,$o_type,@o_what) = @_;
375 $o_type ||= "";
376 CPAN->debug("o_type[$o_type] o_what[@o_what]\n");
377 if ($o_type eq 'conf') {
378 shift @o_what if @o_what && $o_what[0] eq 'help';
379 if (!@o_what) {
380 my($k,$v);
381 print "CPAN::Config options:\n";
382 for $k (sort keys %CPAN::Config::can) {
383 $v = $CPAN::Config::can{$k};
384 printf " %-18s %s\n", $k, $v;
385 }
386 print "\n";
387 for $k (sort keys %$CPAN::Config) {
388 $v = $CPAN::Config->{$k};
389 if (ref $v) {
390 printf " %-18s\n", $k;
391 print map {"\t$_\n"} @{$v};
392 } else {
393 printf " %-18s %s\n", $k, $v;
394 }
395 }
396 print "\n";
397 } elsif (!CPAN::Config->edit(@o_what)) {
398 print qq[Type 'o conf' to view configuration edit options\n\n];
399 }
400 } elsif ($o_type eq 'debug') {
401 my(%valid);
402 @o_what = () if defined $o_what[0] && $o_what[0] =~ /help/i;
403 if (@o_what) {
404 while (@o_what) {
405 my($what) = shift @o_what;
406 if ( exists $CPAN::DEBUG{$what} ) {
407 $CPAN::DEBUG |= $CPAN::DEBUG{$what};
408 } elsif ($what =~ /^\d/) {
409 $CPAN::DEBUG = $what;
410 } elsif (lc $what eq 'all') {
411 my($max) = 0;
412 for (values %CPAN::DEBUG) {
413 $max += $_;
414 }
415 $CPAN::DEBUG = $max;
416 } else {
417 for (keys %CPAN::DEBUG) {
418 next unless lc($_) eq lc($what);
419 $CPAN::DEBUG |= $CPAN::DEBUG{$_};
420 }
421 print "unknown argument $what\n";
422 }
423 }
424 } else {
425 print "Valid options for debug are ".join(", ",sort(keys %CPAN::DEBUG), 'all').
426 " or a number. Completion works on the options. Case is ignored.\n\n";
427 }
428 if ($CPAN::DEBUG) {
429 print "Options set for debugging:\n";
430 my($k,$v);
431 for $k (sort {$CPAN::DEBUG{$a} <=> $CPAN::DEBUG{$b}} keys %CPAN::DEBUG) {
432 $v = $CPAN::DEBUG{$k};
433 printf " %-14s(%s)\n", $k, $v if $v & $CPAN::DEBUG;
434 }
435 } else {
436 print "Debugging turned off completely.\n";
437 }
438 } else {
439 print qq{
440Known options:
441 conf set or get configuration variables
442 debug set or get debugging options
443};
444 }
445}
446
447sub reload {
448 if ($_[1] =~ /cpan/i) {
449 CPAN->debug("reloading the whole CPAN.pm") if $CPAN::DEBUG;
450 my $fh = IO::File->new($INC{'CPAN.pm'});
451 local $/;
452 undef $/;
453 eval <$fh>;
454 warn $@ if $@;
455 } elsif ($_[1] =~ /index/) {
456 CPAN::Index->force_reload;
457 }
458}
459
460sub _binary_extensions {
461 my($self) = shift @_;
462 my(@result,$module,%seen,%need,$headerdone);
463 for $module ($self->expand('Module','/./')) {
464 my $file = $module->cpan_file;
465 next if $file eq "N/A";
466 next if $file =~ /^Contact Author/;
467 next if $file =~ /perl5[._-]\d{3}(?:[\d_]+)?\.tar[._-]gz$/;
468 next unless $module->xs_file;
469 push @result, $module;
470 }
471# print join " | ", @result;
472# print "\n";
473 return @result;
474}
475
476sub recompile {
477 my($self) = shift @_;
478 my($module,@module,$cpan_file,%dist);
479 @module = $self->_binary_extensions();
480 for $module (@module){ # we force now and compile later, so we don't do it twice
481 $cpan_file = $module->cpan_file;
482 my $pack = $CPAN::META->instance('CPAN::Distribution',$cpan_file);
483 $pack->force;
484 $dist{$cpan_file}++;
485 }
486 for $cpan_file (sort keys %dist) {
487 print " CPAN: Recompiling $cpan_file\n\n";
488 my $pack = $CPAN::META->instance('CPAN::Distribution',$cpan_file);
489 $pack->install;
490 $CPAN::Signal = 0; # it's tempting to reset Signal, so we can
491 # stop a package from recompiling,
492 # e.g. IO-1.12 when we have perl5.003_10
493 }
494}
495
496sub _u_r_common {
497 my($self) = shift @_;
498 my($what) = shift @_;
499 CPAN->debug("self[$self] what[$what] args[@_]") if $CPAN::DEBUG;
500 Carp::croak "Usage: \$obj->_u_r_common($what)" unless defined $what;
501 Carp::croak "Usage: \$obj->_u_r_common(a|r|u)" unless $what =~ /^[aru]$/;
502 my(@args) = @_;
503 @args = '/./' unless @args;
504 my(@result,$module,%seen,%need,$headerdone,$version_zeroes);
505 $version_zeroes = 0;
506 my $sprintf = "%-25s %9s %9s %s\n";
507 for $module ($self->expand('Module',@args)) {
508 my $file = $module->cpan_file;
509 next unless defined $file; # ??
510 my($latest) = $module->cpan_version || 0;
511 my($inst_file) = $module->inst_file;
512 my($have);
513 if ($inst_file){
514 if ($what eq "a") {
515 $have = $module->inst_version;
516 } elsif ($what eq "r") {
517 $have = $module->inst_version;
518 local($^W) = 0;
519 $version_zeroes++ unless $have;
520 next if $have >= $latest;
521 } elsif ($what eq "u") {
522 next;
523 }
524 } else {
525 if ($what eq "a") {
526 next;
527 } elsif ($what eq "r") {
528 next;
529 } elsif ($what eq "u") {
530 $have = "-";
531 }
532 }
533 $seen{$file} ||= 0;
534 if ($what eq "a") {
535 push @result, sprintf "%s %s\n", $module->id, $have;
536 } elsif ($what eq "r") {
537 push @result, $module->id;
538 next if $seen{$file}++;
539 } elsif ($what eq "u") {
540 push @result, $module->id;
541 next if $seen{$file}++;
542 next if $file =~ /^Contact/;
543 }
544 unless ($headerdone++){
545 print "\n";
546 printf $sprintf, "Package namespace", "installed", "latest", "in CPAN file";
547 }
548 $latest = substr($latest,0,8) if length($latest) > 8;
549 $have = substr($have,0,8) if length($have) > 8;
550 printf $sprintf, $module->id, $have, $latest, $file;
551 $need{$module->id}++;
552 return if $CPAN::Signal; # this is sometimes lengthy
553 }
554 unless (%need) {
555 if ($what eq "u") {
556 print "No modules found for @args\n";
557 } elsif ($what eq "r") {
558 print "All modules are up to date for @args\n";
559 }
560 }
561 if ($what eq "r" && $version_zeroes) {
562 my $s = $version_zeroes>1 ? "s have" : " has";
563 print qq{$version_zeroes installed module$s no version number to compare\n};
564 }
565 @result;
566}
567
568sub r {
569 shift->_u_r_common("r",@_);
570}
571
572sub u {
573 shift->_u_r_common("u",@_);
574}
575
576sub autobundle {
577 my($self) = shift;
578 my(@bundle) = $self->_u_r_common("a",@_);
579 my($todir) = $CPAN::META->catdir($CPAN::Config->{'cpan_home'},"Bundle");
580 File::Path::mkpath($todir);
581 unless (-d $todir) {
582 print "Couldn't mkdir $todir for some reason\n";
583 return;
584 }
585 my($y,$m,$d) = (localtime)[5,4,3];
586 $y+=1900;
587 $m++;
588 my($c) = 0;
589 my($me) = sprintf "Snapshot_%04d_%02d_%02d_%02d", $y, $m, $d, $c;
590 my($to) = $CPAN::META->catfile($todir,"$me.pm");
591 while (-f $to) {
592 $me = sprintf "Snapshot_%04d_%02d_%02d_%02d", $y, $m, $d, ++$c;
593 $to = $CPAN::META->catfile($todir,"$me.pm");
594 }
595 my($fh) = IO::File->new(">$to") or Carp::croak "Can't open >$to: $!";
596 $fh->print(
597 "package Bundle::$me;\n\n",
598 "\$VERSION = '0.01';\n\n",
599 "1;\n\n",
600 "__END__\n\n",
601 "=head1 NAME\n\n",
602 "Bundle::$me - Snapshot of installation on ",
603 $Config::Config{'myhostname'},
604 " on ",
605 scalar(localtime),
606 "\n\n=head1 SYNOPSIS\n\n",
607 "perl -MCPAN -e 'install Bundle::$me'\n\n",
608 "=head1 CONTENTS\n\n",
609 join("\n", @bundle),
610 "\n\n=head1 CONFIGURATION\n\n",
611 Config->myconfig,
612 "\n\n=head1 AUTHOR\n\n",
613 "This Bundle has been generated automatically by the autobundle routine in CPAN.pm.\n",
614 );
615 $fh->close;
616 print "\nWrote bundle file
617 $to\n\n";
618}
619
620sub bundle {
621 shift;
622 my(@bundles) = @_;
623 my $bundle;
624 my @pack = ();
625 foreach $bundle (@bundles) {
626 my $pack = $bundle;
627 $pack =~ s/^(Bundle::)?(.*)/Bundle::$2/;
628 push @pack, $CPAN::META->instance('CPAN::Bundle',$pack)->contains;
629 }
630 @pack;
631}
632
633sub bundles {
634 my($self) = @_;
635 CPAN->debug("self[$self]") if $CPAN::DEBUG;
636 sort grep $_->id() =~ /^Bundle::/, $CPAN::META->all('CPAN::Bundle');
637}
638
639sub expand {
640 shift;
641 my($type,@args) = @_;
642 my($arg,@m);
643 for $arg (@args) {
644 my $regex;
645 if ($arg =~ m|^/(.*)/$|) {
646 $regex = $1;
647 }
648 my $class = "CPAN::$type";
649 my $obj;
650 if (defined $regex) {
651 for $obj ( sort {$a->id cmp $b->id} $CPAN::META->all($class)) {
652 push @m, $obj if $obj->id =~ /$regex/i or $obj->can('name') && $obj->name =~ /$regex/i;
653 }
654 } else {
655 my($xarg) = $arg;
656 if ( $type eq 'Bundle' ) {
657 $xarg =~ s/^(Bundle::)?(.*)/Bundle::$2/;
658 }
659 if ($CPAN::META->exists($class,$xarg)) {
660 $obj = $CPAN::META->instance($class,$xarg);
661 } elsif ($obj = $CPAN::META->exists($class,$arg)) {
662 $obj = $CPAN::META->instance($class,$arg);
663 } else {
664 next;
665 }
666 push @m, $obj;
667 }
668 }
669 return @m;
670}
671
672sub format_result {
673 my($self) = shift;
674 my($type,@args) = @_;
675 @args = '/./' unless @args;
676 my(@result) = $self->expand($type,@args);
677 my $result = @result==1 ? $result[0]->as_string : join "", map {$_->as_glimpse} @result;
678 $result ||= "No objects of type $type found for argument @args\n";
679 $result;
680}
681
682sub rematein {
683 shift;
684 my($meth,@some) = @_;
685 my $pragma = "";
686 if ($meth eq 'force') {
687 $pragma = $meth;
688 $meth = shift @some;
689 }
690 CPAN->debug("pragma[$pragma]meth[$meth] some[@some]") if $CPAN::DEBUG;
691 my($s,@s);
692 foreach $s (@some) {
693 my $obj;
694 if (ref $s) {
695 $obj = $s;
696 } elsif ($s =~ m|/|) { # looks like a file
697 $obj = $CPAN::META->instance('CPAN::Distribution',$s);
698 } elsif ($s =~ m|^Bundle::|) {
699 $obj = $CPAN::META->instance('CPAN::Bundle',$s);
700 } else {
701 $obj = $CPAN::META->instance('CPAN::Module',$s) if $CPAN::META->exists('CPAN::Module',$s);
702 }
703 if (ref $obj) {
704 CPAN->debug(qq{pragma[$pragma] meth[$meth] obj[$obj] as_string\[}.$obj->as_string.qq{\]}) if $CPAN::DEBUG;
705 $obj->$pragma() if $pragma && $obj->can($pragma);
706 $obj->$meth();
707 } else {
708 print "Warning: Cannot $meth $s, don't know what it is\n";
709 }
710 }
711}
712
713sub force { shift->rematein('force',@_); }
714sub readme { shift->rematein('readme',@_); }
715sub make { shift->rematein('make',@_); }
716sub clean { shift->rematein('clean',@_); }
717sub test { shift->rematein('test',@_); }
718sub install { shift->rematein('install',@_); }
719
720package CPAN::FTP;
721use vars qw($Ua @ISA);
722@ISA = qw(CPAN::Debug);
723
724sub ftp_get {
725 my($class,$host,$dir,$file,$target) = @_;
726 $class->debug(
727 qq[Going to fetch file [$file] from dir [$dir]
728 on host [$host] as local [$target]\n]
729 ) if $CPAN::DEBUG;
730 my $ftp = Net::FTP->new($host);
731 $ftp->debug(1) if $CPAN::DEBUG{'FTP'} & $CPAN::DEBUG;
732 $class->debug(qq[Going to ->login("anonymous","$Config::Config{'cf_email'}")\n]);
733 unless ( $ftp->login("anonymous",$Config::Config{'cf_email'}) ){
734 warn "Couldn't login on $host";
735 return;
736 }
737 # print qq[Going to ->cwd("$dir")\n];
738 unless ( $ftp->cwd($dir) ){
739 warn "Couldn't cwd $dir";
740 return;
741 }
742 $ftp->binary;
743 print qq[Going to ->get("$file","$target")\n] if $CPAN::DEBUG;
744 unless ( $ftp->get($file,$target) ){
745 warn "Couldn't fetch $file from $host";
746 return;
747 }
748 $ftp->quit;
749}
750
751sub localize {
752 my($self,$file,$aslocal,$force) = @_;
753 $force ||= 0;
754 Carp::croak "Usage: ->localize(cpan_file,as_local_file[,$force])" unless defined $aslocal;
755 $self->debug("file [$file] aslocal [$aslocal]") if $CPAN::DEBUG;
756
757 return $aslocal if -f $aslocal && -r _ && ! $force;
758
759 my($aslocal_dir) = File::Basename::dirname($aslocal);
760 File::Path::mkpath($aslocal_dir);
761 print STDERR qq{Warning: You are not allowed to write into directory "$aslocal_dir".
762 I\'ll continue, but if you face any problems, they may be due
763 to insufficient permissions.\n} unless -w $aslocal_dir;
764
765 # Inheritance is not easier to manage than a few if/else branches
766 if ($CPAN::META->hasLWP) {
767 require LWP::UserAgent;
768 unless ($Ua) {
769 $Ua = new LWP::UserAgent;
770 $Ua->proxy('ftp', $ENV{'ftp_proxy'}) if defined $ENV{'ftp_proxy'};
771 $Ua->proxy('http', $ENV{'http_proxy'}) if defined $ENV{'http_proxy'};
772 $Ua->no_proxy($ENV{'no_proxy'}) if defined $ENV{'no_proxy'};
773 }
774 }
775
776 # Try the list of urls for each single object. We keep a record
777 # where we did get a file from
778 for (0..$#{$CPAN::Config->{urllist}}) {
779 my $url = $CPAN::Config->{urllist}[$_];
780 $url .= "/" unless substr($url,-1) eq "/";
781 $url .= $file;
782 $self->debug("localizing[$url]") if $CPAN::DEBUG;
783 if ($url =~ /^file:/) {
784 my $l;
785 if ($CPAN::META->hasLWP) {
786 require URI::URL;
787 my $u = new URI::URL $url;
788 $l = $u->path;
789 } else { # works only on Unix
790 ($l = $url) =~ s/^file://;
791 }
792 return $l if -f $l && -r _;
793 }
794
795 if ($CPAN::META->hasLWP) {
796 print "Fetching $url\n";
797 my $res = $Ua->mirror($url, $aslocal);
798 if ($res->is_success) {
799 return $aslocal;
800 }
801 } elsif ($url =~ m|^ftp://(.*?)/(.*)/(.*)|) {
802 unless ($CPAN::META->hasFTP) {
803 warn "Can't access URL $url without module Net::FTP";
804 next;
805 }
806 my($host,$dir,$getfile) = ($1,$2,$3);
807 $dir =~ s|/+|/|g;
808 print "Going to fetch file [$getfile] from dir [$dir] on host [$host] as local [$aslocal]\n";
809
810 #### This was the bug where I contacted Graham and got so strange error messages
811 #### ftp_get($host,$dir,$getfile,$aslocal) && return $aslocal;
812 CPAN::FTP->ftp_get($host,$dir,$getfile,$aslocal) && return $aslocal;
813 }
814 }
815 Carp::croak("Cannot fetch $file from anywhere");
816}
817
818package CPAN::Complete;
819use vars qw(@ISA);
820@ISA = qw(CPAN::Debug);
821
822sub complete {
823 my($word,$line,$pos) = @_;
824 $word ||= "";
825 $line ||= "";
826 $pos ||= 0;
827 CPAN->debug("word [$word] line[$line] pos[$pos]") if $CPAN::DEBUG;
828 $line =~ s/^\s*//;
829 my @return;
830 if ($pos == 0) {
831 @return = grep(/^$word/, sort qw(! a b d h i m o q r u autobundle clean make test install reload));
832 } elsif ( $line !~ /^[\!abdhimorut]/ ) {
833 @return = ();
834 } elsif ($line =~ /^a\s/) {
835 @return = completex('CPAN::Author',$word);
836 } elsif ($line =~ /^b\s/) {
837 @return = completex('CPAN::Bundle',$word);
838 } elsif ($line =~ /^d\s/) {
839 @return = completex('CPAN::Distribution',$word);
840 } elsif ($line =~ /^([mru]\s|(make|clean|test|install)\s)/ ) {
841 @return = (completex('CPAN::Module',$word),completex('CPAN::Bundle',$word));
842 } elsif ($line =~ /^i\s/) {
843 @return = complete_any($word);
844 } elsif ($line =~ /^reload\s/) {
845 @return = complete_reload($word,$line,$pos);
846 } elsif ($line =~ /^o\s/) {
847 @return = complete_option($word,$line,$pos);
848 } else {
849 @return = ();
850 }
851 return @return;
852}
853
854sub completex {
855 my($class, $word) = @_;
856 grep /^\Q$word\E/, map { $_->id } $CPAN::META->all($class);
857}
858
859sub complete_any {
860 my($word) = shift;
861 return (
862 completex('CPAN::Author',$word),
863 completex('CPAN::Bundle',$word),
864 completex('CPAN::Distribution',$word),
865 completex('CPAN::Module',$word),
866 );
867}
868
869sub complete_reload {
870 my($word,$line,$pos) = @_;
871 $word ||= "";
872 my(@words) = split " ", $line;
873 CPAN->debug("word[$word] line[$line] pos[$pos]") if $CPAN::DEBUG;
874 my(@ok) = qw(cpan index);
875 return @ok if @words==1;
876 return grep /^\Q$word\E/, @ok if @words==2 && $word;
877}
878
879sub complete_option {
880 my($word,$line,$pos) = @_;
881 $word ||= "";
882 my(@words) = split " ", $line;
883 CPAN->debug("word[$word] line[$line] pos[$pos]") if $CPAN::DEBUG;
884 my(@ok) = qw(conf debug);
885 return @ok if @words==1;
886 return grep /^\Q$word\E/, @ok if @words==2 && $word;
887 if (0) {
888 } elsif ($words[1] eq 'index') {
889 return ();
890 } elsif ($words[1] eq 'conf') {
891 return CPAN::Config::complete(@_);
892 } elsif ($words[1] eq 'debug') {
893 return sort grep /^\Q$word\E/, sort keys %CPAN::DEBUG, 'all';
894 }
895}
896
897package CPAN::Index;
898use vars qw($last_time @ISA);
899@ISA = qw(CPAN::Debug);
900$last_time ||= 0;
901
902sub force_reload {
903 my($class) = @_;
904 $CPAN::Index::last_time = 0;
905 $class->reload(1);
906}
907
908sub reload {
909 my($cl,$force) = @_;
910 my $time = time;
911
912 # XXX check if a newer one is available. (We currently read it from time to time)
913 return if $last_time + $CPAN::Config->{index_expire}*86400 > $time;
914 $last_time = $time;
915
916 $cl->read_authindex($cl->reload_x("authors/01mailrc.txt.gz","01mailrc.gz",$force));
917 return if $CPAN::Signal; # this is sometimes lengthy
918 $cl->read_modpacks($cl->reload_x("modules/02packages.details.txt.gz","02packag.gz",$force));
919 return if $CPAN::Signal; # this is sometimes lengthy
920 $cl->read_modlist($cl->reload_x("modules/03modlist.data.gz","03mlist.gz",$force));
921}
922
923sub reload_x {
924 my($cl,$wanted,$localname,$force) = @_;
925 $force ||= 0;
926 my $abs_wanted = CPAN->catfile($CPAN::Config->{'keep_source_where'},$localname);
927 if (-f $abs_wanted && -M $abs_wanted < $CPAN::Config->{'index_expire'} && !$force) {
928 my($s) = $CPAN::Config->{'index_expire'} != 1;
929 $cl->debug(qq{$abs_wanted younger than $CPAN::Config->{'index_expire'} day$s. I\'ll use that.\n});
930 return $abs_wanted;
931 } else {
932 $force ||= 1;
933 }
934 return CPAN::FTP->localize($wanted,$abs_wanted,$force);
935}
936
937sub read_authindex {
938 my($cl,$index_target) = @_;
939 my $pipe = "$CPAN::Config->{gzip} --decompress --stdout $index_target";
940 warn "Going to read $index_target\n";
941 my $fh = IO::File->new("$pipe|");
942 while (<$fh>) {
943 chomp;
944 my($userid,$fullname,$email) = /alias\s+(\S+)\s+\"([^\"\<]+)\s+<([^\>]+)\>\"/;
945 next unless $userid && $fullname && $email;
946
947 # instantiate an author object
948 my $userobj = $CPAN::META->instance('CPAN::Author',$userid);
949 $userobj->set('FULLNAME' => $fullname, 'EMAIL' => $email);
950 return if $CPAN::Signal;
951 }
952 $fh->close;
953 $? and Carp::croak "FAILED $pipe: exit status [$?]";
954}
955
956sub read_modpacks {
957 my($cl,$index_target) = @_;
958 my $pipe = "$CPAN::Config->{gzip} --decompress --stdout $index_target";
959 warn "Going to read $index_target\n";
960 my $fh = IO::File->new("$pipe|");
961 while (<$fh>) {
962 next if 1../^\s*$/;
963 chomp;
964 my($mod,$version,$dist) = split;
965 $version =~ s/^\+//;
966
967 # if it as a bundle, instatiate a bundle object
968 my($bundle) = $mod =~ /^Bundle::(.*)/;
969 $version = "n/a" if $mod =~ s/(.+::.+::).+/$1*/; # replace the third level with a star
970
971 if ($mod eq 'CPAN') {
972 local($^W)=0;
973 if ($version > $CPAN::VERSION){
974 print qq{
975 Hey, you know what? There\'s a new CPAN.pm version (v$version)
976 available! I\'d suggest--provided you have time--you try
977 install CPAN
978 reload cpan
979 without quitting the current session. It should be a seemless upgrade
980 while we are running...
981};
982 sleep 2;
983 print qq{\n};
984 }
985 }
986
987 my($id);
988 if ($bundle){
989 $id = $CPAN::META->instance('CPAN::Bundle',$mod);
990 $id->set('CPAN_VERSION' => $version, 'CPAN_FILE' => $dist);
991# This "next" makes us faster but if the job is running long, we ignore
992# rereads which is bad. So we have to be a bit slower again.
993# } elsif ($CPAN::META->exists('CPAN::Module',$mod)) {
994# next;
995 } else {
996 # instantiate a module object
997 $id = $CPAN::META->instance('CPAN::Module',$mod);
998 $id->set('CPAN_VERSION' => $version, 'CPAN_FILE' => $dist);
999 }
1000
1001 # determine the author
1002 my($userid) = $dist =~ /([^\/]+)/;
1003 $id->set('CPAN_USERID' => $userid) if $userid =~ /\w/;
1004
1005 # instantiate a distribution object
1006 unless ($CPAN::META->exists('CPAN::Distribution',$dist)) {
1007 $CPAN::META->instance(
1008 'CPAN::Distribution' => $dist
1009 )->set(
1010 'CPAN_USERID' => $userid
1011 )
1012 if $userid =~ /\w/;
1013 }
1014
1015 return if $CPAN::Signal;
1016 }
1017 $fh->close;
1018 $? and Carp::croak "FAILED $pipe: exit status [$?]";
1019}
1020
1021sub read_modlist {
1022 my($cl,$index_target) = @_;
1023 my $pipe = "$CPAN::Config->{gzip} --decompress --stdout $index_target";
1024 warn "Going to read $index_target\n";
1025 my $fh = IO::File->new("$pipe|");
1026 my $eval = "";
1027 while (<$fh>) {
1028 next if 1../^\s*$/;
1029 next if /use vars/; # will go away in 03...
1030 $eval .= $_;
1031 return if $CPAN::Signal;
1032 }
1033 $eval .= q{CPAN::Modulelist->data;};
1034 local($^W) = 0;
1035 my($comp) = Safe->new("CPAN::Safe1");
1036 my $ret = $comp->reval($eval);
1037 Carp::confess($@) if $@;
1038 return if $CPAN::Signal;
1039 for (keys %$ret) {
1040 my $obj = $CPAN::META->instance(CPAN::Module,$_);
1041 $obj->set(%{$ret->{$_}});
1042 return if $CPAN::Signal;
1043 }
1044}
1045
1046package CPAN::InfoObj;
1047use vars qw(@ISA);
1048@ISA = qw(CPAN::Debug);
1049
1050sub new { my $this = bless {}, shift; %$this = @_; $this }
1051
1052sub set {
1053 my($self,%att) = @_;
1054 my(%oldatt) = %$self;
1055 %$self = (%oldatt, %att);
1056}
1057
1058sub id { shift->{'ID'} }
1059
1060sub as_glimpse {
1061 my($self) = @_;
1062 my(@m);
1063 my $class = ref($self);
1064 $class =~ s/^CPAN:://;
1065 push @m, sprintf "%-15s %s\n", $class, $self->{ID};
1066 join "", @m;
1067}
1068
1069sub as_string {
1070 my($self) = @_;
1071 my(@m);
1072 my $class = ref($self);
1073 $class =~ s/^CPAN:://;
1074 push @m, $class, " id = $self->{ID}\n";
1075 for (sort keys %$self) {
1076 next if $_ eq 'ID';
1077 my $extra = "";
1078 $_ eq "CPAN_USERID" and $extra = " (".$self->author.")";
1079 if (ref $self->{$_}) { # Should we setup a language interface? XXX
1080 push @m, sprintf " %-12s %s%s\n", $_, "@{$self->{$_}}", $extra;
1081 } else {
1082 push @m, sprintf " %-12s %s%s\n", $_, $self->{$_}, $extra;
1083 }
1084 }
1085 join "", @m, "\n";
1086}
1087
1088sub author {
1089 my($self) = @_;
1090 $CPAN::META->instance(CPAN::Author,$self->{CPAN_USERID})->fullname;
1091}
1092
1093package CPAN::Author;
1094use vars qw(@ISA);
1095@ISA = qw(CPAN::Debug CPAN::InfoObj);
1096
1097sub as_glimpse {
1098 my($self) = @_;
1099 my(@m);
1100 my $class = ref($self);
1101 $class =~ s/^CPAN:://;
1102 push @m, sprintf "%-15s %s (%s)\n", $class, $self->{ID}, $self->fullname;
1103 join "", @m;
1104}
1105
1106sub fullname { shift->{'FULLNAME'} }
1107*name = \&fullname;
1108sub email { shift->{'EMAIL'} }
1109
1110package CPAN::Distribution;
1111use vars qw(@ISA);
1112@ISA = qw(CPAN::Debug CPAN::InfoObj);
1113
1114sub called_for {
1115 my($self,$id) = @_;
1116 $self->{'CALLED_FOR'} = $id if defined $id;
1117 return $self->{'CALLED_FOR'};
1118}
1119
1120sub get {
1121 my($self) = @_;
1122 EXCUSE: {
1123 my @e;
1124 exists $self->{'build_dir'} and push @e, "Unwrapped into directory $self->{'build_dir'}";
1125 print join "", map {" $_\n"} @e and return if @e;
1126 }
1127 my($local_file);
1128 my($local_wanted) =
1129 CPAN->catfile(
1130 $CPAN::Config->{keep_source_where},
1131 "authors",
1132 "id",
1133 split("/",$self->{ID})
1134 );
1135
1136 $self->debug("Doing localize") if $CPAN::DEBUG;
1137 $local_file = CPAN::FTP->localize("authors/id/$self->{ID}", $local_wanted);
1138 $self->{localfile} = $local_file;
1139 my $builddir = $CPAN::META->{cachemgr}->dir;
1140 $self->debug("doing chdir $builddir") if $CPAN::DEBUG;
1141 chdir $builddir or Carp::croak("Couldn't chdir $builddir: $!");
1142 my $packagedir;
1143
1144 $self->debug("local_file[$local_file]") if $CPAN::DEBUG;
1145 if ($local_file =~ /(\.tar\.(gz|Z)|\.tgz|\.zip)$/i){
1146 $self->debug("Removing tmp") if $CPAN::DEBUG;
1147 File::Path::rmtree("tmp");
1148 mkdir "tmp", 0777 or Carp::croak "Couldn't mkdir tmp: $!";
1149 chdir "tmp";
1150 $self->debug("Changed directory to tmp") if $CPAN::DEBUG;
1151 if ($local_file =~ /z$/i){
1152 $self->{archived} = "tar";
1153 if (system("$CPAN::Config->{gzip} --decompress --stdout $local_file | $CPAN::Config->{tar} xvf -")==0) {
1154 $self->{unwrapped} = "YES";
1155 } else {
1156 $self->{unwrapped} = "NO";
1157 }
1158 } elsif ($local_file =~ /zip$/i) {
1159 $self->{archived} = "zip";
1160 if (system("$CPAN::Config->{unzip} $local_file")==0) {
1161 $self->{unwrapped} = "YES";
1162 } else {
1163 $self->{unwrapped} = "NO";
1164 }
1165 }
1166 # Let's check if the package has its own directory.
1167 opendir DIR, "." or Carp::croak("Weird: couldn't opendir .: $!");
1168 my @readdir = grep $_ !~ /^\.\.?$/, readdir DIR; ### MAC??
1169 closedir DIR;
1170 my ($distdir,$packagedir);
1171 if (@readdir == 1 && -d $readdir[0]) {
1172 $distdir = $readdir[0];
1173 $packagedir = $CPAN::META->catdir($builddir,$distdir);
1174 -d $packagedir and print "Removing previously used $packagedir\n";
1175 File::Path::rmtree($packagedir);
1176 rename($distdir,$packagedir) or Carp::confess("Couldn't rename $distdir to $packagedir");
1177 } else {
1178 my $pragmatic_dir = $self->{'CPAN_USERID'} . '000';
1179 $pragmatic_dir =~ s/\W_//g;
1180 $pragmatic_dir++ while -d "../$pragmatic_dir";
1181 $packagedir = $CPAN::META->catdir($builddir,$pragmatic_dir);
1182 File::Path::mkpath($packagedir);
1183 my($f);
1184 for $f (@readdir) { # is already without "." and ".."
1185 my $to = $CPAN::META->catdir($packagedir,$f);
1186 rename($f,$to) or Carp::confess("Couldn't rename $f to $to");
1187 }
1188 }
1189 $self->{'build_dir'} = $packagedir;
1190
1191 chdir "..";
1192 $self->debug("Changed directory to .. (self is $self [".$self->as_string."])") if $CPAN::DEBUG;
1193 File::Path::rmtree("tmp");
1194 if ($CPAN::Config->{keep_source_where} =~ /^no/i ){
1195 print "Going to unlink $local_file\n";
1196 unlink $local_file or Carp::carp "Couldn't unlink $local_file";
1197 }
1198 my($makefilepl) = $CPAN::META->catfile($packagedir,"Makefile.PL");
1199 unless (-f $makefilepl) {
1200 my($configure) = $CPAN::META->catfile($packagedir,"Configure");
1201 if (-f $configure) {
1202 # do we have anything to do?
1203 $self->{'configure'} = $configure;
1204 } else {
1205 my $fh = IO::File->new(">$makefilepl") or Carp::croak("Could not open >$makefilepl");
1206 my $cf = $self->called_for || "unknown";
1207 $fh->print(qq{
1208# This Makefile.PL has been autogenerated by the module CPAN.pm
1209# Autogenerated on: }.scalar localtime().qq{
1210 use ExtUtils::MakeMaker;
1211 WriteMakefile(NAME => q[$cf]);
1212});
1213 print qq{Package comes without Makefile.PL.\n}.
1214 qq{ Writing one on our own (calling it $cf)\n};
1215 }
1216 }
1217 } else {
1218 $self->{archived} = "NO";
1219 }
1220 return $self;
1221}
1222
1223sub new {
1224 my($class,%att) = @_;
1225
1226 $CPAN::META->{cachemgr} ||= CPAN::CacheMgr->new();
1227
1228 my $this = { %att };
1229 return bless $this, $class;
1230}
1231
1232sub readme {
1233 my($self) = @_;
1234 print "Readme not yet implemented (says ".$self->id.")\n";
1235}
1236
1237sub verifyMD5 {
1238 my($self) = @_;
1239 EXCUSE: {
1240 my @e;
1241 $self->{MD5_STATUS} and push @e, "MD5 Checksum was ok";
1242 print join "", map {" $_\n"} @e and return if @e;
1243 }
1244 my($local_file);
1245 my(@local) = split("/",$self->{ID});
1246 my($basename) = pop @local;
1247 push @local, "CHECKSUMS";
1248 my($local_wanted) =
1249 CPAN->catfile(
1250 $CPAN::Config->{keep_source_where},
1251 "authors",
1252 "id",
1253 @local
1254 );
1255 local($") = "/";
1256 if (
1257 -f $local_wanted
1258 &&
1259 $self->MD5_check_file($local_wanted,$basename)
1260 ) {
1261 return $self->{MD5_STATUS}="OK";
1262 }
1263 $local_file = CPAN::FTP->localize("authors/id/@local", $local_wanted, 'force>:-{');
1264 my($checksum_pipe);
1265 if ($local_file) {
1266 # fine
1267 } else {
1268 $local[-1] .= ".gz";
1269 $local_file = CPAN::FTP->localize(
1270 "authors/id/@local",
1271 "$local_wanted.gz",
1272 'force>:-{'
1273 );
1274 my $system = "$CPAN::Config->{gzip} --decompress $local_file";
1275 system($system)==0 or die "Could not uncompress $local_file";
1276 $local_file =~ s/\.gz$//;
1277 }
1278 $self->MD5_check_file($local_file,$basename);
1279}
1280
1281sub MD5_check_file {
1282 my($self,$lfile,$basename) = @_;
1283 my($cksum);
1284 my $fh = new IO::File;
1285 local($/)=undef;
1286 if (open $fh, $lfile){
1287 my $eval = <$fh>;
1288 close $fh;
1289 my($comp) = Safe->new();
1290 $cksum = $comp->reval($eval);
1291 Carp::confess($@) if $@;
1292 if ($cksum->{$basename}->{md5}) {
1293 $self->debug("Found checksum for $basename: $cksum->{$basename}->{md5}\n") if $CPAN::DEBUG;
1294 my $file = $self->{localfile};
1295 my $pipe = "$CPAN::Config->{gzip} --decompress --stdout $self->{localfile}|";
1296 if (
1297 open($fh, $file) && $self->eq_MD5($fh,$cksum->{$basename}->{md5})
1298 or
1299 open($fh, $pipe) && $self->eq_MD5($fh,$cksum->{$basename}->{'md5-ungz'})
1300 ){
1301 print "Checksum for $file ok\n";
1302 return $self->{MD5_STATUS}="OK";
1303 } else {
1304 die join(
1305 "",
1306 "\nChecksum mismatch for distribution file. Please investigate.\n\n",
1307 $self->as_string,
1308 $CPAN::META->instance('CPAN::Author',$self->{CPAN_USERID})->as_string,
1309 "Please contact the author or your CPAN site admin"
1310 );
1311 }
1312 close $fh if fileno($fh);
1313 } else {
1314 print "No md5 checksum for $basename in local $lfile\n";
1315 return;
1316 }
1317 } else {
1318 Carp::carp "Could not open $lfile for reading";
1319 }
1320}
1321
1322sub eq_MD5 {
1323 my($self,$fh,$expectMD5) = @_;
1324 my $md5 = new MD5;
1325 $md5->addfile($fh);
1326 my $hexdigest = $md5->hexdigest;
1327 $hexdigest eq $expectMD5;
1328}
1329
1330sub force {
1331 my($self) = @_;
1332 $self->{'force_update'}++;
1333 delete $self->{'MD5_STATUS'};
1334 delete $self->{'archived'};
1335 delete $self->{'build_dir'};
1336 delete $self->{'localfile'};
1337 delete $self->{'make'};
1338 delete $self->{'install'};
1339 delete $self->{'unwrapped'};
1340 delete $self->{'writemakefile'};
1341}
1342
1343sub make {
1344 my($self) = @_;
1345 $self->debug($self->id) if $CPAN::DEBUG;
1346 print "Running make\n";
1347 $self->get;
1348 if ($CPAN::META->hasMD5) {
1349 $self->verifyMD5;
1350 }
1351 EXCUSE: {
1352 my @e;
1353 $self->{archived} eq "NO" and push @e, "Is neither a tar nor a zip archive.";
1354 $self->{unwrapped} eq "NO" and push @e, "had problems unarchiving. Please build manually";
1355 exists $self->{writemakefile} && $self->{writemakefile} eq "NO" and push @e, "Had some problem writing Makefile";
1356 defined $self->{'make'} and push @e, "Has already been processed within this session";
1357 print join "", map {" $_\n"} @e and return if @e;
1358 }
1359 print "\n CPAN: Going to build ".$self->id."\n\n";
1360 my $builddir = $self->dir;
1361 chdir $builddir or Carp::croak("Couldn't chdir $builddir: $!");
1362 $self->debug("Changed directory to $builddir") if $CPAN::DEBUG;
1363
1364 my $system;
1365 if ($self->{'configure'}) {
1366 $system = $self->{'configure'};
1367 } else {
1368 my($perl) = $^X =~ /^\.\// ? "$CPAN::Cwd/$^X" : $^X; # XXX subclassing folks, forgive me!
1369 $system = "$perl Makefile.PL $CPAN::Config->{makepl_arg}";
1370 }
1371 if (system($system)!=0) {
1372 $self->{writemakefile} = "NO";
1373 return;
1374 }
1375 $self->{writemakefile} = "YES";
1376 return if $CPAN::Signal;
1377 $system = join " ", $CPAN::Config->{'make'}, $CPAN::Config->{make_arg};
1378 if (system($system)==0) {
1379 print " $system -- OK\n";
1380 $self->{'make'} = "YES";
1381 } else {
1382 $self->{writemakefile} = "YES";
1383 $self->{'make'} = "NO";
1384 print " $system -- NOT OK\n";
1385 }
1386}
1387
1388sub test {
1389 my($self) = @_;
1390 $self->make;
1391 return if $CPAN::Signal;
1392 print "Running make test\n";
1393 EXCUSE: {
1394 my @e;
1395 exists $self->{'make'} or push @e, "Make had some problems, maybe interrupted? Won't test";
1396 exists $self->{'make'} and $self->{'make'} eq 'NO' and push @e, "Oops, make had returned bad status";
1397 exists $self->{'build_dir'} or push @e, "Has no own directory";
1398 print join "", map {" $_\n"} @e and return if @e;
1399 }
1400 chdir $self->{'build_dir'} or Carp::croak("Couldn't chdir to $self->{'build_dir'}");
1401 $self->debug("Changed directory to $self->{'build_dir'}") if $CPAN::DEBUG;
1402 my $system = join " ", $CPAN::Config->{'make'}, "test";
1403 if (system($system)==0) {
1404 print " $system -- OK\n";
1405 $self->{'make_test'} = "YES";
1406 } else {
1407 $self->{'make_test'} = "NO";
1408 print " $system -- NOT OK\n";
1409 }
1410}
1411
1412sub clean {
1413 my($self) = @_;
1414 print "Running make clean\n";
1415 EXCUSE: {
1416 my @e;
1417 exists $self->{'build_dir'} or push @e, "Has no own directory";
1418 print join "", map {" $_\n"} @e and return if @e;
1419 }
1420 chdir $self->{'build_dir'} or Carp::croak("Couldn't chdir to $self->{'build_dir'}");
1421 $self->debug("Changed directory to $self->{'build_dir'}") if $CPAN::DEBUG;
1422 my $system = join " ", $CPAN::Config->{'make'}, "clean";
1423 if (system($system)==0) {
1424 print " $system -- OK\n";
1425 $self->force;
1426 } else {
1427 # Hmmm, what to do if make clean failed?
1428 }
1429}
1430
1431sub install {
1432 my($self) = @_;
1433 $self->test;
1434 return if $CPAN::Signal;
1435 print "Running make install\n";
1436 EXCUSE: {
1437 my @e;
1438 exists $self->{'build_dir'} or push @e, "Has no own directory";
1439 exists $self->{'make'} or push @e, "Make had some problems, maybe interrupted? Won't install";
1440 exists $self->{'make'} and $self->{'make'} eq 'NO' and push @e, "Oops, make had returned bad status";
1441 exists $self->{'install'} and push @e, $self->{'install'} eq "YES" ? "Already done" : "Already tried without success";
1442 print join "", map {" $_\n"} @e and return if @e;
1443 }
1444 chdir $self->{'build_dir'} or Carp::croak("Couldn't chdir to $self->{'build_dir'}");
1445 $self->debug("Changed directory to $self->{'build_dir'}") if $CPAN::DEBUG;
1446 my $system = join " ", $CPAN::Config->{'make'}, "install", $CPAN::Config->{make_install_arg};
1447 my($pipe) = IO::File->new("$system 2>&1 |");
1448 my($makeout) = "";
1449 while (<$pipe>){
1450 print;
1451 $makeout .= $_;
1452 }
1453 $pipe->close;
1454 if ($?==0) {
1455 print " $system -- OK\n";
1456 $self->{'install'} = "YES";
1457 } else {
1458 $self->{'install'} = "NO";
1459 print " $system -- NOT OK\n";
1460 if ($makeout =~ /permission/s && $> > 0) {
1461 print " You may have to su to root to install the package\n";
1462 }
1463 }
1464}
1465
1466sub dir {
1467 shift->{'build_dir'};
1468}
1469
1470package CPAN::Bundle;
1471use vars qw(@ISA);
1472@ISA = qw(CPAN::Debug CPAN::InfoObj CPAN::Module);
1473
1474sub as_string {
1475 my($self) = @_;
1476 $self->contains;
1477 return $self->SUPER::as_string;
1478}
1479
1480sub contains {
1481 my($self) = @_;
1482 my($parsefile) = $self->inst_file;
1483 unless ($parsefile) {
1484 # Try to get at it in the cpan directory
1485 $self->debug("no parsefile") if $CPAN::DEBUG;
1486 my $dist = $CPAN::META->instance('CPAN::Distribution',$self->{'CPAN_FILE'});
1487 $self->debug($dist->as_string) if $CPAN::DEBUG;
1488 $dist->get;
1489 $self->debug($dist->as_string) if $CPAN::DEBUG;
1490 my($todir) = $CPAN::META->catdir($CPAN::Config->{'cpan_home'},"Bundle");
1491 File::Path::mkpath($todir);
1492 my($me,$from,$to);
1493 ($me = $self->id) =~ s/.*://;
1494 $from = $CPAN::META->catfile($dist->{'build_dir'},"$me.pm");
1495 $to = $CPAN::META->catfile($todir,"$me.pm");
1496 rename($from, $to) or Carp::croak("Couldn't rename $from to $to: $!");
1497 $parsefile = $to;
1498 }
1499 my @result;
1500 my $fh = new IO::File;
1501 local $/ = "\n";
1502 open($fh,$parsefile) or die "Could not open '$parsefile': $!";
1503 my $inpod = 0;
1504 while (<$fh>) {
1505 $inpod = /^=(?!head1\s+CONTENTS)/ ? 0 : /^=head1\s+CONTENTS/ ? 1 : $inpod;
1506 next unless $inpod;
1507 next if /^=/;
1508 next if /^\s+$/;
1509 chomp;
1510 push @result, (split " ", $_, 2)[0];
1511 }
1512 close $fh;
1513 delete $self->{STATUS};
1514 $self->{CONTAINS} = [@result];
1515 @result;
1516}
1517
1518sub inst_file {
1519 my($self) = @_;
1520 my($me,$inst_file);
1521 ($me = $self->id) =~ s/.*://;
1522 $inst_file = $CPAN::META->catfile($CPAN::Config->{'cpan_home'},"Bundle", "$me.pm");
1523 return $self->{'INST_FILE'} = $inst_file if -f $inst_file;
1524 $inst_file = $self->SUPER::inst_file;
1525 return $self->{'INST_FILE'} = $inst_file if -f $inst_file;
1526 return $self->{'INST_FILE'}; # even if undefined?
1527}
1528
1529sub rematein {
1530 my($self,$meth) = @_;
1531 $self->debug("self[$self] meth[$meth]") if $CPAN::DEBUG;
1532 my($s);
1533 for $s ($self->contains) {
1534 $CPAN::META->instance('CPAN::Module',$s)->$meth();
1535 }
1536}
1537
1538sub install { shift->rematein('install',@_); }
1539sub clean { shift->rematein('clean',@_); }
1540sub test { shift->rematein('test',@_); }
1541sub make { shift->rematein('make',@_); }
1542
1543# XXX not yet implemented!
1544sub readme {
1545 my($self) = @_;
1546 my($file) = $self->cpan_file or print("No File found for bundle ", $self->id, "\n"), return;
1547 $self->debug("self[$self] file[$file]") if $CPAN::DEBUG;
1548 $CPAN::META->instance('CPAN::Distribution',$file)->readme;
1549# CPAN::FTP->localize("authors/id/$file",$index_wanted); # XXX
1550}
1551
1552package CPAN::Module;
1553use vars qw(@ISA);
1554@ISA = qw(CPAN::Debug CPAN::InfoObj);
1555
1556sub as_glimpse {
1557 my($self) = @_;
1558 my(@m);
1559 my $class = ref($self);
1560 $class =~ s/^CPAN:://;
1561 push @m, sprintf "%-15s %-15s (%s)\n", $class, $self->{ID}, $self->cpan_file;
1562 join "", @m;
1563}
1564
1565sub as_string {
1566 my($self) = @_;
1567 my(@m);
1568 CPAN->debug($self) if $CPAN::DEBUG;
1569 my $class = ref($self);
1570 $class =~ s/^CPAN:://;
1571 local($^W) = 0;
1572 push @m, $class, " id = $self->{ID}\n";
1573 my $sprintf = " %-12s %s\n";
1574 push @m, sprintf $sprintf, 'DESCRIPTION', $self->{description} if $self->{description};
1575 my $sprintf2 = " %-12s %s (%s)\n";
1576 my($userid);
1577 if ($userid = $self->{'CPAN_USERID'} || $self->{'userid'}){
1578 push @m, sprintf(
1579 $sprintf2,
1580 'CPAN_USERID',
1581 $userid,
1582 $CPAN::META->instance(CPAN::Author,$userid)->fullname
1583 )
1584 }
1585 push @m, sprintf $sprintf, 'CPAN_VERSION', $self->{CPAN_VERSION} if $self->{CPAN_VERSION};
1586 push @m, sprintf $sprintf, 'CPAN_FILE', $self->{CPAN_FILE} if $self->{CPAN_FILE};
1587 my $sprintf3 = " %-12s %1s%1s%1s%1s (%s,%s,%s,%s)\n";
1588 my(%statd,%stats,%statl,%stati);
1589 @statd{qw,? i c a b R M S,} = qw,unknown idea pre-alpha alpha beta released mature standard,;
1590 @stats{qw,? m d u n,} = qw,unknown mailing-list developer comp.lang.perl.* none,;
1591 @statl{qw,? p c + o,} = qw,unknown perl C C++ other,;
1592 @stati{qw,? f r O,} = qw,unknown functions references+ties object-oriented,;
1593 $statd{' '} = 'unknown';
1594 $stats{' '} = 'unknown';
1595 $statl{' '} = 'unknown';
1596 $stati{' '} = 'unknown';
1597 push @m, sprintf(
1598 $sprintf3,
1599 'DSLI_STATUS',
1600 $self->{statd},
1601 $self->{stats},
1602 $self->{statl},
1603 $self->{stati},
1604 $statd{$self->{statd}},
1605 $stats{$self->{stats}},
1606 $statl{$self->{statl}},
1607 $stati{$self->{stati}}
1608 ) if $self->{statd};
1609 my $local_file = $self->inst_file;
1610 if ($local_file && ! exists $self->{MANPAGE}) {
1611 my $fh = IO::File->new($local_file) or Carp::croak("Couldn't open $local_file: $!");
1612 my $inpod = 0;
1613 my(@result);
1614 local $/ = "\n";
1615 while (<$fh>) {
1616 $inpod = /^=(?!head1\s+NAME)/ ? 0 : /^=head1\s+NAME/ ? 1 : $inpod;
1617 next unless $inpod;
1618 next if /^=/;
1619 next if /^\s+$/;
1620 chomp;
1621 push @result, $_;
1622 }
1623 close $fh;
1624 $self->{MANPAGE} = join " ", @result;
1625 }
1626 push @m, sprintf $sprintf, 'MANPAGE', $self->{MANPAGE} if $self->{MANPAGE};
1627 push @m, sprintf $sprintf, 'INST_FILE', $local_file || "(not installed)";
1628 push @m, sprintf $sprintf, 'INST_VERSION', $self->inst_version if $local_file;
1629 join "", @m, "\n";
1630}
1631
1632sub cpan_file {
1633 my $self = shift;
1634 CPAN->debug($self->id) if $CPAN::DEBUG;
1635 unless (defined $self->{'CPAN_FILE'}) {
1636 CPAN::Index->reload;
1637 }
1638 if (defined $self->{'CPAN_FILE'}){
1639 return $self->{'CPAN_FILE'};
1640 } elsif (defined $self->{'userid'}) {
1641 return "Contact Author ".$self->{'userid'}."=".$CPAN::META->instance(CPAN::Author,$self->{'userid'})->fullname
1642 } else {
1643 return "N/A";
1644 }
1645}
1646
1647*name = \&cpan_file;
1648
1649sub cpan_version { shift->{'CPAN_VERSION'} }
1650
1651sub force {
1652 my($self) = @_;
1653 $self->{'force_update'}++;
1654}
1655
1656sub rematein {
1657 my($self,$meth) = @_;
1658 $self->debug($self->id) if $CPAN::DEBUG;
1659 my $cpan_file = $self->cpan_file;
1660 return if $cpan_file eq "N/A";
1661 return if $cpan_file =~ /^Contact Author/;
1662 my $pack = $CPAN::META->instance('CPAN::Distribution',$cpan_file);
1663 $pack->called_for($self->id);
1664 $pack->force if exists $self->{'force_update'};
1665 $pack->$meth();
1666 delete $self->{'force_update'};
1667}
1668
1669sub readme { shift->rematein('readme') }
1670sub make { shift->rematein('make') }
1671sub clean { shift->rematein('clean') }
1672sub test { shift->rematein('test') }
1673sub install {
1674 my($self) = @_;
1675 my($doit) = 0;
1676 my($latest) = $self->cpan_version;
1677 $latest ||= 0;
1678 my($inst_file) = $self->inst_file;
1679 my($have) = 0;
1680 if (defined $inst_file) {
1681 $have = $self->inst_version;
1682 }
1683 if ($inst_file && $have >= $latest && not exists $self->{'force_update'}) {
1684 print $self->id, " is up to date.\n";
1685 } else {
1686 $doit = 1;
1687 }
1688 $self->rematein('install') if $doit;
1689}
1690
1691sub inst_file {
1692 my($self) = @_;
1693 my($dir,@packpath);
1694 @packpath = split /::/, $self->{ID};
1695 $packpath[-1] .= ".pm";
1696 foreach $dir (@INC) {
1697 my $pmfile = CPAN->catfile($dir,@packpath);
1698 if (-f $pmfile){
1699 return $pmfile;
1700 }
1701 }
1702}
1703
1704sub xs_file {
1705 my($self) = @_;
1706 my($dir,@packpath);
1707 @packpath = split /::/, $self->{ID};
1708 push @packpath, $packpath[-1];
1709 $packpath[-1] .= "." . $Config::Config{'dlext'};
1710 foreach $dir (@INC) {
1711 my $xsfile = CPAN->catfile($dir,'auto',@packpath);
1712 if (-f $xsfile){
1713 return $xsfile;
1714 }
1715 }
1716}
1717
1718sub inst_version {
1719 my($self) = @_;
1720 my $parsefile = $self->inst_file or return 0;
1721 my $have = MY->parse_version($parsefile);
1722 $have ||= 0;
1723 $have =~ s/\s+//g;
1724 $have ||= 0;
1725 $have;
1726}
1727
1728package CPAN::CacheMgr;
1729use vars qw($Du @ISA);
1730@ISA=qw(CPAN::Debug CPAN::InfoObj);
1731use File::Find;
1732
1733sub as_string {
1734 eval { require Data::Dumper };
1735 if ($@) {
1736 return shift->SUPER::as_string;
1737 } else {
1738 return Data::Dumper::Dumper(shift);
1739 }
1740}
1741
1742sub cachesize {
1743 shift->{DU};
1744}
1745
1746# sub check {
1747# my($self,@dirs) = @_;
1748# return unless -d $self->{ID};
1749# my $dir;
1750# @dirs = $self->dirs unless @dirs;
1751# for $dir (@dirs) {
1752# $self->disk_usage($dir);
1753# }
1754# }
1755
1756sub clean_cache {
1757 my $self = shift;
1758 my $dir;
1759 while ($self->{DU} > $self->{'MAX'} and $dir = shift @{$self->{FIFO}}) {
1760 $self->force_clean_cache($dir);
1761 }
1762 $self->debug("leaving clean_cache with $self->{DU}") if $CPAN::DEBUG;
1763}
1764
1765sub dir {
1766 shift->{ID};
1767}
1768
1769sub entries {
1770 my($self,$dir) = @_;
1771 $dir ||= $self->{ID};
1772 my($cwd) = Cwd::cwd();
1773 chdir $dir or Carp::croak("Can't chdir to $dir: $!");
1774 my $dh = DirHandle->new(".") or Carp::croak("Couldn't opendir $dir: $!");
1775 my(@entries);
1776 for ($dh->read) {
1777 next if $_ eq "." || $_ eq "..";
1778 if (-f $_) {
1779 push @entries, $CPAN::META->catfile($dir,$_);
1780 } elsif (-d _) {
1781 push @entries, $CPAN::META->catdir($dir,$_);
1782 } else {
1783 print STDERR "Warning: weird direntry in $dir: $_\n";
1784 }
1785 }
1786 chdir $cwd or Carp::croak("Can't chdir to $cwd: $!");
1787 sort {-M $b <=> -M $a} @entries;
1788}
1789
1790sub disk_usage {
1791 my($self,$dir) = @_;
1792 if (! defined $dir or $dir eq "") {
1793 $self->debug("Cannot determine disk usage for some reason") if $CPAN::DEBUG;
1794 return;
1795 }
1796 return if defined $self->{SIZE}{$dir};
1797 local($Du) = 0;
1798 find(
1799 sub {
1800 return if -l $_;
1801 $Du += -s;
1802 },
1803 $dir
1804 );
1805 $self->{SIZE}{$dir} = $Du/1024/1024;
1806 push @{$self->{FIFO}}, $dir;
1807 $self->debug("measured $dir is $Du") if $CPAN::DEBUG;
1808 $self->{DU} += $Du/1024/1024;
1809 if ($self->{DU} > $self->{'MAX'} ) {
1810 printf "...Hold on a sec... CPAN's cleaning the cache: %.2f MB > %.2f MB\n",
1811 $self->{DU}, $self->{'MAX'};
1812 $self->clean_cache;
1813 } else {
1814 $self->debug("NOT have to clean the cache: $self->{DU} <= $self->{'MAX'}") if $CPAN::DEBUG;
1815 $self->debug($self->as_string) if $CPAN::DEBUG;
1816 }
1817 $self->{DU};
1818}
1819
1820sub force_clean_cache {
1821 my($self,$dir) = @_;
1822 $self->debug("have to rmtree $dir, will free $self->{SIZE}{$dir}") if $CPAN::DEBUG;
1823 File::Path::rmtree($dir);
1824 $self->{DU} -= $self->{SIZE}{$dir};
1825 delete $self->{SIZE}{$dir};
1826}
1827
1828sub new {
1829 my $class = shift;
1830 my $self = { ID => $CPAN::Config->{'build_dir'}, MAX => $CPAN::Config->{'build_cache'}, DU => 0 };
1831 File::Path::mkpath($self->{ID});
1832 my $dh = DirHandle->new($self->{ID});
1833 bless $self, $class;
1834 $self->debug("dir [$self->{ID}]") if $CPAN::DEBUG;
1835 my $e;
1836 for $e ($self->entries) {
1837 next if $e eq ".." || $e eq ".";
1838 $self->debug("Have to check size $e") if $CPAN::DEBUG;
1839 $self->disk_usage($e);
1840 }
1841 $self;
1842}
1843
1844package CPAN::Debug;
1845
1846sub debug {
1847 my($self,$arg) = @_;
1848 my($caller,$func,$line,@rest) = caller(1); # caller(0) eg Complete, caller(1) eg readline
1849 ($caller) = caller(0);
1850 $caller =~ s/.*:://;
1851# print "caller[$caller]func[$func]line[$line]rest[@rest]\n";
1852# print "CPAN::DEBUG{caller}[$CPAN::DEBUG{$caller}]CPAN::DEBUG[$CPAN::DEBUG]\n";
1853 if ($CPAN::DEBUG{$caller} & $CPAN::DEBUG){
1854 if (ref $arg) {
1855 eval { require Data::Dumper };
1856 if ($@) {
1857 print $arg->as_string;
1858 } else {
1859 print Data::Dumper::Dumper($arg);
1860 }
1861 } else {
1862 print "Debug($caller:$func,$line,@rest): $arg\n"
1863 }
1864 }
1865}
1866
1867package CPAN::Config;
1868import ExtUtils::MakeMaker 'neatvalue';
1869use vars qw(%can);
1870
1871%can = (
1872 'commit' => "Commit changes to disk",
1873 'defaults' => "Reload defaults from disk",
1874);
1875
1876sub edit {
1877 my($class,@args) = @_;
1878 return unless @args;
1879 CPAN->debug("class[$class]args[@args]");
1880 my($o,$str,$func,$args,$key_exists);
1881 $o = shift @args;
1882 if($can{$o}) {
1883 $class->$o(@args);
1884 return 1;
1885 }
1886 return unless exists $CPAN::Config->{$o};
1887
1888 if (ref($CPAN::Config->{$o}) eq ARRAY) {
1889 if (@args) {
1890 $func = shift @args;
1891 # Let's avoid eval, it's easier to comprehend without.
1892 if ($func eq "push") {
1893 push @{$CPAN::Config->{$o}}, @args;
1894 } elsif ($func eq "pop") {
1895 pop @{$CPAN::Config->{$o}};
1896 } elsif ($func eq "shift") {
1897 shift @{$CPAN::Config->{$o}};
1898 } elsif ($func eq "unshift") {
1899 unshift @{$CPAN::Config->{$o}}, @args;
1900 } elsif ($func eq "splice") {
1901 splice @{$CPAN::Config->{$o}}, @args;
1902 } else {
1903 $CPAN::Config->{$o} = [@args];
1904 }
1905 } else {
1906 print qq{ $o }, neatvalue($CPAN::Config->{$o}), qq{
1907Usage:
1908 o conf $o [shift|pop]
1909or
1910 o conf $o [unshift|push|splice] <list>
1911};
1912 }
1913 } else {
1914 if (@args) {
1915 $CPAN::Config->{$o} = $args[0];
1916 }
1917 print " $o ";
1918 print defined $CPAN::Config->{$o} ? $CPAN::Config->{$o} : "UNDEFINED";
1919 }
1920}
1921
1922sub commit {
1923 my($self, $configpm) = @_;
1924 my $mode;
1925 # mkpath!?
1926
1927 my($fh) = IO::File->new;
1928 $configpm ||= cfile();
1929 if (-f $configpm) {
1930 $mode = (stat $configpm)[2];
1931 if ($mode && ! -w _) {
1932 print "$configpm is not writable\n" and return;
1933 }
1934 #chmod 0644, $configpm; #?
1935 }
1936
1937 my $msg = <<EOF unless $configpm =~ /MyConfig/;
1938
1939# This is CPAN.pm's systemwide configuration file. This file provides
1940# defaults for users, and the values can be changed in a per-user configuration
1941# file. The user-config file is being looked for as ~/.cpan/CPAN/MyConfig.pm.
1942
1943EOF
1944 $msg ||= "\n";
1945 open $fh, ">$configpm" or warn "Couldn't open >$configpm: $!";
1946 print $fh qq[$msg\$CPAN::Config = \{\n];
1947 foreach (sort keys %$CPAN::Config) {
1948 print $fh " '$_' => ", ExtUtils::MakeMaker::neatvalue($CPAN::Config->{$_}), ",\n";
1949 }
1950
1951 print $fh "};\n1;\n__END__\n";
1952 close $fh;
1953
1954 #$mode = 0444 | ( $mode & 0111 ? 0111 : 0 );
1955 #chmod $mode, $configpm;
1956 $self->defaults;
1957 print "commit: wrote $configpm\n";
1958 1;
1959}
1960
1961*default = \&defaults;
1962sub defaults {
1963 my($self) = @_;
1964 $self->unload;
1965 $self->load;
1966 1;
1967}
1968
1969my $dot_cpan;
1970sub load {
1971 my($self) = @_;
1972 eval {require CPAN::Config;}; # We eval, because of some MakeMaker problems
1973 unshift @INC, $CPAN::META->catdir($ENV{HOME},".cpan") unless $dot_cpan++;
1974 eval {require CPAN::MyConfig;}; # where you can override system wide settings
1975 unless ( $self->load_succeeded ) {
1976 require CPAN::FirstTime;
1977 my($configpm,$fh);
1978 if (defined $INC{"CPAN/Config.pm"} && -w $INC{"CPAN/Config.pm"}) {
1979 $configpm = $INC{"CPAN/Config.pm"};
1980 } elsif (defined $INC{"CPAN/MyConfig.pm"} && -w $INC{"CPAN/MyConfig.pm"}) {
1981 $configpm = $INC{"CPAN/MyConfig.pm"};
1982 } else {
1983 my($path_to_cpan) = File::Basename::dirname($INC{"CPAN.pm"});
1984 my($configpmdir) = MY->catdir($path_to_cpan,"CPAN");
1985 my($configpmtest) = MY->catfile($configpmdir,"Config.pm");
1986 if (-d $configpmdir || File::Path::mkpath($configpmdir)) {
1987#_#_# following code dumped core on me with 5.003_11, a.k.
1988#_#_# $fh = IO::File->new;
1989#_#_# if ($fh->open(">$configpmtest")) {
1990#_#_# $fh->print("1;\n");
1991#_#_# $configpm = $configpmtest;
1992#_#_# }
1993 if (-w $configpmtest or -w $configpmdir) {
1994 $configpm = $configpmtest;
1995 }
1996 }
1997 unless ($configpm) {
1998 $configpmdir = MY->catdir($ENV{HOME},".cpan","CPAN");
1999 File::Path::mkpath($configpmdir);
2000 $configpmtest = MY->catfile($configpmdir,"MyConfig.pm");
2001 if (-w $configpmtest or -w $configpmdir) {
2002 $configpm = $configpmtest;
2003 } else {
2004 warn "WARNING: CPAN.pm is unable to create a configuration file.\n";
2005 }
2006 }
2007 }
2008 warn "Calling CPAN::FirstTime::init($configpm)";
2009 CPAN::FirstTime::init($configpm);
2010 }
2011}
2012
2013sub load_succeeded {
2014 my($miss) = 0;
2015 for (qw(
2016 cpan_home keep_source_where build_dir build_cache index_expire
2017 gzip tar unzip make pager makepl_arg make_arg make_install_arg
2018 urllist inhibit_startup_message
2019 )) {
2020 $miss++ unless defined $CPAN::Config->{$_}; # we want them all
2021 }
2022 return !$miss;
2023}
2024
2025sub unload {
2026 delete $INC{'CPAN/MyConfig.pm'};
2027 delete $INC{'CPAN/Config.pm'};
2028}
2029
2030sub cfile {
2031 $INC{'CPAN/MyConfig.pm'} || $INC{'CPAN/Config.pm'};
2032}
2033
2034*h = \&help;
2035sub help {
2036 print <<EOF;
2037Known options:
2038 defaults reload default config values from disk
2039 commit commit session changes to disk
2040
2041You may edit key values in the follow fashion:
2042
2043 o conf build_cache 15
2044
2045 o conf build_dir "/foo/bar"
2046
2047 o conf urllist shift
2048
2049 o conf urllist unshift ftp://ftp.foo.bar/
2050
2051EOF
2052 undef; #don't reprint CPAN::Config
2053}
2054
2055sub complete {
2056 my($word,$line,$pos) = @_;
2057 $word ||= "";
2058 my(@words) = split " ", $line;
2059 my(@o_conf) = (sort keys %CPAN::Config::can, sort keys %$CPAN::Config);
2060 return (@o_conf) unless @words>2;
2061 if($words[2] =~ /->(.*)/) {
2062 my $meth = $1;
2063 my(@methods) = qw(shift unshift push pop splice);
2064 return @methods unless $meth;
2065 return sort grep /^\Q$meth\E/, @methods;
2066 }
2067 return sort grep /^\Q$word\E/, @o_conf;
2068}
2069
20701;
2071
2072=head1 NAME
2073
2074CPAN - query, download and build perl modules from CPAN sites
2075
2076=head1 SYNOPSIS
2077
2078Interactive mode:
2079
2080 perl -MCPAN -e shell;
2081
2082Batch mode:
2083
2084 use CPAN;
2085
2086 autobundle, bundle, clean, expand, install, make, recompile, test
2087
2088=head1 DESCRIPTION
2089
2090The CPAN module is designed to automate the building and installing of
2091perl modules and extensions including the searching and fetching from
2092the net.
2093
2094Modules are fetched from one or more of the mirrored CPAN
2095(Comprehensive Perl Archive Network) sites and unpacked in a dedicated
2096directory.
2097
2098The CPAN module also supports the concept of named and versioned
2099'bundles' of modules. Bundles simplify the handling of sets of
2100related modules. See BUNDLES below.
2101
2102The package contains a session manager and a cache manager. There is
2103no status retained between sessions. The session manager keeps track
2104of what has been fetched, built and installed in the current
2105session. The cache manager keeps track of the disk space occupied by
2106the make processes and deletes excess space in a simple FIFO style.
2107
2108=head2 Interactive Mode
2109
2110The interactive mode is entered by running
2111
2112 perl -MCPAN -e shell
2113
2114which puts you into a readline interface. You will have most fun if
2115you install Term::ReadKey and Term::ReadLine to enjoy both history and
2116completion.
2117
2118Once you are on the command line, type 'h' and the rest should be
2119self-explanatory.
2120
2121=head2 CPAN::Shell
2122
2123The commands that are available in the shell interface are methods in
2124the package CPAN::Shell. If you enter the shell command, all your
2125input is split on whitespace, the first word is being interpreted as
2126the method to be called and the rest of the words are treated as
2127arguments to this method.
2128
2129If you do not enter the shell, most of the available shell commands
2130are both available as methods (C<CPAN::Shell-E<gt>install(...)>) and as
2131functions in the calling package (C<install(...)>).
2132
2133=head2 Cache Manager
2134
2135Currently the cache manager only keeps track of the build directory
2136($CPAN::Config->{build_dir}). It is a simple FIFO mechanism that
2137deletes complete directories below build_dir as soon as the size of
2138all directories there gets bigger than $CPAN::Config->{build_cache}
2139(in MB). The contents of this cache may be used for later
2140re-installations that you intend to do manually, but will never be
2141trusted by CPAN itself.
2142
2143There is another directory ($CPAN::Config->{keep_source_where}) where
2144the original distribution files are kept. This directory is not
2145covered by the cache manager and must be controlled by the user. If
2146you choose to have the same directory as build_dir and as
2147keep_source_where directory, then your sources will be deleted with
2148the same fifo mechanism.
2149
2150=head2 Bundles
2151
2152A bundle is just a perl module in the namespace Bundle:: that does not
2153define any functions or methods. It usually only contains documentation.
2154
2155It starts like a perl module with a package declaration and a $VERSION
2156variable. After that the pod section looks like any other pod with the
2157only difference, that one pod section exists starting with (verbatim):
2158
2159 =head1 CONTENTS
2160
2161In this pod section each line obeys the format
2162
2163 Module_Name [Version_String] [- optional text]
2164
2165The only required part is the first field, the name of a module
2166(eg. Foo::Bar, ie. I<not> the name of the distribution file). The rest
2167of the line is optional. The comment part is delimited by a dash just
2168as in the man page header.
2169
2170The distribution of a bundle should follow the same convention as
2171other distributions. The bundle() function in the CPAN module simply
2172parses the module that defines the bundle and returns the module names
2173that are listed in the described CONTENTS section.
2174
2175Bundles are treated specially in the CPAN package. If you say 'install
2176Bundle::Tkkit' (assuming such a bundle exists), CPAN will install all
2177the modules in the CONTENTS section of the pod. You can install your
2178own Bundles locally by placing a conformant Bundle file somewhere into
2179your @INC path. The autobundle() command which is available in the
2180shell interface does that for you by including all currently installed
2181modules in a snapshot bundle file.
2182
2183=head2 autobundle
2184
2185autobundle() writes a bundle file into the directory
2186$CPAN::Config->{cpan_home}/Bundle directory. The file contains a list
2187of all modules that are both available from CPAN and currently
2188installed within @INC. The name of the bundle file is based on the
2189current date and a counter.
2190
2191=head2 Pragma: force
2192
2193Normally CPAN keeps track of what it has done within the current
2194session and doesn't try to build a package a second time regardless if
2195it succeeded or not. The force command takes as first argument the
2196method to invoke (currently: make, test, or install) and executes the
2197command from scratch.
2198
2199Example:
2200
2201 cpan> install OpenGL
2202 OpenGL is up to date.
2203 cpan> force install OpenGL
2204 Running make
2205 OpenGL-0.4/
2206 OpenGL-0.4/COPYRIGHT
2207 [...]
2208
2209=head2 recompile
2210
2211recompile() is a very special command in that it takes no argument and
2212runs the make/test/install cycle with brute force over all installed
2213dynamically loadable extensions (aka XS modules) with 'force' in
2214effect. Primary purpose of this command is to act as a rescue in case
2215your perl breaks binary compatibility. If one of the modules that CPAN
2216uses is in turn depending on binary compatibility (so you cannot run
2217CPAN commands), then you should try the CPAN::Nox module for recovery.
2218
2219=head1 CONFIGURATION
2220
2221When the CPAN module is installed a site wide configuration file is
2222created as CPAN/Config.pm. The default values defined there can be
2223overridden in another configuration file: CPAN/MyConfig.pm. You can
2224store this file in $HOME/.cpan/CPAN/MyConfig.pm if you want, because
2225$HOME/.cpan is added to the search path of the CPAN module before the
2226use() or require() statements.
2227
2228Currently the following keys in the hash reference $CPAN::Config are
2229defined:
2230
2231 build_cache size of cache for directories to build modules
2232 build_dir locally accessible directory to build modules
2233 index_expire after how many days refetch index files
2234 cpan_home local directory reserved for this package
2235 gzip location of external program gzip
2236 inhibit_startup_message
2237 if true, does not print the startup message
2238 keep_source keep the source in a local directory?
2239 keep_source_where where keep the source (if we do)
2240 make location of external program make
2241 make_arg arguments that should always be passed to 'make'
2242 make_install_arg same as make_arg for 'make install'
2243 makepl_arg arguments passed to 'perl Makefile.PL'
2244 pager location of external program more (or any pager)
2245 tar location of external program tar
2246 unzip location of external program unzip
2247 urllist arrayref to nearby CPAN sites (or equivalent locations)
2248
2249You can set and query each of these options interactively in the cpan
2250shell with the command set defined within the C<o conf> command:
2251
2252=over 2
2253
2254=item o conf E<lt>scalar optionE<gt>
2255
2256prints the current value of the I<scalar option>
2257
2258=item o conf E<lt>scalar optionE<gt> E<lt>valueE<gt>
2259
2260Sets the value of the I<scalar option> to I<value>
2261
2262=item o conf E<lt>list optionE<gt>
2263
2264prints the current value of the I<list option> in MakeMaker's
2265neatvalue format.
2266
2267=item o conf E<lt>list optionE<gt> [shift|pop]
2268
2269shifts or pops the array in the I<list option> variable
2270
2271=item o conf E<lt>list optionE<gt> [unshift|push|splice] E<lt>listE<gt>
2272
2273works like the corresponding perl commands. Whitespace is used to
2274determine the arguments.
2275
2276=back
2277
2278=head1 SECURITY
2279
2280There's no strong security layer in CPAN.pm. CPAN.pm helps you to
2281install foreign, unmasked, unsigned code on your machine. We compare
2282to a checksum that comes from the net just as the distribution file
2283itself. If somebody has managed to tamper with the distribution file,
2284they may have as well tampered with the CHECKSUMS file. Future
2285development will go towards stong authentification.
2286
2287=head1 EXPORT
2288
2289Most functions in package CPAN are exported per default. The reason
2290for this is that the primary use is intended for the cpan shell or for
2291oneliners.
2292
2293=head1 Debugging
2294
2295The debugging of this module is pretty difficult, because we have
2296interferences of the software producing the indices on CPAN, of the
2297mirroring process on CPAN, of packaging, of configuration, of
2298synchronicity, and of bugs within CPAN.pm.
2299
2300In interactive mode you can try "o debug" which will list options for
2301debugging the various parts of the package. The output may not be very
2302useful for you as it's just a byproduct of my own testing, but if you
2303have an idea which part of the package may have a bug, it's sometimes
2304worth to give it a try and send me more specific output. You should
2305know that "o debug" has built-in completion support.
2306
2307=head2 Prerequisites
2308
2309If you have a local mirror of CPAN and can access all files with
2310"file:" URLs, then you only need perl5.003 to run this
2311module. Otherwise you need Net::FTP intalled. LWP may be required for
2312non-UNIX systems or if your nearest CPAN site is associated with an
2313URL that is not C<ftp:>.
2314
2315This module presumes that all packages on CPAN
2316
2317=over 2
2318
2319=item *
2320
2321declare their $VERSION variable in an easy to parse manner. This
2322prerequisite can hardly be relaxed because it consumes by far too much
2323memory to load all packages into the running program just to determine
2324the $VERSION variable . Currently all programs that are dealing with
2325VERSION use something like this
2326
2327 perl -MExtUtils::MakeMaker -le \
2328 'print MM->parse_version($ARGV[0])' filename
2329
2330If you are author of a package and wonder if your VERSION can be
2331parsed, please try the above method.
2332
2333=item *
2334
2335come as compressed or gzipped tarfiles or as zip files and contain a
2336Makefile.PL (well we try to handle a bit more, but without much
2337enthusiasm).
2338
2339=back
2340
2341=head1 AUTHOR
2342
2343Andreas K├Ânig E<lt>a.koenig@mind.deE<gt>
2344
2345=head1 SEE ALSO
2346
2347perl(1), CPAN::Nox(3)
2348
2349=cut
2350