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