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