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