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