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