Commit | Line | Data |
---|---|---|
5f05dabc | 1 | package CPAN; |
36263cb3 GS |
2 | use vars qw{$Try_autoload |
3 | $Revision | |
c356248b A |
4 | $META $Signal $Cwd $End |
5 | $Suppress_readline %Dontload | |
09d9d230 | 6 | $Frontend $Defaultsite |
36263cb3 | 7 | }; #}; |
5f05dabc | 8 | |
36263cb3 | 9 | $VERSION = '1.50'; |
5f05dabc | 10 | |
36263cb3 | 11 | # $Id: CPAN.pm,v 1.264 1999/05/23 14:26:49 k Exp $ |
5f05dabc | 12 | |
c356248b A |
13 | # only used during development: |
14 | $Revision = ""; | |
36263cb3 | 15 | # $Revision = "[".substr(q$Revision: 1.264 $, 10)."]"; |
5f05dabc | 16 | |
17 | use Carp (); | |
18 | use Config (); | |
19 | use Cwd (); | |
20 | use DirHandle; | |
21 | use Exporter (); | |
2e2b7522 | 22 | use ExtUtils::MakeMaker (); # $SelfLoader::DEBUG=1; |
5f05dabc | 23 | use File::Basename (); |
10b2abe6 | 24 | use File::Copy (); |
5f05dabc | 25 | use File::Find; |
26 | use File::Path (); | |
da199366 | 27 | use FileHandle (); |
5f05dabc | 28 | use Safe (); |
10b2abe6 | 29 | use Text::ParseWords (); |
05454584 | 30 | use Text::Wrap; |
f14b5cec | 31 | use File::Spec; |
5f05dabc | 32 | |
5f05dabc | 33 | END { $End++; &cleanup; } |
34 | ||
2e2b7522 | 35 | %CPAN::DEBUG = qw[ |
5f05dabc | 36 | CPAN 1 |
37 | Index 2 | |
38 | InfoObj 4 | |
39 | Author 8 | |
40 | Distribution 16 | |
41 | Bundle 32 | |
42 | Module 64 | |
43 | CacheMgr 128 | |
44 | Complete 256 | |
45 | FTP 512 | |
46 | Shell 1024 | |
47 | Eval 2048 | |
48 | Config 4096 | |
09d9d230 | 49 | Tarzip 8192 |
2e2b7522 | 50 | ]; |
5f05dabc | 51 | |
52 | $CPAN::DEBUG ||= 0; | |
da199366 | 53 | $CPAN::Signal ||= 0; |
c356248b | 54 | $CPAN::Frontend ||= "CPAN::Shell"; |
09d9d230 | 55 | $CPAN::Defaultsite ||= "ftp://ftp.perl.org/pub/CPAN"; |
5f05dabc | 56 | |
57 | package CPAN; | |
05454584 | 58 | use vars qw($VERSION @EXPORT $AUTOLOAD $DEBUG $META $term); |
5f05dabc | 59 | use strict qw(vars); |
60 | ||
2e2b7522 | 61 | @CPAN::ISA = qw(CPAN::Debug Exporter); |
5f05dabc | 62 | |
55e314ee | 63 | @EXPORT = qw( |
da199366 A |
64 | autobundle bundle expand force get |
65 | install make readme recompile shell test clean | |
66 | ); | |
5f05dabc | 67 | |
55e314ee A |
68 | #-> sub CPAN::AUTOLOAD ; |
69 | sub AUTOLOAD { | |
70 | my($l) = $AUTOLOAD; | |
71 | $l =~ s/.*:://; | |
72 | my(%EXPORT); | |
73 | @EXPORT{@EXPORT} = ''; | |
36263cb3 | 74 | CPAN::Config->load unless $CPAN::Config_loaded++; |
55e314ee A |
75 | if (exists $EXPORT{$l}){ |
76 | CPAN::Shell->$l(@_); | |
77 | } else { | |
78 | my $ok = CPAN::Shell->try_dot_al($AUTOLOAD); | |
79 | if ($ok) { | |
80 | goto &$AUTOLOAD; | |
c356248b A |
81 | # } else { |
82 | # $CPAN::Frontend->mywarn("Could not autoload $AUTOLOAD"); | |
55e314ee | 83 | } |
c356248b A |
84 | $CPAN::Frontend->mywarn(qq{Unknown command "$AUTOLOAD". }. |
85 | qq{Type ? for help. | |
86 | }); | |
55e314ee A |
87 | } |
88 | } | |
89 | ||
90 | #-> sub CPAN::shell ; | |
91 | sub shell { | |
36263cb3 | 92 | my($self) = @_; |
55e314ee | 93 | $Suppress_readline ||= ! -t STDIN; |
36263cb3 | 94 | CPAN::Config->load unless $CPAN::Config_loaded++; |
55e314ee A |
95 | |
96 | my $prompt = "cpan> "; | |
97 | local($^W) = 1; | |
98 | unless ($Suppress_readline) { | |
99 | require Term::ReadLine; | |
100 | # import Term::ReadLine; | |
101 | $term = Term::ReadLine->new('CPAN Monitor'); | |
36263cb3 GS |
102 | if ($term->ReadLine eq "Term::ReadLine::Gnu") { |
103 | my $attribs = $term->Attribs; | |
104 | # $attribs->{completion_entry_function} = | |
105 | # $attribs->{'list_completion_function'}; | |
106 | $attribs->{attempted_completion_function} = sub { | |
107 | &CPAN::Complete::gnu_cpl; | |
108 | } | |
109 | # $attribs->{completion_word} = | |
110 | # [qw(help me somebody to find out how | |
111 | # to use completion with GNU)]; | |
112 | } else { | |
113 | $readline::rl_completion_function = | |
114 | $readline::rl_completion_function = 'CPAN::Complete::cpl'; | |
115 | } | |
55e314ee A |
116 | } |
117 | ||
118 | no strict; | |
119 | $META->checklock(); | |
120 | my $getcwd; | |
121 | $getcwd = $CPAN::Config->{'getcwd'} || 'cwd'; | |
122 | my $cwd = CPAN->$getcwd(); | |
36263cb3 | 123 | my $try_detect_readline = $term->ReadLine eq "Term::ReadLine::Stub"; |
55e314ee A |
124 | my $rl_avail = $Suppress_readline ? "suppressed" : |
125 | ($term->ReadLine ne "Term::ReadLine::Stub") ? "enabled" : | |
126 | "available (try ``install Bundle::CPAN'')"; | |
127 | ||
c356248b A |
128 | $CPAN::Frontend->myprint( |
129 | qq{ | |
130 | cpan shell -- CPAN exploration and modules installation (v$CPAN::VERSION$CPAN::Revision) | |
131 | ReadLine support $rl_avail | |
55e314ee | 132 | |
c356248b A |
133 | }) unless $CPAN::Config->{'inhibit_startup_message'} ; |
134 | my($continuation) = ""; | |
55e314ee A |
135 | while () { |
136 | if ($Suppress_readline) { | |
137 | print $prompt; | |
138 | last unless defined ($_ = <> ); | |
139 | chomp; | |
140 | } else { | |
141 | last unless defined ($_ = $term->readline($prompt)); | |
142 | } | |
c356248b | 143 | $_ = "$continuation$_" if $continuation; |
55e314ee A |
144 | s/^\s+//; |
145 | next if /^$/; | |
2e2b7522 | 146 | $_ = 'h' if /^\s*\?/; |
09d9d230 | 147 | if (/^(?:q(?:uit)?|bye|exit)$/i) { |
c356248b A |
148 | last; |
149 | } elsif (s/\\$//s) { | |
150 | chomp; | |
151 | $continuation = $_; | |
152 | $prompt = " > "; | |
153 | } elsif (/^\!/) { | |
55e314ee A |
154 | s/^\!//; |
155 | my($eval) = $_; | |
156 | package CPAN::Eval; | |
157 | use vars qw($import_done); | |
158 | CPAN->import(':DEFAULT') unless $import_done++; | |
159 | CPAN->debug("eval[$eval]") if $CPAN::DEBUG; | |
160 | eval($eval); | |
161 | warn $@ if $@; | |
c356248b A |
162 | $continuation = ""; |
163 | $prompt = "cpan> "; | |
55e314ee A |
164 | } elsif (/./) { |
165 | my(@line); | |
166 | if ($] < 5.00322) { # parsewords had a bug until recently | |
167 | @line = split; | |
168 | } else { | |
169 | eval { @line = Text::ParseWords::shellwords($_) }; | |
170 | warn($@), next if $@; | |
171 | } | |
172 | $CPAN::META->debug("line[".join("|",@line)."]") if $CPAN::DEBUG; | |
173 | my $command = shift @line; | |
174 | eval { CPAN::Shell->$command(@line) }; | |
175 | warn $@ if $@; | |
c356248b A |
176 | chdir $cwd; |
177 | $CPAN::Frontend->myprint("\n"); | |
178 | $continuation = ""; | |
179 | $prompt = "cpan> "; | |
55e314ee A |
180 | } |
181 | } continue { | |
09d9d230 | 182 | $Signal=0; |
36263cb3 GS |
183 | CPAN::Queue->nullify_queue; |
184 | if ($try_detect_readline) { | |
185 | if ($CPAN::META->has_inst("Term::ReadLine::Gnu") | |
186 | || | |
187 | $CPAN::META->has_inst("Term::ReadLine::Perl") | |
188 | ) { | |
189 | delete $INC{"Term/ReadLine.pm"}; | |
190 | my $redef; | |
191 | local($SIG{__WARN__}) = CPAN::Shell::dotdot_onreload(\$redef); | |
192 | require Term::ReadLine; | |
193 | $CPAN::Frontend->myprint("\n$redef subroutines in Term::ReadLine redefined\n"); | |
194 | goto &shell; | |
195 | } | |
196 | } | |
55e314ee A |
197 | } |
198 | } | |
199 | ||
200 | package CPAN::CacheMgr; | |
c356248b | 201 | @CPAN::CacheMgr::ISA = qw(CPAN::InfoObj CPAN); |
55e314ee A |
202 | use File::Find; |
203 | ||
204 | package CPAN::Config; | |
205 | import ExtUtils::MakeMaker 'neatvalue'; | |
206 | use vars qw(%can $dot_cpan); | |
207 | ||
208 | %can = ( | |
209 | 'commit' => "Commit changes to disk", | |
210 | 'defaults' => "Reload defaults from disk", | |
211 | 'init' => "Interactive setting of all options", | |
212 | ); | |
213 | ||
214 | package CPAN::FTP; | |
c356248b | 215 | use vars qw($Ua $Thesite $Themethod); |
55e314ee A |
216 | @CPAN::FTP::ISA = qw(CPAN::Debug); |
217 | ||
218 | package CPAN::Complete; | |
219 | @CPAN::Complete::ISA = qw(CPAN::Debug); | |
220 | ||
221 | package CPAN::Index; | |
222 | use vars qw($last_time $date_of_03); | |
223 | @CPAN::Index::ISA = qw(CPAN::Debug); | |
224 | $last_time ||= 0; | |
225 | $date_of_03 ||= 0; | |
226 | ||
227 | package CPAN::InfoObj; | |
228 | @CPAN::InfoObj::ISA = qw(CPAN::Debug); | |
229 | ||
230 | package CPAN::Author; | |
231 | @CPAN::Author::ISA = qw(CPAN::InfoObj); | |
232 | ||
233 | package CPAN::Distribution; | |
234 | @CPAN::Distribution::ISA = qw(CPAN::InfoObj); | |
235 | ||
236 | package CPAN::Bundle; | |
237 | @CPAN::Bundle::ISA = qw(CPAN::Module); | |
238 | ||
239 | package CPAN::Module; | |
240 | @CPAN::Module::ISA = qw(CPAN::InfoObj); | |
10b2abe6 | 241 | |
55e314ee A |
242 | package CPAN::Shell; |
243 | use vars qw($AUTOLOAD $redef @ISA); | |
244 | @CPAN::Shell::ISA = qw(CPAN::Debug); | |
245 | ||
246 | #-> sub CPAN::Shell::AUTOLOAD ; | |
247 | sub AUTOLOAD { | |
248 | my($autoload) = $AUTOLOAD; | |
c356248b | 249 | my $class = shift(@_); |
09d9d230 | 250 | # warn "autoload[$autoload] class[$class]"; |
55e314ee A |
251 | $autoload =~ s/.*:://; |
252 | if ($autoload =~ /^w/) { | |
253 | if ($CPAN::META->has_inst('CPAN::WAIT')) { | |
c356248b | 254 | CPAN::WAIT->$autoload(@_); |
55e314ee | 255 | } else { |
c356248b | 256 | $CPAN::Frontend->mywarn(qq{ |
55e314ee A |
257 | Commands starting with "w" require CPAN::WAIT to be installed. |
258 | Please consider installing CPAN::WAIT to use the fulltext index. | |
f610777f | 259 | For this you just need to type |
55e314ee | 260 | install CPAN::WAIT |
c356248b | 261 | }); |
55e314ee A |
262 | } |
263 | } else { | |
264 | my $ok = CPAN::Shell->try_dot_al($AUTOLOAD); | |
265 | if ($ok) { | |
266 | goto &$AUTOLOAD; | |
c356248b A |
267 | # } else { |
268 | # $CPAN::Frontend->mywarn("Could not autoload $autoload"); | |
55e314ee | 269 | } |
c356248b A |
270 | $CPAN::Frontend->mywarn(qq{Unknown command '$autoload'. }. |
271 | qq{Type ? for help. | |
272 | }); | |
55e314ee A |
273 | } |
274 | } | |
275 | ||
276 | #-> CPAN::Shell::try_dot_al | |
277 | sub try_dot_al { | |
278 | my($class,$autoload) = @_; | |
279 | return unless $CPAN::Try_autoload; | |
280 | # I don't see how to re-use that from the AutoLoader... | |
281 | my($name,$ok); | |
282 | # Braces used to preserve $1 et al. | |
283 | { | |
284 | my ($pkg,$func) = $autoload =~ /(.*)::([^:]+)$/; | |
285 | $pkg =~ s|::|/|g; | |
286 | if (defined($name=$INC{"$pkg.pm"})) | |
287 | { | |
288 | $name =~ s|^(.*)$pkg\.pm$|$1auto/$pkg/$func.al|; | |
f610777f | 289 | $name = undef unless (-r $name); |
55e314ee A |
290 | } |
291 | unless (defined $name) | |
292 | { | |
293 | $name = "auto/$autoload.al"; | |
294 | $name =~ s|::|/|g; | |
295 | } | |
296 | } | |
297 | my $save = $@; | |
298 | eval {local $SIG{__DIE__};require $name}; | |
299 | if ($@) { | |
300 | if (substr($autoload,-9) eq '::DESTROY') { | |
301 | *$autoload = sub {}; | |
302 | $ok = 1; | |
303 | } else { | |
f610777f | 304 | if ($name =~ s{(\w{12,})\.al$}{substr($1,0,11).".al"}e){ |
55e314ee A |
305 | eval {local $SIG{__DIE__};require $name}; |
306 | } | |
307 | if ($@){ | |
308 | $@ =~ s/ at .*\n//; | |
309 | Carp::croak $@; | |
310 | } else { | |
311 | $ok = 1; | |
312 | } | |
313 | } | |
314 | } else { | |
2e2b7522 | 315 | |
36263cb3 | 316 | $ok = 1; |
2e2b7522 | 317 | |
55e314ee A |
318 | } |
319 | $@ = $save; | |
c356248b | 320 | # my $lm = Carp::longmess(); |
55e314ee A |
321 | # warn "ok[$ok] autoload[$autoload] longmess[$lm]"; # debug |
322 | return $ok; | |
323 | } | |
324 | ||
55e314ee A |
325 | #### autoloader is experimental |
326 | #### to try it we have to set $Try_autoload and uncomment | |
327 | #### the use statement and uncomment the __END__ below | |
328 | #### You also need AutoSplit 1.01 available. MakeMaker will | |
329 | #### then build CPAN with all the AutoLoad stuff. | |
330 | # use AutoLoader; | |
331 | # $Try_autoload = 1; | |
332 | ||
333 | if ($CPAN::Try_autoload) { | |
36263cb3 | 334 | my $p; |
c356248b | 335 | for $p (qw( |
55e314ee A |
336 | CPAN::Author CPAN::Bundle CPAN::CacheMgr CPAN::Complete |
337 | CPAN::Config CPAN::Debug CPAN::Distribution CPAN::FTP | |
338 | CPAN::FTP::netrc CPAN::Index CPAN::InfoObj CPAN::Module | |
339 | )) { | |
340 | *{"$p\::AUTOLOAD"} = \&AutoLoader::AUTOLOAD; | |
341 | } | |
342 | } | |
343 | ||
09d9d230 A |
344 | package CPAN::Tarzip; |
345 | use vars qw($AUTOLOAD @ISA); | |
346 | @CPAN::Tarzip::ISA = qw(CPAN::Debug); | |
347 | ||
348 | package CPAN::Queue; | |
f610777f | 349 | |
f14b5cec JH |
350 | # One use of the queue is to determine if we should or shouldn't |
351 | # announce the availability of a new CPAN module | |
352 | ||
353 | # Now we try to use it for dependency tracking. For that to happen | |
f610777f A |
354 | # we need to draw a dependency tree and do the leaves first. This can |
355 | # easily be reached by running CPAN.pm recursively, but we don't want | |
356 | # to waste memory and run into deep recursion. So what we can do is | |
f14b5cec JH |
357 | # this: |
358 | ||
359 | # CPAN::Queue is the package where the queue is maintained. Dependencies | |
360 | # often have high priority and must be brought to the head of the queue, | |
361 | # possibly by jumping the queue if they are already there. My first code | |
362 | # attempt tried to be extremely correct. Whenever a module needed | |
363 | # immediate treatment, I either unshifted it to the front of the queue, | |
364 | # or, if it was already in the queue, I spliced and let it bypass the | |
365 | # others. This became a too correct model that made it impossible to put | |
366 | # an item more than once into the queue. Why would you need that? Well, | |
367 | # you need temporary duplicates as the manager of the queue is a loop | |
368 | # that | |
369 | # | |
370 | # (1) looks at the first item in the queue without shifting it off | |
371 | # | |
372 | # (2) cares for the item | |
373 | # | |
374 | # (3) removes the item from the queue, *even if its agenda failed and | |
375 | # even if the item isn't the first in the queue anymore* (that way | |
376 | # protecting against never ending queues) | |
377 | # | |
378 | # So if an item has prerequisites, the installation fails now, but we | |
379 | # want to retry later. That's easy if we have it twice in the queue. | |
380 | # | |
381 | # I also expect insane dependency situations where an item gets more | |
382 | # than two lives in the queue. Simplest example is triggered by 'install | |
383 | # Foo Foo Foo'. People make this kind of mistakes and I don't want to | |
384 | # get in the way. I wanted the queue manager to be a dumb servant, not | |
385 | # one that knows everything. | |
386 | # | |
387 | # Who would I tell in this model that the user wants to be asked before | |
388 | # processing? I can't attach that information to the module object, | |
389 | # because not modules are installed but distributions. So I'd have to | |
390 | # tell the distribution object that it should ask the user before | |
391 | # processing. Where would the question be triggered then? Most probably | |
392 | # in CPAN::Distribution::rematein. | |
393 | # Hope that makes sense, my head is a bit off:-) -- AK | |
f610777f A |
394 | |
395 | use vars qw{ @All }; | |
396 | ||
09d9d230 A |
397 | sub new { |
398 | my($class,$mod) = @_; | |
f610777f A |
399 | my $self = bless {mod => $mod}, $class; |
400 | push @All, $self; | |
401 | # my @all = map { $_->{mod} } @All; | |
402 | # warn "Adding Queue object for mod[$mod] all[@all]"; | |
403 | return $self; | |
f610777f A |
404 | } |
405 | ||
406 | sub first { | |
407 | my $obj = $All[0]; | |
408 | $obj->{mod}; | |
409 | } | |
410 | ||
411 | sub delete_first { | |
412 | my($class,$what) = @_; | |
413 | my $i; | |
414 | for my $i (0..$#All) { | |
415 | if ( $All[$i]->{mod} eq $what ) { | |
416 | splice @All, $i, 1; | |
417 | return; | |
418 | } | |
419 | } | |
420 | } | |
421 | ||
422 | sub jumpqueue { | |
423 | my $class = shift; | |
424 | my @what = @_; | |
425 | my $obj; | |
426 | WHAT: for my $what (reverse @what) { | |
427 | my $jumped = 0; | |
428 | for (my $i=0; $i<$#All;$i++) { #prevent deep recursion | |
429 | if ($All[$i]->{mod} eq $what){ | |
430 | $jumped++; | |
431 | if ($jumped > 100) { # one's OK if e.g. just processing now; | |
432 | # more are OK if user typed it several | |
433 | # times | |
434 | $CPAN::Frontend->mywarn( | |
435 | qq{Object [$what] queued more than 100 times, ignoring} | |
436 | ); | |
437 | next WHAT; | |
438 | } | |
439 | } | |
440 | } | |
441 | my $obj = bless { mod => $what }, $class; | |
442 | unshift @All, $obj; | |
443 | } | |
444 | } | |
445 | ||
446 | sub exists { | |
447 | my($self,$what) = @_; | |
448 | my @all = map { $_->{mod} } @All; | |
449 | my $exists = grep { $_->{mod} eq $what } @All; | |
450 | # warn "Checking exists in Queue object for mod[$what] all[@all] exists[$exists]"; | |
451 | $exists; | |
452 | } | |
453 | ||
454 | sub delete { | |
455 | my($self,$mod) = @_; | |
456 | @All = grep { $_->{mod} ne $mod } @All; | |
457 | # my @all = map { $_->{mod} } @All; | |
458 | # warn "Deleting Queue object for mod[$mod] all[@all]"; | |
09d9d230 | 459 | } |
55e314ee | 460 | |
36263cb3 GS |
461 | sub nullify_queue { |
462 | @All = (); | |
463 | } | |
464 | ||
465 | ||
466 | ||
55e314ee A |
467 | package CPAN; |
468 | ||
2e2b7522 | 469 | $META ||= CPAN->new; # In case we re-eval ourselves we need the || |
55e314ee | 470 | |
55e314ee A |
471 | 1; |
472 | ||
473 | # __END__ # uncomment this and AutoSplit version 1.01 will split it | |
10b2abe6 CS |
474 | |
475 | #-> sub CPAN::autobundle ; | |
5f05dabc | 476 | sub autobundle; |
10b2abe6 | 477 | #-> sub CPAN::bundle ; |
5f05dabc | 478 | sub bundle; |
10b2abe6 | 479 | #-> sub CPAN::expand ; |
5f05dabc | 480 | sub expand; |
10b2abe6 | 481 | #-> sub CPAN::force ; |
5f05dabc | 482 | sub force; |
10b2abe6 | 483 | #-> sub CPAN::install ; |
5f05dabc | 484 | sub install; |
10b2abe6 | 485 | #-> sub CPAN::make ; |
5f05dabc | 486 | sub make; |
10b2abe6 | 487 | #-> sub CPAN::clean ; |
5f05dabc | 488 | sub clean; |
10b2abe6 | 489 | #-> sub CPAN::test ; |
5f05dabc | 490 | sub test; |
491 | ||
10b2abe6 | 492 | #-> sub CPAN::all ; |
36263cb3 | 493 | sub all_objects { |
5f05dabc | 494 | my($mgr,$class) = @_; |
36263cb3 | 495 | CPAN::Config->load unless $CPAN::Config_loaded++; |
5f05dabc | 496 | CPAN->debug("mgr[$mgr] class[$class]") if $CPAN::DEBUG; |
497 | CPAN::Index->reload; | |
498 | values %{ $META->{$class} }; | |
499 | } | |
36263cb3 | 500 | *all = \&all_objects; |
5f05dabc | 501 | |
502 | # Called by shell, not in batch mode. Not clean XXX | |
10b2abe6 | 503 | #-> sub CPAN::checklock ; |
5f05dabc | 504 | sub checklock { |
505 | my($self) = @_; | |
c356248b | 506 | my $lockfile = MM->catfile($CPAN::Config->{cpan_home},".lock"); |
5f05dabc | 507 | if (-f $lockfile && -M _ > 0) { |
da199366 | 508 | my $fh = FileHandle->new($lockfile); |
5f05dabc | 509 | my $other = <$fh>; |
510 | $fh->close; | |
511 | if (defined $other && $other) { | |
512 | chomp $other; | |
513 | return if $$==$other; # should never happen | |
c356248b A |
514 | $CPAN::Frontend->mywarn( |
515 | qq{ | |
516 | There seems to be running another CPAN process ($other). Contacting... | |
517 | }); | |
5f05dabc | 518 | if (kill 0, $other) { |
c356248b A |
519 | $CPAN::Frontend->mydie(qq{Other job is running. |
520 | You may want to kill it and delete the lockfile, maybe. On UNIX try: | |
521 | kill $other | |
522 | rm $lockfile | |
523 | }); | |
5f05dabc | 524 | } elsif (-w $lockfile) { |
e50380aa | 525 | my($ans) = |
5f05dabc | 526 | ExtUtils::MakeMaker::prompt |
05454584 A |
527 | (qq{Other job not responding. Shall I overwrite }. |
528 | qq{the lockfile? (Y/N)},"y"); | |
c356248b A |
529 | $CPAN::Frontend->myexit("Ok, bye\n") |
530 | unless $ans =~ /^y/i; | |
5f05dabc | 531 | } else { |
532 | Carp::croak( | |
05454584 A |
533 | qq{Lockfile $lockfile not writeable by you. }. |
534 | qq{Cannot proceed.\n}. | |
5f05dabc | 535 | qq{ On UNIX try:\n}. |
536 | qq{ rm $lockfile\n}. | |
537 | qq{ and then rerun us.\n} | |
538 | ); | |
539 | } | |
540 | } | |
541 | } | |
36263cb3 GS |
542 | my $dotcpan = $CPAN::Config->{cpan_home}; |
543 | eval { File::Path::mkpath($dotcpan);}; | |
544 | if ($@) { | |
545 | # A special case at least for Jarkko. | |
546 | my $firsterror = $@; | |
547 | my $seconderror; | |
548 | my $symlinkcpan; | |
549 | if (-l $dotcpan) { | |
550 | $symlinkcpan = readlink $dotcpan; | |
551 | die "readlink $dotcpan failed: $!" unless defined $symlinkcpan; | |
552 | eval { File::Path::mkpath($symlinkcpan); }; | |
553 | if ($@) { | |
554 | $seconderror = $@; | |
555 | } else { | |
556 | $CPAN::Frontend->mywarn(qq{ | |
557 | Working directory $symlinkcpan created. | |
558 | }); | |
559 | } | |
560 | } | |
561 | unless (-d $dotcpan) { | |
562 | my $diemess = qq{ | |
563 | Your configuration suggests "$dotcpan" as your | |
564 | CPAN.pm working directory. I could not create this directory due | |
565 | to this error: $firsterror\n}; | |
566 | $diemess .= qq{ | |
567 | As "$dotcpan" is a symlink to "$symlinkcpan", | |
568 | I tried to create that, but I failed with this error: $seconderror | |
569 | } if $seconderror; | |
570 | $diemess .= qq{ | |
571 | Please make sure the directory exists and is writable. | |
572 | }; | |
573 | $CPAN::Frontend->mydie($diemess); | |
574 | } | |
575 | } | |
5f05dabc | 576 | my $fh; |
da199366 | 577 | unless ($fh = FileHandle->new(">$lockfile")) { |
265f5c4a | 578 | if ($! =~ /Permission/ || $!{EACCES}) { |
5f05dabc | 579 | my $incc = $INC{'CPAN/Config.pm'}; |
05454584 | 580 | my $myincc = MM->catfile($ENV{HOME},'.cpan','CPAN','MyConfig.pm'); |
c356248b | 581 | $CPAN::Frontend->myprint(qq{ |
5f05dabc | 582 | |
583 | Your configuration suggests that CPAN.pm should use a working | |
584 | directory of | |
585 | $CPAN::Config->{cpan_home} | |
586 | Unfortunately we could not create the lock file | |
587 | $lockfile | |
588 | due to permission problems. | |
589 | ||
590 | Please make sure that the configuration variable | |
591 | \$CPAN::Config->{cpan_home} | |
592 | points to a directory where you can write a .lock file. You can set | |
593 | this variable in either | |
594 | $incc | |
595 | or | |
596 | $myincc | |
597 | ||
c356248b | 598 | }); |
5f05dabc | 599 | } |
c356248b | 600 | $CPAN::Frontend->mydie("Could not open >$lockfile: $!"); |
5f05dabc | 601 | } |
c356248b | 602 | $fh->print($$, "\n"); |
5f05dabc | 603 | $self->{LOCK} = $lockfile; |
604 | $fh->close; | |
c356248b | 605 | $SIG{'TERM'} = sub { |
2e2b7522 GS |
606 | &cleanup; |
607 | $CPAN::Frontend->mydie("Got SIGTERM, leaving"); | |
c356248b | 608 | }; |
da199366 | 609 | $SIG{'INT'} = sub { |
09d9d230 A |
610 | # no blocks!!! |
611 | &cleanup if $Signal; | |
612 | $CPAN::Frontend->mydie("Got another SIGINT") if $Signal; | |
613 | print "Caught SIGINT\n"; | |
614 | $Signal++; | |
da199366 | 615 | }; |
5f05dabc | 616 | $SIG{'__DIE__'} = \&cleanup; |
e50380aa | 617 | $self->debug("Signal handler set.") if $CPAN::DEBUG; |
5f05dabc | 618 | } |
619 | ||
10b2abe6 | 620 | #-> sub CPAN::DESTROY ; |
5f05dabc | 621 | sub DESTROY { |
622 | &cleanup; # need an eval? | |
623 | } | |
624 | ||
55e314ee A |
625 | #-> sub CPAN::cwd ; |
626 | sub cwd {Cwd::cwd();} | |
627 | ||
628 | #-> sub CPAN::getcwd ; | |
629 | sub getcwd {Cwd::getcwd();} | |
630 | ||
10b2abe6 | 631 | #-> sub CPAN::exists ; |
5f05dabc | 632 | sub exists { |
633 | my($mgr,$class,$id) = @_; | |
634 | CPAN::Index->reload; | |
e50380aa | 635 | ### Carp::croak "exists called without class argument" unless $class; |
5f05dabc | 636 | $id ||= ""; |
637 | exists $META->{$class}{$id}; | |
638 | } | |
639 | ||
09d9d230 A |
640 | #-> sub CPAN::delete ; |
641 | sub delete { | |
642 | my($mgr,$class,$id) = @_; | |
643 | delete $META->{$class}{$id}; | |
644 | } | |
645 | ||
55e314ee A |
646 | #-> sub CPAN::has_inst |
647 | sub has_inst { | |
648 | my($self,$mod,$message) = @_; | |
649 | Carp::croak("CPAN->has_inst() called without an argument") | |
650 | unless defined $mod; | |
651 | if (defined $message && $message eq "no") { | |
652 | $Dontload{$mod}||=1; | |
653 | return 0; | |
654 | } elsif (exists $Dontload{$mod}) { | |
655 | return 0; | |
656 | } | |
657 | my $file = $mod; | |
c356248b | 658 | my $obj; |
55e314ee A |
659 | $file =~ s|::|/|g; |
660 | $file =~ s|/|\\|g if $^O eq 'MSWin32'; | |
661 | $file .= ".pm"; | |
c356248b | 662 | if ($INC{$file}) { |
f14b5cec JH |
663 | # checking %INC is wrong, because $INC{LWP} may be true |
664 | # although $INC{"URI/URL.pm"} may have failed. But as | |
665 | # I really want to say "bla loaded OK", I have to somehow | |
666 | # cache results. | |
667 | ### warn "$file in %INC"; #debug | |
55e314ee | 668 | return 1; |
55e314ee | 669 | } elsif (eval { require $file }) { |
c356248b A |
670 | # eval is good: if we haven't yet read the database it's |
671 | # perfect and if we have installed the module in the meantime, | |
672 | # it tries again. The second require is only a NOOP returning | |
673 | # 1 if we had success, otherwise it's retrying | |
f14b5cec | 674 | |
c356248b A |
675 | $CPAN::Frontend->myprint("CPAN: $mod loaded ok\n"); |
676 | if ($mod eq "CPAN::WAIT") { | |
677 | push @CPAN::Shell::ISA, CPAN::WAIT; | |
678 | } | |
55e314ee A |
679 | return 1; |
680 | } elsif ($mod eq "Net::FTP") { | |
681 | warn qq{ | |
682 | Please, install Net::FTP as soon as possible. CPAN.pm installs it for you | |
683 | if you just type | |
684 | install Bundle::libnet | |
5f05dabc | 685 | |
55e314ee A |
686 | }; |
687 | sleep 2; | |
c356248b A |
688 | } elsif ($mod eq "MD5"){ |
689 | $CPAN::Frontend->myprint(qq{ | |
690 | CPAN: MD5 security checks disabled because MD5 not installed. | |
691 | Please consider installing the MD5 module. | |
692 | ||
693 | }); | |
694 | sleep 2; | |
f14b5cec JH |
695 | } else { |
696 | delete $INC{$file}; # if it inc'd LWP but failed during, say, URI | |
05454584 | 697 | } |
55e314ee | 698 | return 0; |
05454584 A |
699 | } |
700 | ||
10b2abe6 | 701 | #-> sub CPAN::instance ; |
5f05dabc | 702 | sub instance { |
703 | my($mgr,$class,$id) = @_; | |
704 | CPAN::Index->reload; | |
5f05dabc | 705 | $id ||= ""; |
706 | $META->{$class}{$id} ||= $class->new(ID => $id ); | |
707 | } | |
708 | ||
10b2abe6 | 709 | #-> sub CPAN::new ; |
5f05dabc | 710 | sub new { |
711 | bless {}, shift; | |
712 | } | |
713 | ||
10b2abe6 | 714 | #-> sub CPAN::cleanup ; |
5f05dabc | 715 | sub cleanup { |
2e2b7522 GS |
716 | # warn "cleanup called with arg[@_] End[$End] Signal[$Signal]"; |
717 | local $SIG{__DIE__} = ''; | |
718 | my($message) = @_; | |
719 | my $i = 0; | |
720 | my $ineval = 0; | |
721 | if ( | |
722 | 0 && # disabled, try reload cpan with it | |
723 | $] > 5.004_60 # thereabouts | |
724 | ) { | |
725 | $ineval = $^S; | |
726 | } else { | |
727 | my($subroutine); | |
728 | while ((undef,undef,undef,$subroutine) = caller(++$i)) { | |
729 | $ineval = 1, last if | |
730 | $subroutine eq '(eval)'; | |
5f05dabc | 731 | } |
2e2b7522 GS |
732 | } |
733 | return if $ineval && !$End; | |
734 | return unless defined $META->{'LOCK'}; | |
735 | return unless -f $META->{'LOCK'}; | |
736 | unlink $META->{'LOCK'}; | |
737 | # require Carp; | |
738 | # Carp::cluck("DEBUGGING"); | |
739 | $CPAN::Frontend->mywarn("Lockfile removed.\n"); | |
5f05dabc | 740 | } |
741 | ||
05454584 | 742 | package CPAN::CacheMgr; |
5f05dabc | 743 | |
05454584 A |
744 | #-> sub CPAN::CacheMgr::as_string ; |
745 | sub as_string { | |
746 | eval { require Data::Dumper }; | |
747 | if ($@) { | |
748 | return shift->SUPER::as_string; | |
5f05dabc | 749 | } else { |
05454584 | 750 | return Data::Dumper::Dumper(shift); |
5f05dabc | 751 | } |
752 | } | |
753 | ||
05454584 A |
754 | #-> sub CPAN::CacheMgr::cachesize ; |
755 | sub cachesize { | |
756 | shift->{DU}; | |
5f05dabc | 757 | } |
5f05dabc | 758 | |
09d9d230 A |
759 | sub tidyup { |
760 | my($self) = @_; | |
761 | return unless -d $self->{ID}; | |
762 | while ($self->{DU} > $self->{'MAX'} ) { | |
763 | my($toremove) = shift @{$self->{FIFO}}; | |
764 | $CPAN::Frontend->myprint(sprintf( | |
765 | "Deleting from cache". | |
766 | ": $toremove (%.1f>%.1f MB)\n", | |
767 | $self->{DU}, $self->{'MAX'}) | |
768 | ); | |
769 | return if $CPAN::Signal; | |
770 | $self->force_clean_cache($toremove); | |
771 | return if $CPAN::Signal; | |
772 | } | |
773 | } | |
5f05dabc | 774 | |
05454584 A |
775 | #-> sub CPAN::CacheMgr::dir ; |
776 | sub dir { | |
777 | shift->{ID}; | |
778 | } | |
779 | ||
780 | #-> sub CPAN::CacheMgr::entries ; | |
781 | sub entries { | |
782 | my($self,$dir) = @_; | |
55e314ee | 783 | return unless defined $dir; |
e50380aa | 784 | $self->debug("reading dir[$dir]") if $CPAN::DEBUG; |
05454584 | 785 | $dir ||= $self->{ID}; |
e50380aa A |
786 | my $getcwd; |
787 | $getcwd = $CPAN::Config->{'getcwd'} || 'cwd'; | |
55e314ee | 788 | my($cwd) = CPAN->$getcwd(); |
05454584 | 789 | chdir $dir or Carp::croak("Can't chdir to $dir: $!"); |
f14b5cec JH |
790 | my $dh = DirHandle->new(File::Spec->curdir) |
791 | or Carp::croak("Couldn't opendir $dir: $!"); | |
05454584 A |
792 | my(@entries); |
793 | for ($dh->read) { | |
794 | next if $_ eq "." || $_ eq ".."; | |
795 | if (-f $_) { | |
c356248b | 796 | push @entries, MM->catfile($dir,$_); |
05454584 | 797 | } elsif (-d _) { |
c356248b | 798 | push @entries, MM->catdir($dir,$_); |
5f05dabc | 799 | } else { |
c356248b | 800 | $CPAN::Frontend->mywarn("Warning: weird direntry in $dir: $_\n"); |
5f05dabc | 801 | } |
5f05dabc | 802 | } |
05454584 | 803 | chdir $cwd or Carp::croak("Can't chdir to $cwd: $!"); |
e50380aa | 804 | sort { -M $b <=> -M $a} @entries; |
5f05dabc | 805 | } |
806 | ||
05454584 A |
807 | #-> sub CPAN::CacheMgr::disk_usage ; |
808 | sub disk_usage { | |
809 | my($self,$dir) = @_; | |
09d9d230 A |
810 | return if exists $self->{SIZE}{$dir}; |
811 | return if $CPAN::Signal; | |
812 | my($Du) = 0; | |
05454584 A |
813 | find( |
814 | sub { | |
f14b5cec JH |
815 | $File::Find::prune++ if $CPAN::Signal; |
816 | return if -l $_; | |
817 | if ($^O eq 'MacOS') { | |
818 | require Mac::Files; | |
819 | my $cat = Mac::Files::FSpGetCatInfo($_); | |
820 | $Du += $cat->ioFlLgLen() + $cat->ioFlRLgLen(); | |
821 | } else { | |
822 | $Du += (-s _); | |
823 | } | |
05454584 A |
824 | }, |
825 | $dir | |
826 | ); | |
09d9d230 | 827 | return if $CPAN::Signal; |
05454584 A |
828 | $self->{SIZE}{$dir} = $Du/1024/1024; |
829 | push @{$self->{FIFO}}, $dir; | |
830 | $self->debug("measured $dir is $Du") if $CPAN::DEBUG; | |
831 | $self->{DU} += $Du/1024/1024; | |
05454584 | 832 | $self->{DU}; |
5f05dabc | 833 | } |
834 | ||
05454584 A |
835 | #-> sub CPAN::CacheMgr::force_clean_cache ; |
836 | sub force_clean_cache { | |
837 | my($self,$dir) = @_; | |
09d9d230 | 838 | return unless -e $dir; |
05454584 A |
839 | $self->debug("have to rmtree $dir, will free $self->{SIZE}{$dir}") |
840 | if $CPAN::DEBUG; | |
841 | File::Path::rmtree($dir); | |
842 | $self->{DU} -= $self->{SIZE}{$dir}; | |
843 | delete $self->{SIZE}{$dir}; | |
5f05dabc | 844 | } |
845 | ||
05454584 A |
846 | #-> sub CPAN::CacheMgr::new ; |
847 | sub new { | |
848 | my $class = shift; | |
e50380aa A |
849 | my $time = time; |
850 | my($debug,$t2); | |
851 | $debug = ""; | |
05454584 A |
852 | my $self = { |
853 | ID => $CPAN::Config->{'build_dir'}, | |
854 | MAX => $CPAN::Config->{'build_cache'}, | |
f610777f | 855 | SCAN => $CPAN::Config->{'scan_cache'} || 'atstart', |
05454584 A |
856 | DU => 0 |
857 | }; | |
858 | File::Path::mkpath($self->{ID}); | |
859 | my $dh = DirHandle->new($self->{ID}); | |
860 | bless $self, $class; | |
f610777f A |
861 | $self->scan_cache; |
862 | $t2 = time; | |
863 | $debug .= "timing of CacheMgr->new: ".($t2 - $time); | |
864 | $time = $t2; | |
865 | CPAN->debug($debug) if $CPAN::DEBUG; | |
866 | $self; | |
867 | } | |
868 | ||
869 | #-> sub CPAN::CacheMgr::scan_cache ; | |
870 | sub scan_cache { | |
871 | my $self = shift; | |
872 | return if $self->{SCAN} eq 'never'; | |
873 | $CPAN::Frontend->mydie("Unknown scan_cache argument: $self->{SCAN}") | |
874 | unless $self->{SCAN} eq 'atstart'; | |
09d9d230 A |
875 | $CPAN::Frontend->myprint( |
876 | sprintf("Scanning cache %s for sizes\n", | |
877 | $self->{ID})); | |
f610777f | 878 | my $e; |
09d9d230 | 879 | for $e ($self->entries($self->{ID})) { |
05454584 | 880 | next if $e eq ".." || $e eq "."; |
05454584 | 881 | $self->disk_usage($e); |
09d9d230 | 882 | return if $CPAN::Signal; |
5f05dabc | 883 | } |
09d9d230 | 884 | $self->tidyup; |
5f05dabc | 885 | } |
886 | ||
05454584 A |
887 | package CPAN::Debug; |
888 | ||
889 | #-> sub CPAN::Debug::debug ; | |
890 | sub debug { | |
891 | my($self,$arg) = @_; | |
892 | my($caller,$func,$line,@rest) = caller(1); # caller(0) eg | |
893 | # Complete, caller(1) | |
894 | # eg readline | |
895 | ($caller) = caller(0); | |
896 | $caller =~ s/.*:://; | |
55e314ee | 897 | $arg = "" unless defined $arg; |
c356248b | 898 | my $rest = join "|", map { defined $_ ? $_ : "UNDEF" } @rest; |
05454584 | 899 | if ($CPAN::DEBUG{$caller} & $CPAN::DEBUG){ |
55e314ee | 900 | if ($arg and ref $arg) { |
05454584 A |
901 | eval { require Data::Dumper }; |
902 | if ($@) { | |
c356248b | 903 | $CPAN::Frontend->myprint($arg->as_string); |
05454584 | 904 | } else { |
c356248b | 905 | $CPAN::Frontend->myprint(Data::Dumper::Dumper($arg)); |
5f05dabc | 906 | } |
907 | } else { | |
c356248b | 908 | $CPAN::Frontend->myprint("Debug($caller:$func,$line,[$rest]): $arg\n"); |
5f05dabc | 909 | } |
05454584 A |
910 | } |
911 | } | |
912 | ||
913 | package CPAN::Config; | |
05454584 A |
914 | |
915 | #-> sub CPAN::Config::edit ; | |
916 | sub edit { | |
917 | my($class,@args) = @_; | |
918 | return unless @args; | |
919 | CPAN->debug("class[$class]args[".join(" | ",@args)."]"); | |
920 | my($o,$str,$func,$args,$key_exists); | |
921 | $o = shift @args; | |
922 | if($can{$o}) { | |
923 | $class->$o(@args); | |
924 | return 1; | |
925 | } else { | |
926 | if (ref($CPAN::Config->{$o}) eq ARRAY) { | |
927 | $func = shift @args; | |
928 | $func ||= ""; | |
929 | # Let's avoid eval, it's easier to comprehend without. | |
930 | if ($func eq "push") { | |
931 | push @{$CPAN::Config->{$o}}, @args; | |
932 | } elsif ($func eq "pop") { | |
933 | pop @{$CPAN::Config->{$o}}; | |
934 | } elsif ($func eq "shift") { | |
935 | shift @{$CPAN::Config->{$o}}; | |
936 | } elsif ($func eq "unshift") { | |
937 | unshift @{$CPAN::Config->{$o}}, @args; | |
938 | } elsif ($func eq "splice") { | |
939 | splice @{$CPAN::Config->{$o}}, @args; | |
940 | } elsif (@args) { | |
941 | $CPAN::Config->{$o} = [@args]; | |
942 | } else { | |
c356248b A |
943 | $CPAN::Frontend->myprint( |
944 | join "", | |
945 | " $o ", | |
946 | ExtUtils::MakeMaker::neatvalue($CPAN::Config->{$o}), | |
947 | "\n" | |
05454584 A |
948 | ); |
949 | } | |
950 | } else { | |
951 | $CPAN::Config->{$o} = $args[0] if defined $args[0]; | |
c356248b A |
952 | $CPAN::Frontend->myprint(" $o " . |
953 | (defined $CPAN::Config->{$o} ? | |
954 | $CPAN::Config->{$o} : "UNDEFINED")); | |
5f05dabc | 955 | } |
5f05dabc | 956 | } |
05454584 A |
957 | } |
958 | ||
959 | #-> sub CPAN::Config::commit ; | |
960 | sub commit { | |
961 | my($self,$configpm) = @_; | |
962 | unless (defined $configpm){ | |
963 | $configpm ||= $INC{"CPAN/MyConfig.pm"}; | |
964 | $configpm ||= $INC{"CPAN/Config.pm"}; | |
2e2b7522 | 965 | $configpm || Carp::confess(q{ |
05454584 A |
966 | CPAN::Config::commit called without an argument. |
967 | Please specify a filename where to save the configuration or try | |
968 | "o conf init" to have an interactive course through configing. | |
969 | }); | |
970 | } | |
971 | my($mode); | |
972 | if (-f $configpm) { | |
973 | $mode = (stat $configpm)[2]; | |
974 | if ($mode && ! -w _) { | |
975 | Carp::confess("$configpm is not writable"); | |
5f05dabc | 976 | } |
977 | } | |
05454584 A |
978 | |
979 | my $msg = <<EOF unless $configpm =~ /MyConfig/; | |
980 | ||
09d9d230 | 981 | # This is CPAN.pm's systemwide configuration file. This file provides |
55e314ee A |
982 | # defaults for users, and the values can be changed in a per-user |
983 | # configuration file. The user-config file is being looked for as | |
984 | # ~/.cpan/CPAN/MyConfig.pm. | |
05454584 A |
985 | |
986 | EOF | |
987 | $msg ||= "\n"; | |
988 | my($fh) = FileHandle->new; | |
f610777f | 989 | rename $configpm, "$configpm~" if -f $configpm; |
05454584 | 990 | open $fh, ">$configpm" or warn "Couldn't open >$configpm: $!"; |
c356248b | 991 | $fh->print(qq[$msg\$CPAN::Config = \{\n]); |
05454584 A |
992 | foreach (sort keys %$CPAN::Config) { |
993 | $fh->print( | |
994 | " '$_' => ", | |
995 | ExtUtils::MakeMaker::neatvalue($CPAN::Config->{$_}), | |
996 | ",\n" | |
997 | ); | |
5f05dabc | 998 | } |
05454584 | 999 | |
c356248b | 1000 | $fh->print("};\n1;\n__END__\n"); |
05454584 A |
1001 | close $fh; |
1002 | ||
1003 | #$mode = 0444 | ( $mode & 0111 ? 0111 : 0 ); | |
1004 | #chmod $mode, $configpm; | |
e50380aa | 1005 | ###why was that so? $self->defaults; |
c356248b | 1006 | $CPAN::Frontend->myprint("commit: wrote $configpm\n"); |
05454584 | 1007 | 1; |
5f05dabc | 1008 | } |
1009 | ||
05454584 A |
1010 | *default = \&defaults; |
1011 | #-> sub CPAN::Config::defaults ; | |
1012 | sub defaults { | |
1013 | my($self) = @_; | |
1014 | $self->unload; | |
1015 | $self->load; | |
1016 | 1; | |
5f05dabc | 1017 | } |
1018 | ||
05454584 A |
1019 | sub init { |
1020 | my($self) = @_; | |
1021 | undef $CPAN::Config->{'inhibit_startup_message'}; # lazy trick to | |
1022 | # have the least | |
1023 | # important | |
1024 | # variable | |
1025 | # undefined | |
1026 | $self->load; | |
1027 | 1; | |
5f05dabc | 1028 | } |
1029 | ||
05454584 A |
1030 | #-> sub CPAN::Config::load ; |
1031 | sub load { | |
e50380aa A |
1032 | my($self) = shift; |
1033 | my(@miss); | |
f610777f | 1034 | use Carp; |
c356248b A |
1035 | eval {require CPAN::Config;}; # We eval because of some |
1036 | # MakeMaker problems | |
09d9d230 A |
1037 | unless ($dot_cpan++){ |
1038 | unshift @INC, MM->catdir($ENV{HOME},".cpan"); | |
1039 | eval {require CPAN::MyConfig;}; # where you can override | |
c356248b | 1040 | # system wide settings |
09d9d230 A |
1041 | shift @INC; |
1042 | } | |
e50380aa | 1043 | return unless @miss = $self->not_loaded; |
c356248b | 1044 | # XXX better check for arrayrefs too |
e50380aa | 1045 | require CPAN::FirstTime; |
55e314ee | 1046 | my($configpm,$fh,$redo,$theycalled); |
e50380aa | 1047 | $redo ||= ""; |
55e314ee | 1048 | $theycalled++ if @miss==1 && $miss[0] eq 'inhibit_startup_message'; |
e50380aa A |
1049 | if (defined $INC{"CPAN/Config.pm"} && -w $INC{"CPAN/Config.pm"}) { |
1050 | $configpm = $INC{"CPAN/Config.pm"}; | |
1051 | $redo++; | |
1052 | } elsif (defined $INC{"CPAN/MyConfig.pm"} && -w $INC{"CPAN/MyConfig.pm"}) { | |
1053 | $configpm = $INC{"CPAN/MyConfig.pm"}; | |
1054 | $redo++; | |
1055 | } else { | |
1056 | my($path_to_cpan) = File::Basename::dirname($INC{"CPAN.pm"}); | |
1057 | my($configpmdir) = MM->catdir($path_to_cpan,"CPAN"); | |
1058 | my($configpmtest) = MM->catfile($configpmdir,"Config.pm"); | |
1059 | if (-d $configpmdir or File::Path::mkpath($configpmdir)) { | |
1060 | if (-w $configpmtest) { | |
1061 | $configpm = $configpmtest; | |
1062 | } elsif (-w $configpmdir) { | |
1063 | #_#_# following code dumped core on me with 5.003_11, a.k. | |
1064 | unlink "$configpmtest.bak" if -f "$configpmtest.bak"; | |
1065 | rename $configpmtest, "$configpmtest.bak" if -f $configpmtest; | |
1066 | my $fh = FileHandle->new; | |
1067 | if ($fh->open(">$configpmtest")) { | |
1068 | $fh->print("1;\n"); | |
1069 | $configpm = $configpmtest; | |
1070 | } else { | |
1071 | # Should never happen | |
1072 | Carp::confess("Cannot open >$configpmtest"); | |
1073 | } | |
1074 | } | |
1075 | } | |
1076 | unless ($configpm) { | |
1077 | $configpmdir = MM->catdir($ENV{HOME},".cpan","CPAN"); | |
1078 | File::Path::mkpath($configpmdir); | |
1079 | $configpmtest = MM->catfile($configpmdir,"MyConfig.pm"); | |
1080 | if (-w $configpmtest) { | |
1081 | $configpm = $configpmtest; | |
1082 | } elsif (-w $configpmdir) { | |
1083 | #_#_# following code dumped core on me with 5.003_11, a.k. | |
1084 | my $fh = FileHandle->new; | |
1085 | if ($fh->open(">$configpmtest")) { | |
1086 | $fh->print("1;\n"); | |
1087 | $configpm = $configpmtest; | |
1088 | } else { | |
1089 | # Should never happen | |
1090 | Carp::confess("Cannot open >$configpmtest"); | |
1091 | } | |
1092 | } else { | |
1093 | Carp::confess(qq{WARNING: CPAN.pm is unable to }. | |
1094 | qq{create a configuration file.}); | |
1095 | } | |
1096 | } | |
1097 | } | |
1098 | local($") = ", "; | |
f610777f | 1099 | $CPAN::Frontend->myprint(<<END) if $redo && ! $theycalled; |
e50380aa A |
1100 | We have to reconfigure CPAN.pm due to following uninitialized parameters: |
1101 | ||
1102 | @miss | |
f610777f | 1103 | END |
c356248b | 1104 | $CPAN::Frontend->myprint(qq{ |
05454584 | 1105 | $configpm initialized. |
c356248b | 1106 | }); |
e50380aa A |
1107 | sleep 2; |
1108 | CPAN::FirstTime::init($configpm); | |
5f05dabc | 1109 | } |
1110 | ||
e50380aa A |
1111 | #-> sub CPAN::Config::not_loaded ; |
1112 | sub not_loaded { | |
1113 | my(@miss); | |
05454584 | 1114 | for (qw( |
f610777f A |
1115 | cpan_home keep_source_where build_dir build_cache scan_cache |
1116 | index_expire gzip tar unzip make pager makepl_arg make_arg | |
1117 | make_install_arg urllist inhibit_startup_message | |
1118 | ftp_proxy http_proxy no_proxy prerequisites_policy | |
05454584 | 1119 | )) { |
e50380aa | 1120 | push @miss, $_ unless defined $CPAN::Config->{$_}; |
5f05dabc | 1121 | } |
e50380aa | 1122 | return @miss; |
5f05dabc | 1123 | } |
1124 | ||
05454584 A |
1125 | #-> sub CPAN::Config::unload ; |
1126 | sub unload { | |
1127 | delete $INC{'CPAN/MyConfig.pm'}; | |
1128 | delete $INC{'CPAN/Config.pm'}; | |
5f05dabc | 1129 | } |
1130 | ||
05454584 A |
1131 | #-> sub CPAN::Config::help ; |
1132 | sub help { | |
2e2b7522 | 1133 | $CPAN::Frontend->myprint(q[ |
05454584 A |
1134 | Known options: |
1135 | defaults reload default config values from disk | |
1136 | commit commit session changes to disk | |
1137 | init go through a dialog to set all parameters | |
5f05dabc | 1138 | |
05454584 | 1139 | You may edit key values in the follow fashion: |
5f05dabc | 1140 | |
05454584 | 1141 | o conf build_cache 15 |
5f05dabc | 1142 | |
05454584 | 1143 | o conf build_dir "/foo/bar" |
5f05dabc | 1144 | |
05454584 | 1145 | o conf urllist shift |
5f05dabc | 1146 | |
05454584 | 1147 | o conf urllist unshift ftp://ftp.foo.bar/ |
5f05dabc | 1148 | |
2e2b7522 | 1149 | ]); |
05454584 A |
1150 | undef; #don't reprint CPAN::Config |
1151 | } | |
5f05dabc | 1152 | |
55e314ee A |
1153 | #-> sub CPAN::Config::cpl ; |
1154 | sub cpl { | |
05454584 A |
1155 | my($word,$line,$pos) = @_; |
1156 | $word ||= ""; | |
c356248b A |
1157 | CPAN->debug("word[$word] line[$line] pos[$pos]") if $CPAN::DEBUG; |
1158 | my(@words) = split " ", substr($line,0,$pos+1); | |
1159 | if ( | |
09d9d230 A |
1160 | defined($words[2]) |
1161 | and | |
1162 | ( | |
1163 | $words[2] =~ /list$/ && @words == 3 | |
1164 | || | |
1165 | $words[2] =~ /list$/ && @words == 4 && length($word) | |
1166 | ) | |
c356248b A |
1167 | ) { |
1168 | return grep /^\Q$word\E/, qw(splice shift unshift pop push); | |
1169 | } elsif (@words >= 4) { | |
1170 | return (); | |
1171 | } | |
05454584 A |
1172 | my(@o_conf) = (keys %CPAN::Config::can, keys %$CPAN::Config); |
1173 | return grep /^\Q$word\E/, @o_conf; | |
1174 | } | |
1175 | ||
1176 | package CPAN::Shell; | |
5f05dabc | 1177 | |
05454584 A |
1178 | #-> sub CPAN::Shell::h ; |
1179 | sub h { | |
1180 | my($class,$about) = @_; | |
1181 | if (defined $about) { | |
c356248b | 1182 | $CPAN::Frontend->myprint("Detailed help not yet implemented\n"); |
05454584 | 1183 | } else { |
c356248b | 1184 | $CPAN::Frontend->myprint(q{ |
05454584 A |
1185 | command arguments description |
1186 | a string authors | |
1187 | b or display bundles | |
1188 | d /regex/ info distributions | |
1189 | m or about modules | |
1190 | i none anything of above | |
da199366 | 1191 | |
05454584 A |
1192 | r as reinstall recommendations |
1193 | u above uninstalled distributions | |
1194 | See manpage for autobundle, recompile, force, look, etc. | |
da199366 | 1195 | |
05454584 A |
1196 | make make |
1197 | test modules, make test (implies make) | |
1198 | install dists, bundles, make install (implies test) | |
1199 | clean "r" or "u" make clean | |
1200 | readme display the README file | |
da199366 | 1201 | |
05454584 A |
1202 | reload index|cpan load most recent indices/CPAN.pm |
1203 | h or ? display this menu | |
1204 | o various set and query options | |
1205 | ! perl-code eval a perl command | |
1206 | q quit the shell subroutine | |
c356248b | 1207 | }); |
05454584 A |
1208 | } |
1209 | } | |
da199366 | 1210 | |
09d9d230 A |
1211 | *help = \&h; |
1212 | ||
05454584 | 1213 | #-> sub CPAN::Shell::a ; |
c356248b | 1214 | sub a { $CPAN::Frontend->myprint(shift->format_result('Author',@_));} |
05454584 A |
1215 | #-> sub CPAN::Shell::b ; |
1216 | sub b { | |
1217 | my($self,@which) = @_; | |
1218 | CPAN->debug("which[@which]") if $CPAN::DEBUG; | |
55e314ee | 1219 | my($incdir,$bdir,$dh); |
05454584 | 1220 | foreach $incdir ($CPAN::Config->{'cpan_home'},@INC) { |
c356248b | 1221 | $bdir = MM->catdir($incdir,"Bundle"); |
05454584 A |
1222 | if ($dh = DirHandle->new($bdir)) { # may fail |
1223 | my($entry); | |
1224 | for $entry ($dh->read) { | |
c356248b | 1225 | next if -d MM->catdir($bdir,$entry); |
05454584 A |
1226 | next unless $entry =~ s/\.pm$//; |
1227 | $CPAN::META->instance('CPAN::Bundle',"Bundle::$entry"); | |
1228 | } | |
1229 | } | |
1230 | } | |
c356248b | 1231 | $CPAN::Frontend->myprint($self->format_result('Bundle',@which)); |
05454584 A |
1232 | } |
1233 | #-> sub CPAN::Shell::d ; | |
c356248b | 1234 | sub d { $CPAN::Frontend->myprint(shift->format_result('Distribution',@_));} |
05454584 | 1235 | #-> sub CPAN::Shell::m ; |
f610777f A |
1236 | sub m { # emacs confused here }; sub mimimimimi { # emacs in sync here |
1237 | $CPAN::Frontend->myprint(shift->format_result('Module',@_)); | |
1238 | } | |
da199366 | 1239 | |
05454584 A |
1240 | #-> sub CPAN::Shell::i ; |
1241 | sub i { | |
1242 | my($self) = shift; | |
1243 | my(@args) = @_; | |
1244 | my(@type,$type,@m); | |
1245 | @type = qw/Author Bundle Distribution Module/; | |
1246 | @args = '/./' unless @args; | |
1247 | my(@result); | |
1248 | for $type (@type) { | |
1249 | push @result, $self->expand($type,@args); | |
1250 | } | |
e50380aa | 1251 | my $result = @result == 1 ? |
05454584 A |
1252 | $result[0]->as_string : |
1253 | join "", map {$_->as_glimpse} @result; | |
1254 | $result ||= "No objects found of any type for argument @args\n"; | |
c356248b | 1255 | $CPAN::Frontend->myprint($result); |
da199366 | 1256 | } |
da199366 | 1257 | |
05454584 A |
1258 | #-> sub CPAN::Shell::o ; |
1259 | sub o { | |
1260 | my($self,$o_type,@o_what) = @_; | |
1261 | $o_type ||= ""; | |
1262 | CPAN->debug("o_type[$o_type] o_what[".join(" | ",@o_what)."]\n"); | |
1263 | if ($o_type eq 'conf') { | |
1264 | shift @o_what if @o_what && $o_what[0] eq 'help'; | |
1265 | if (!@o_what) { | |
1266 | my($k,$v); | |
09d9d230 A |
1267 | $CPAN::Frontend->myprint("CPAN::Config options"); |
1268 | if (exists $INC{'CPAN/Config.pm'}) { | |
1269 | $CPAN::Frontend->myprint(" from $INC{'CPAN/Config.pm'}"); | |
1270 | } | |
1271 | if (exists $INC{'CPAN/MyConfig.pm'}) { | |
1272 | $CPAN::Frontend->myprint(" and $INC{'CPAN/MyConfig.pm'}"); | |
1273 | } | |
1274 | $CPAN::Frontend->myprint(":\n"); | |
05454584 A |
1275 | for $k (sort keys %CPAN::Config::can) { |
1276 | $v = $CPAN::Config::can{$k}; | |
c356248b | 1277 | $CPAN::Frontend->myprint(sprintf " %-18s %s\n", $k, $v); |
05454584 | 1278 | } |
c356248b | 1279 | $CPAN::Frontend->myprint("\n"); |
05454584 A |
1280 | for $k (sort keys %$CPAN::Config) { |
1281 | $v = $CPAN::Config->{$k}; | |
1282 | if (ref $v) { | |
c356248b A |
1283 | $CPAN::Frontend->myprint( |
1284 | join( | |
1285 | "", | |
1286 | sprintf( | |
1287 | " %-18s\n", | |
1288 | $k | |
1289 | ), | |
1290 | map {"\t$_\n"} @{$v} | |
1291 | ) | |
1292 | ); | |
10b2abe6 | 1293 | } else { |
c356248b | 1294 | $CPAN::Frontend->myprint(sprintf " %-18s %s\n", $k, $v); |
da199366 | 1295 | } |
10b2abe6 | 1296 | } |
c356248b | 1297 | $CPAN::Frontend->myprint("\n"); |
05454584 | 1298 | } elsif (!CPAN::Config->edit(@o_what)) { |
c356248b | 1299 | $CPAN::Frontend->myprint(qq[Type 'o conf' to view configuration edit options\n\n]); |
5f05dabc | 1300 | } |
05454584 A |
1301 | } elsif ($o_type eq 'debug') { |
1302 | my(%valid); | |
1303 | @o_what = () if defined $o_what[0] && $o_what[0] =~ /help/i; | |
1304 | if (@o_what) { | |
1305 | while (@o_what) { | |
1306 | my($what) = shift @o_what; | |
1307 | if ( exists $CPAN::DEBUG{$what} ) { | |
1308 | $CPAN::DEBUG |= $CPAN::DEBUG{$what}; | |
1309 | } elsif ($what =~ /^\d/) { | |
1310 | $CPAN::DEBUG = $what; | |
1311 | } elsif (lc $what eq 'all') { | |
1312 | my($max) = 0; | |
1313 | for (values %CPAN::DEBUG) { | |
1314 | $max += $_; | |
10b2abe6 | 1315 | } |
05454584 | 1316 | $CPAN::DEBUG = $max; |
10b2abe6 | 1317 | } else { |
d4fd5c69 | 1318 | my($known) = 0; |
05454584 A |
1319 | for (keys %CPAN::DEBUG) { |
1320 | next unless lc($_) eq lc($what); | |
1321 | $CPAN::DEBUG |= $CPAN::DEBUG{$_}; | |
d4fd5c69 | 1322 | $known = 1; |
10b2abe6 | 1323 | } |
c356248b A |
1324 | $CPAN::Frontend->myprint("unknown argument [$what]\n") |
1325 | unless $known; | |
10b2abe6 CS |
1326 | } |
1327 | } | |
05454584 | 1328 | } else { |
c356248b A |
1329 | $CPAN::Frontend->myprint("Valid options for debug are ". |
1330 | join(", ",sort(keys %CPAN::DEBUG), 'all'). | |
05454584 | 1331 | qq{ or a number. Completion works on the options. }. |
c356248b | 1332 | qq{Case is ignored.\n\n}); |
05454584 A |
1333 | } |
1334 | if ($CPAN::DEBUG) { | |
c356248b | 1335 | $CPAN::Frontend->myprint("Options set for debugging:\n"); |
05454584 A |
1336 | my($k,$v); |
1337 | for $k (sort {$CPAN::DEBUG{$a} <=> $CPAN::DEBUG{$b}} keys %CPAN::DEBUG) { | |
1338 | $v = $CPAN::DEBUG{$k}; | |
c356248b | 1339 | $CPAN::Frontend->myprint(sprintf " %-14s(%s)\n", $k, $v) if $v & $CPAN::DEBUG; |
05454584 A |
1340 | } |
1341 | } else { | |
c356248b | 1342 | $CPAN::Frontend->myprint("Debugging turned off completely.\n"); |
10b2abe6 | 1343 | } |
05454584 | 1344 | } else { |
c356248b | 1345 | $CPAN::Frontend->myprint(qq{ |
05454584 A |
1346 | Known options: |
1347 | conf set or get configuration variables | |
1348 | debug set or get debugging options | |
c356248b | 1349 | }); |
5f05dabc | 1350 | } |
5f05dabc | 1351 | } |
1352 | ||
36263cb3 GS |
1353 | sub dotdot_onreload { |
1354 | my($ref) = shift; | |
1355 | sub { | |
1356 | if ( $_[0] =~ /Subroutine (\w+) redefined/ ) { | |
1357 | my($subr) = $1; | |
1358 | ++$$ref; | |
1359 | local($|) = 1; | |
1360 | # $CPAN::Frontend->myprint(".($subr)"); | |
1361 | $CPAN::Frontend->myprint("."); | |
1362 | return; | |
1363 | } | |
1364 | warn @_; | |
1365 | }; | |
1366 | } | |
1367 | ||
05454584 A |
1368 | #-> sub CPAN::Shell::reload ; |
1369 | sub reload { | |
d4fd5c69 A |
1370 | my($self,$command,@arg) = @_; |
1371 | $command ||= ""; | |
1372 | $self->debug("self[$self]command[$command]arg[@arg]") if $CPAN::DEBUG; | |
1373 | if ($command =~ /cpan/i) { | |
05454584 A |
1374 | CPAN->debug("reloading the whole CPAN.pm") if $CPAN::DEBUG; |
1375 | my $fh = FileHandle->new($INC{'CPAN.pm'}); | |
1376 | local($/); | |
05454584 | 1377 | $redef = 0; |
36263cb3 | 1378 | local($SIG{__WARN__}) = dotdot_onreload(\$redef); |
05454584 A |
1379 | eval <$fh>; |
1380 | warn $@ if $@; | |
c356248b | 1381 | $CPAN::Frontend->myprint("\n$redef subroutines redefined\n"); |
d4fd5c69 | 1382 | } elsif ($command =~ /index/) { |
2e2b7522 | 1383 | CPAN::Index->force_reload; |
d4fd5c69 | 1384 | } else { |
2e2b7522 | 1385 | $CPAN::Frontend->myprint(qq{cpan re-evals the CPAN.pm file |
f14b5cec | 1386 | index re-reads the index files\n}); |
05454584 A |
1387 | } |
1388 | } | |
1389 | ||
1390 | #-> sub CPAN::Shell::_binary_extensions ; | |
1391 | sub _binary_extensions { | |
1392 | my($self) = shift @_; | |
1393 | my(@result,$module,%seen,%need,$headerdone); | |
e04b929a | 1394 | my $isaperl = q{perl5[._-]\\d{3}(_[0-4][0-9])?\\.tar[._-]gz$}; |
05454584 A |
1395 | for $module ($self->expand('Module','/./')) { |
1396 | my $file = $module->cpan_file; | |
1397 | next if $file eq "N/A"; | |
1398 | next if $file =~ /^Contact Author/; | |
c356248b | 1399 | next if $file =~ / $isaperl /xo; |
05454584 A |
1400 | next unless $module->xs_file; |
1401 | local($|) = 1; | |
c356248b | 1402 | $CPAN::Frontend->myprint("."); |
05454584 A |
1403 | push @result, $module; |
1404 | } | |
1405 | # print join " | ", @result; | |
c356248b | 1406 | $CPAN::Frontend->myprint("\n"); |
05454584 A |
1407 | return @result; |
1408 | } | |
1409 | ||
1410 | #-> sub CPAN::Shell::recompile ; | |
1411 | sub recompile { | |
1412 | my($self) = shift @_; | |
1413 | my($module,@module,$cpan_file,%dist); | |
1414 | @module = $self->_binary_extensions(); | |
c356248b A |
1415 | for $module (@module){ # we force now and compile later, so we |
1416 | # don't do it twice | |
05454584 A |
1417 | $cpan_file = $module->cpan_file; |
1418 | my $pack = $CPAN::META->instance('CPAN::Distribution',$cpan_file); | |
1419 | $pack->force; | |
1420 | $dist{$cpan_file}++; | |
1421 | } | |
1422 | for $cpan_file (sort keys %dist) { | |
c356248b | 1423 | $CPAN::Frontend->myprint(" CPAN: Recompiling $cpan_file\n\n"); |
05454584 A |
1424 | my $pack = $CPAN::META->instance('CPAN::Distribution',$cpan_file); |
1425 | $pack->install; | |
1426 | $CPAN::Signal = 0; # it's tempting to reset Signal, so we can | |
1427 | # stop a package from recompiling, | |
1428 | # e.g. IO-1.12 when we have perl5.003_10 | |
1429 | } | |
1430 | } | |
1431 | ||
1432 | #-> sub CPAN::Shell::_u_r_common ; | |
1433 | sub _u_r_common { | |
1434 | my($self) = shift @_; | |
1435 | my($what) = shift @_; | |
1436 | CPAN->debug("self[$self] what[$what] args[@_]") if $CPAN::DEBUG; | |
1437 | Carp::croak "Usage: \$obj->_u_r_common($what)" unless defined $what; | |
1438 | Carp::croak "Usage: \$obj->_u_r_common(a|r|u)" unless $what =~ /^[aru]$/; | |
1439 | my(@args) = @_; | |
1440 | @args = '/./' unless @args; | |
c356248b A |
1441 | my(@result,$module,%seen,%need,$headerdone, |
1442 | $version_undefs,$version_zeroes); | |
1443 | $version_undefs = $version_zeroes = 0; | |
05454584 A |
1444 | my $sprintf = "%-25s %9s %9s %s\n"; |
1445 | for $module ($self->expand('Module',@args)) { | |
1446 | my $file = $module->cpan_file; | |
1447 | next unless defined $file; # ?? | |
c356248b | 1448 | my($latest) = $module->cpan_version; |
05454584 A |
1449 | my($inst_file) = $module->inst_file; |
1450 | my($have); | |
09d9d230 | 1451 | return if $CPAN::Signal; |
05454584 A |
1452 | if ($inst_file){ |
1453 | if ($what eq "a") { | |
1454 | $have = $module->inst_version; | |
1455 | } elsif ($what eq "r") { | |
1456 | $have = $module->inst_version; | |
1457 | local($^W) = 0; | |
c356248b A |
1458 | if ($have eq "undef"){ |
1459 | $version_undefs++; | |
1460 | } elsif ($have == 0){ | |
1461 | $version_zeroes++; | |
1462 | } | |
05454584 | 1463 | next if $have >= $latest; |
c356248b A |
1464 | # to be pedantic we should probably say: |
1465 | # && !($have eq "undef" && $latest ne "undef" && $latest gt ""); | |
1466 | # to catch the case where CPAN has a version 0 and we have a version undef | |
05454584 A |
1467 | } elsif ($what eq "u") { |
1468 | next; | |
1469 | } | |
1470 | } else { | |
1471 | if ($what eq "a") { | |
1472 | next; | |
1473 | } elsif ($what eq "r") { | |
1474 | next; | |
1475 | } elsif ($what eq "u") { | |
1476 | $have = "-"; | |
1477 | } | |
1478 | } | |
1479 | return if $CPAN::Signal; # this is sometimes lengthy | |
1480 | $seen{$file} ||= 0; | |
1481 | if ($what eq "a") { | |
1482 | push @result, sprintf "%s %s\n", $module->id, $have; | |
1483 | } elsif ($what eq "r") { | |
1484 | push @result, $module->id; | |
1485 | next if $seen{$file}++; | |
1486 | } elsif ($what eq "u") { | |
1487 | push @result, $module->id; | |
1488 | next if $seen{$file}++; | |
1489 | next if $file =~ /^Contact/; | |
1490 | } | |
1491 | unless ($headerdone++){ | |
c356248b A |
1492 | $CPAN::Frontend->myprint("\n"); |
1493 | $CPAN::Frontend->myprint(sprintf( | |
05454584 A |
1494 | $sprintf, |
1495 | "Package namespace", | |
1496 | "installed", | |
1497 | "latest", | |
1498 | "in CPAN file" | |
c356248b | 1499 | )); |
05454584 A |
1500 | } |
1501 | $latest = substr($latest,0,8) if length($latest) > 8; | |
1502 | $have = substr($have,0,8) if length($have) > 8; | |
c356248b | 1503 | $CPAN::Frontend->myprint(sprintf $sprintf, $module->id, $have, $latest, $file); |
05454584 A |
1504 | $need{$module->id}++; |
1505 | } | |
1506 | unless (%need) { | |
1507 | if ($what eq "u") { | |
c356248b | 1508 | $CPAN::Frontend->myprint("No modules found for @args\n"); |
05454584 | 1509 | } elsif ($what eq "r") { |
c356248b | 1510 | $CPAN::Frontend->myprint("All modules are up to date for @args\n"); |
05454584 A |
1511 | } |
1512 | } | |
c356248b A |
1513 | if ($what eq "r") { |
1514 | if ($version_zeroes) { | |
1515 | my $s_has = $version_zeroes > 1 ? "s have" : " has"; | |
1516 | $CPAN::Frontend->myprint(qq{$version_zeroes installed module$s_has }. | |
1517 | qq{a version number of 0\n}); | |
1518 | } | |
1519 | if ($version_undefs) { | |
1520 | my $s_has = $version_undefs > 1 ? "s have" : " has"; | |
1521 | $CPAN::Frontend->myprint(qq{$version_undefs installed module$s_has no }. | |
1522 | qq{parseable version number\n}); | |
1523 | } | |
05454584 A |
1524 | } |
1525 | @result; | |
1526 | } | |
1527 | ||
1528 | #-> sub CPAN::Shell::r ; | |
1529 | sub r { | |
1530 | shift->_u_r_common("r",@_); | |
1531 | } | |
1532 | ||
1533 | #-> sub CPAN::Shell::u ; | |
1534 | sub u { | |
1535 | shift->_u_r_common("u",@_); | |
1536 | } | |
1537 | ||
1538 | #-> sub CPAN::Shell::autobundle ; | |
1539 | sub autobundle { | |
1540 | my($self) = shift; | |
36263cb3 | 1541 | CPAN::Config->load unless $CPAN::Config_loaded++; |
05454584 | 1542 | my(@bundle) = $self->_u_r_common("a",@_); |
c356248b | 1543 | my($todir) = MM->catdir($CPAN::Config->{'cpan_home'},"Bundle"); |
05454584 A |
1544 | File::Path::mkpath($todir); |
1545 | unless (-d $todir) { | |
c356248b | 1546 | $CPAN::Frontend->myprint("Couldn't mkdir $todir for some reason\n"); |
05454584 A |
1547 | return; |
1548 | } | |
1549 | my($y,$m,$d) = (localtime)[5,4,3]; | |
1550 | $y+=1900; | |
1551 | $m++; | |
1552 | my($c) = 0; | |
1553 | my($me) = sprintf "Snapshot_%04d_%02d_%02d_%02d", $y, $m, $d, $c; | |
c356248b | 1554 | my($to) = MM->catfile($todir,"$me.pm"); |
05454584 A |
1555 | while (-f $to) { |
1556 | $me = sprintf "Snapshot_%04d_%02d_%02d_%02d", $y, $m, $d, ++$c; | |
c356248b | 1557 | $to = MM->catfile($todir,"$me.pm"); |
05454584 A |
1558 | } |
1559 | my($fh) = FileHandle->new(">$to") or Carp::croak "Can't open >$to: $!"; | |
1560 | $fh->print( | |
1561 | "package Bundle::$me;\n\n", | |
1562 | "\$VERSION = '0.01';\n\n", | |
1563 | "1;\n\n", | |
1564 | "__END__\n\n", | |
1565 | "=head1 NAME\n\n", | |
1566 | "Bundle::$me - Snapshot of installation on ", | |
1567 | $Config::Config{'myhostname'}, | |
1568 | " on ", | |
1569 | scalar(localtime), | |
1570 | "\n\n=head1 SYNOPSIS\n\n", | |
1571 | "perl -MCPAN -e 'install Bundle::$me'\n\n", | |
1572 | "=head1 CONTENTS\n\n", | |
1573 | join("\n", @bundle), | |
1574 | "\n\n=head1 CONFIGURATION\n\n", | |
1575 | Config->myconfig, | |
1576 | "\n\n=head1 AUTHOR\n\n", | |
1577 | "This Bundle has been generated automatically ", | |
1578 | "by the autobundle routine in CPAN.pm.\n", | |
1579 | ); | |
1580 | $fh->close; | |
c356248b A |
1581 | $CPAN::Frontend->myprint("\nWrote bundle file |
1582 | $to\n\n"); | |
05454584 A |
1583 | } |
1584 | ||
1585 | #-> sub CPAN::Shell::expand ; | |
1586 | sub expand { | |
1587 | shift; | |
1588 | my($type,@args) = @_; | |
1589 | my($arg,@m); | |
1590 | for $arg (@args) { | |
1591 | my $regex; | |
1592 | if ($arg =~ m|^/(.*)/$|) { | |
1593 | $regex = $1; | |
1594 | } | |
1595 | my $class = "CPAN::$type"; | |
1596 | my $obj; | |
1597 | if (defined $regex) { | |
36263cb3 | 1598 | for $obj ( sort {$a->id cmp $b->id} $CPAN::META->all_objects($class)) { |
05454584 A |
1599 | push @m, $obj |
1600 | if | |
1601 | $obj->id =~ /$regex/i | |
1602 | or | |
1603 | ( | |
1604 | ( | |
1605 | $] < 5.00303 ### provide sort of compatibility with 5.003 | |
1606 | || | |
1607 | $obj->can('name') | |
1608 | ) | |
1609 | && | |
1610 | $obj->name =~ /$regex/i | |
1611 | ); | |
1612 | } | |
1613 | } else { | |
1614 | my($xarg) = $arg; | |
1615 | if ( $type eq 'Bundle' ) { | |
1616 | $xarg =~ s/^(Bundle::)?(.*)/Bundle::$2/; | |
1617 | } | |
1618 | if ($CPAN::META->exists($class,$xarg)) { | |
1619 | $obj = $CPAN::META->instance($class,$xarg); | |
1620 | } elsif ($CPAN::META->exists($class,$arg)) { | |
1621 | $obj = $CPAN::META->instance($class,$arg); | |
1622 | } else { | |
1623 | next; | |
1624 | } | |
1625 | push @m, $obj; | |
1626 | } | |
1627 | } | |
e50380aa | 1628 | return wantarray ? @m : $m[0]; |
05454584 A |
1629 | } |
1630 | ||
1631 | #-> sub CPAN::Shell::format_result ; | |
1632 | sub format_result { | |
1633 | my($self) = shift; | |
1634 | my($type,@args) = @_; | |
1635 | @args = '/./' unless @args; | |
1636 | my(@result) = $self->expand($type,@args); | |
e50380aa | 1637 | my $result = @result == 1 ? |
05454584 A |
1638 | $result[0]->as_string : |
1639 | join "", map {$_->as_glimpse} @result; | |
1640 | $result ||= "No objects of type $type found for argument @args\n"; | |
1641 | $result; | |
1642 | } | |
1643 | ||
c356248b A |
1644 | # The only reason for this method is currently to have a reliable |
1645 | # debugging utility that reveals which output is going through which | |
1646 | # channel. No, I don't like the colors ;-) | |
1647 | sub print_ornamented { | |
1648 | my($self,$what,$ornament) = @_; | |
1649 | my $longest = 0; | |
1650 | my $ornamenting = 0; # turn the colors on | |
1651 | ||
1652 | if ($ornamenting) { | |
1653 | unless (defined &color) { | |
1654 | if ($CPAN::META->has_inst("Term::ANSIColor")) { | |
1655 | import Term::ANSIColor "color"; | |
1656 | } else { | |
1657 | *color = sub { return "" }; | |
1658 | } | |
1659 | } | |
09d9d230 A |
1660 | my $line; |
1661 | for $line (split /\n/, $what) { | |
c356248b A |
1662 | $longest = length($line) if length($line) > $longest; |
1663 | } | |
1664 | my $sprintf = "%-" . $longest . "s"; | |
1665 | while ($what){ | |
1666 | $what =~ s/(.*\n?)//m; | |
1667 | my $line = $1; | |
1668 | last unless $line; | |
1669 | my($nl) = chomp $line ? "\n" : ""; | |
1670 | # print "line[$line]ornament[$ornament]sprintf[$sprintf]\n"; | |
1671 | print color($ornament), sprintf($sprintf,$line), color("reset"), $nl; | |
1672 | } | |
1673 | } else { | |
1674 | print $what; | |
1675 | } | |
1676 | } | |
1677 | ||
1678 | sub myprint { | |
1679 | my($self,$what) = @_; | |
1680 | $self->print_ornamented($what, 'bold blue on_yellow'); | |
1681 | } | |
1682 | ||
1683 | sub myexit { | |
1684 | my($self,$what) = @_; | |
1685 | $self->myprint($what); | |
1686 | exit; | |
1687 | } | |
1688 | ||
1689 | sub mywarn { | |
1690 | my($self,$what) = @_; | |
1691 | $self->print_ornamented($what, 'bold red on_yellow'); | |
1692 | } | |
1693 | ||
1694 | sub myconfess { | |
1695 | my($self,$what) = @_; | |
1696 | $self->print_ornamented($what, 'bold red on_white'); | |
1697 | Carp::confess "died"; | |
1698 | } | |
1699 | ||
1700 | sub mydie { | |
1701 | my($self,$what) = @_; | |
1702 | $self->print_ornamented($what, 'bold red on_white'); | |
1703 | die "\n"; | |
1704 | } | |
1705 | ||
05454584 | 1706 | #-> sub CPAN::Shell::rematein ; |
09d9d230 | 1707 | # RE-adme||MA-ke||TE-st||IN-stall |
05454584 A |
1708 | sub rematein { |
1709 | shift; | |
1710 | my($meth,@some) = @_; | |
1711 | my $pragma = ""; | |
1712 | if ($meth eq 'force') { | |
1713 | $pragma = $meth; | |
1714 | $meth = shift @some; | |
1715 | } | |
1716 | CPAN->debug("pragma[$pragma]meth[$meth] some[@some]") if $CPAN::DEBUG; | |
1717 | my($s,@s); | |
1718 | foreach $s (@some) { | |
f610777f A |
1719 | CPAN::Queue->new($s); |
1720 | } | |
1721 | while ($s = CPAN::Queue->first) { | |
05454584 A |
1722 | my $obj; |
1723 | if (ref $s) { | |
1724 | $obj = $s; | |
1725 | } elsif ($s =~ m|/|) { # looks like a file | |
1726 | $obj = $CPAN::META->instance('CPAN::Distribution',$s); | |
1727 | } elsif ($s =~ m|^Bundle::|) { | |
1728 | $obj = $CPAN::META->instance('CPAN::Bundle',$s); | |
1729 | } else { | |
1730 | $obj = $CPAN::META->instance('CPAN::Module',$s) | |
1731 | if $CPAN::META->exists('CPAN::Module',$s); | |
1732 | } | |
1733 | if (ref $obj) { | |
1734 | CPAN->debug( | |
f610777f | 1735 | qq{pragma[$pragma]meth[$meth]obj[$obj]as_string\[}. |
05454584 A |
1736 | $obj->as_string. |
1737 | qq{\]} | |
1738 | ) if $CPAN::DEBUG; | |
1739 | $obj->$pragma() | |
1740 | if | |
1741 | $pragma | |
1742 | && | |
09d9d230 A |
1743 | ($] < 5.00303 || $obj->can($pragma)); ### |
1744 | ### compatibility | |
1745 | ### with | |
1746 | ### 5.003 | |
1747 | if ($]>=5.00303 && $obj->can('called_for')) { | |
1748 | $obj->called_for($s); | |
1749 | } | |
f610777f A |
1750 | CPAN::Queue->delete($s) if $obj->$meth(); # if it is more |
1751 | # than once in | |
1752 | # the queue | |
05454584 A |
1753 | } elsif ($CPAN::META->exists('CPAN::Author',$s)) { |
1754 | $obj = $CPAN::META->instance('CPAN::Author',$s); | |
c356248b A |
1755 | $CPAN::Frontend->myprint( |
1756 | join "", | |
1757 | "Don't be silly, you can't $meth ", | |
1758 | $obj->fullname, | |
1759 | " ;-)\n" | |
1760 | ); | |
05454584 | 1761 | } else { |
f610777f A |
1762 | $CPAN::Frontend |
1763 | ->myprint(qq{Warning: Cannot $meth $s, }. | |
1764 | qq{don\'t know what it is. | |
e50380aa A |
1765 | Try the command |
1766 | ||
1767 | i /$s/ | |
1768 | ||
1769 | to find objects with similar identifiers. | |
c356248b | 1770 | }); |
05454584 | 1771 | } |
f610777f | 1772 | CPAN::Queue->delete_first($s); |
05454584 A |
1773 | } |
1774 | } | |
1775 | ||
1776 | #-> sub CPAN::Shell::force ; | |
1777 | sub force { shift->rematein('force',@_); } | |
1778 | #-> sub CPAN::Shell::get ; | |
1779 | sub get { shift->rematein('get',@_); } | |
1780 | #-> sub CPAN::Shell::readme ; | |
1781 | sub readme { shift->rematein('readme',@_); } | |
1782 | #-> sub CPAN::Shell::make ; | |
1783 | sub make { shift->rematein('make',@_); } | |
1784 | #-> sub CPAN::Shell::test ; | |
1785 | sub test { shift->rematein('test',@_); } | |
1786 | #-> sub CPAN::Shell::install ; | |
1787 | sub install { shift->rematein('install',@_); } | |
1788 | #-> sub CPAN::Shell::clean ; | |
1789 | sub clean { shift->rematein('clean',@_); } | |
1790 | #-> sub CPAN::Shell::look ; | |
1791 | sub look { shift->rematein('look',@_); } | |
1792 | ||
1793 | package CPAN::FTP; | |
05454584 A |
1794 | |
1795 | #-> sub CPAN::FTP::ftp_get ; | |
1796 | sub ftp_get { | |
2e2b7522 GS |
1797 | my($class,$host,$dir,$file,$target) = @_; |
1798 | $class->debug( | |
1799 | qq[Going to fetch file [$file] from dir [$dir] | |
05454584 A |
1800 | on host [$host] as local [$target]\n] |
1801 | ) if $CPAN::DEBUG; | |
2e2b7522 GS |
1802 | my $ftp = Net::FTP->new($host); |
1803 | return 0 unless defined $ftp; | |
1804 | $ftp->debug(1) if $CPAN::DEBUG{'FTP'} & $CPAN::DEBUG; | |
1805 | $class->debug(qq[Going to ->login("anonymous","$Config::Config{'cf_email'}")\n]); | |
1806 | unless ( $ftp->login("anonymous",$Config::Config{'cf_email'}) ){ | |
1807 | warn "Couldn't login on $host"; | |
1808 | return; | |
1809 | } | |
1810 | unless ( $ftp->cwd($dir) ){ | |
1811 | warn "Couldn't cwd $dir"; | |
1812 | return; | |
1813 | } | |
1814 | $ftp->binary; | |
1815 | $class->debug(qq[Going to ->get("$file","$target")\n]) if $CPAN::DEBUG; | |
1816 | unless ( $ftp->get($file,$target) ){ | |
1817 | warn "Couldn't fetch $file from $host\n"; | |
1818 | return; | |
1819 | } | |
1820 | $ftp->quit; # it's ok if this fails | |
1821 | return 1; | |
05454584 A |
1822 | } |
1823 | ||
09d9d230 | 1824 | # If more accuracy is wanted/needed, Chris Leach sent me this patch... |
f610777f | 1825 | |
09d9d230 A |
1826 | # leach,> *** /install/perl/live/lib/CPAN.pm- Wed Sep 24 13:08:48 1997 |
1827 | # leach,> --- /tmp/cp Wed Sep 24 13:26:40 1997 | |
1828 | # leach,> *************** | |
1829 | # leach,> *** 1562,1567 **** | |
1830 | # leach,> --- 1562,1580 ---- | |
1831 | # leach,> return 1 if substr($url,0,4) eq "file"; | |
1832 | # leach,> return 1 unless $url =~ m|://([^/]+)|; | |
1833 | # leach,> my $host = $1; | |
1834 | # leach,> + my $proxy = $CPAN::Config->{'http_proxy'} || $ENV{'http_proxy'}; | |
1835 | # leach,> + if ($proxy) { | |
1836 | # leach,> + $proxy =~ m|://([^/:]+)|; | |
1837 | # leach,> + $proxy = $1; | |
1838 | # leach,> + my $noproxy = $CPAN::Config->{'no_proxy'} || $ENV{'no_proxy'}; | |
1839 | # leach,> + if ($noproxy) { | |
1840 | # leach,> + if ($host !~ /$noproxy$/) { | |
1841 | # leach,> + $host = $proxy; | |
1842 | # leach,> + } | |
1843 | # leach,> + } else { | |
1844 | # leach,> + $host = $proxy; | |
1845 | # leach,> + } | |
1846 | # leach,> + } | |
1847 | # leach,> require Net::Ping; | |
1848 | # leach,> return 1 unless $Net::Ping::VERSION >= 2; | |
1849 | # leach,> my $p; | |
1850 | ||
1851 | ||
1852 | # this is quite optimistic and returns one on several occasions where | |
1853 | # inappropriate. But this does no harm. It would do harm if we were | |
1854 | # too pessimistic (as I was before the http_proxy | |
c356248b A |
1855 | sub is_reachable { |
1856 | my($self,$url) = @_; | |
1857 | return 1; # we can't simply roll our own, firewalls may break ping | |
1858 | return 0 unless $url; | |
1859 | return 1 if substr($url,0,4) eq "file"; | |
09d9d230 A |
1860 | return 1 unless $url =~ m|^(\w+)://([^/]+)|; |
1861 | my $proxytype = $1 . "_proxy"; # ftp_proxy or http_proxy | |
1862 | my $host = $2; | |
1863 | return 1 if $CPAN::Config->{$proxytype} || $ENV{$proxytype}; | |
c356248b A |
1864 | require Net::Ping; |
1865 | return 1 unless $Net::Ping::VERSION >= 2; | |
1866 | my $p; | |
09d9d230 A |
1867 | # 1.3101 had it different: only if the first eval raised an |
1868 | # exception we tried it with TCP. Now we are happy if icmp wins | |
1869 | # the order and return, we don't even check for $@. Thanks to | |
1870 | # thayer@uis.edu for the suggestion. | |
c356248b | 1871 | eval {$p = Net::Ping->new("icmp");}; |
09d9d230 A |
1872 | return 1 if $p && ref($p) && $p->ping($host, 10); |
1873 | eval {$p = Net::Ping->new("tcp");}; | |
c356248b | 1874 | $CPAN::Frontend->mydie($@) if $@; |
09d9d230 | 1875 | return $p->ping($host, 10); |
c356248b A |
1876 | } |
1877 | ||
05454584 | 1878 | #-> sub CPAN::FTP::localize ; |
55e314ee A |
1879 | # sorry for the ugly code here, I'll clean it up as soon as Net::FTP |
1880 | # is in the core | |
05454584 A |
1881 | sub localize { |
1882 | my($self,$file,$aslocal,$force) = @_; | |
1883 | $force ||= 0; | |
1884 | Carp::croak "Usage: ->localize(cpan_file,as_local_file[,$force])" | |
1885 | unless defined $aslocal; | |
55e314ee A |
1886 | $self->debug("file[$file] aslocal[$aslocal] force[$force]") |
1887 | if $CPAN::DEBUG; | |
05454584 | 1888 | |
f14b5cec JH |
1889 | if ($^O eq 'MacOS') { |
1890 | my($name, $path) = File::Basename::fileparse($aslocal, ''); | |
1891 | if (length($name) > 31) { | |
1892 | $name =~ s/(\.(readme(\.(gz|Z))?|(tar\.)?(gz|Z)|tgz|zip|pm\.(gz|Z)))$//; | |
1893 | my $suf = $1; | |
1894 | my $size = 31 - length($suf); | |
1895 | while (length($name) > $size) { | |
1896 | chop $name; | |
1897 | } | |
1898 | $name .= $suf; | |
1899 | $aslocal = File::Spec->catfile($path, $name); | |
1900 | } | |
1901 | } | |
1902 | ||
c356248b | 1903 | return $aslocal if -f $aslocal && -r _ && !($force & 1); |
55e314ee A |
1904 | my($restore) = 0; |
1905 | if (-f $aslocal){ | |
1906 | rename $aslocal, "$aslocal.bak"; | |
1907 | $restore++; | |
1908 | } | |
05454584 A |
1909 | |
1910 | my($aslocal_dir) = File::Basename::dirname($aslocal); | |
1911 | File::Path::mkpath($aslocal_dir); | |
c356248b | 1912 | $CPAN::Frontend->mywarn(qq{Warning: You are not allowed to write into }. |
05454584 | 1913 | qq{directory "$aslocal_dir". |
c356248b A |
1914 | I\'ll continue, but if you encounter problems, they may be due |
1915 | to insufficient permissions.\n}) unless -w $aslocal_dir; | |
05454584 A |
1916 | |
1917 | # Inheritance is not easier to manage than a few if/else branches | |
36263cb3 | 1918 | if ($CPAN::META->has_inst('LWP::UserAgent')) { |
05454584 A |
1919 | require LWP::UserAgent; |
1920 | unless ($Ua) { | |
55e314ee | 1921 | $Ua = LWP::UserAgent->new; |
05454584 A |
1922 | my($var); |
1923 | $Ua->proxy('ftp', $var) | |
1924 | if $var = $CPAN::Config->{'ftp_proxy'} || $ENV{'ftp_proxy'}; | |
1925 | $Ua->proxy('http', $var) | |
1926 | if $var = $CPAN::Config->{'http_proxy'} || $ENV{'http_proxy'}; | |
1927 | $Ua->no_proxy($var) | |
1928 | if $var = $CPAN::Config->{'no_proxy'} || $ENV{'no_proxy'}; | |
1929 | } | |
1930 | } | |
1931 | ||
1932 | # Try the list of urls for each single object. We keep a record | |
1933 | # where we did get a file from | |
c356248b | 1934 | my(@reordered,$last); |
09d9d230 | 1935 | $CPAN::Config->{urllist} ||= []; |
c356248b A |
1936 | $last = $#{$CPAN::Config->{urllist}}; |
1937 | if ($force & 2) { # local cpans probably out of date, don't reorder | |
1938 | @reordered = (0..$last); | |
1939 | } else { | |
1940 | @reordered = | |
1941 | sort { | |
1942 | (substr($CPAN::Config->{urllist}[$b],0,4) eq "file") | |
f610777f | 1943 | <=> |
c356248b A |
1944 | (substr($CPAN::Config->{urllist}[$a],0,4) eq "file") |
1945 | or | |
1946 | defined($Thesite) | |
1947 | and | |
1948 | ($b == $Thesite) | |
1949 | <=> | |
1950 | ($a == $Thesite) | |
1951 | } 0..$last; | |
c356248b A |
1952 | } |
1953 | my($level,@levels); | |
1954 | if ($Themethod) { | |
1955 | @levels = ($Themethod, grep {$_ ne $Themethod} qw/easy hard hardest/); | |
1956 | } else { | |
1957 | @levels = qw/easy hard hardest/; | |
1958 | } | |
f14b5cec | 1959 | @levels = qw/easy/ if $^O eq 'MacOS'; |
c356248b A |
1960 | for $level (@levels) { |
1961 | my $method = "host$level"; | |
1962 | my @host_seq = $level eq "easy" ? | |
1963 | @reordered : 0..$last; # reordered has CDROM up front | |
09d9d230 | 1964 | @host_seq = (0) unless @host_seq; |
c356248b A |
1965 | my $ret = $self->$method(\@host_seq,$file,$aslocal); |
1966 | if ($ret) { | |
2e2b7522 GS |
1967 | $Themethod = $level; |
1968 | $self->debug("level[$level]") if $CPAN::DEBUG; | |
1969 | return $ret; | |
1970 | } else { | |
1971 | unlink $aslocal; | |
c356248b A |
1972 | } |
1973 | } | |
1974 | my(@mess); | |
1975 | push @mess, | |
1976 | qq{Please check, if the URLs I found in your configuration file \(}. | |
1977 | join(", ", @{$CPAN::Config->{urllist}}). | |
1978 | qq{\) are valid. The urllist can be edited.}, | |
1979 | qq{E.g. with ``o conf urllist push ftp://myurl/''}; | |
1980 | $CPAN::Frontend->myprint(Text::Wrap::wrap("","",@mess). "\n\n"); | |
1981 | sleep 2; | |
1982 | $CPAN::Frontend->myprint("Cannot fetch $file\n\n"); | |
1983 | if ($restore) { | |
1984 | rename "$aslocal.bak", $aslocal; | |
1985 | $CPAN::Frontend->myprint("Trying to get away with old file:\n" . | |
1986 | $self->ls($aslocal)); | |
1987 | return $aslocal; | |
1988 | } | |
1989 | return; | |
1990 | } | |
1991 | ||
1992 | sub hosteasy { | |
1993 | my($self,$host_seq,$file,$aslocal) = @_; | |
05454584 | 1994 | my($i); |
c356248b | 1995 | HOSTEASY: for $i (@$host_seq) { |
09d9d230 | 1996 | my $url = $CPAN::Config->{urllist}[$i] || $CPAN::Defaultsite; |
c356248b A |
1997 | unless ($self->is_reachable($url)) { |
1998 | $CPAN::Frontend->myprint("Skipping $url (seems to be not reachable)\n"); | |
1999 | sleep 2; | |
2000 | next; | |
2001 | } | |
05454584 A |
2002 | $url .= "/" unless substr($url,-1) eq "/"; |
2003 | $url .= $file; | |
c356248b | 2004 | $self->debug("localizing perlish[$url]") if $CPAN::DEBUG; |
05454584 A |
2005 | if ($url =~ /^file:/) { |
2006 | my $l; | |
55e314ee | 2007 | if ($CPAN::META->has_inst('LWP')) { |
05454584 | 2008 | require URI::URL; |
55e314ee | 2009 | my $u = URI::URL->new($url); |
05454584 A |
2010 | $l = $u->path; |
2011 | } else { # works only on Unix, is poorly constructed, but | |
c356248b A |
2012 | # hopefully better than nothing. |
2013 | # RFC 1738 says fileurl BNF is | |
2014 | # fileurl = "file://" [ host | "localhost" ] "/" fpath | |
2015 | # Thanks to "Mark D. Baushke" <mdb@cisco.com> for | |
2016 | # the code | |
36263cb3 GS |
2017 | ($l = $url) =~ s|^file://[^/]*/|/|; # discard the host part |
2018 | $l =~ s|^file:||; # assume they | |
2019 | # meant | |
2020 | # file://localhost | |
2021 | $l =~ s|^/|| unless -f $l; # e.g. /P: | |
05454584 | 2022 | } |
c356248b A |
2023 | if ( -f $l && -r _) { |
2024 | $Thesite = $i; | |
2025 | return $l; | |
2026 | } | |
05454584 A |
2027 | # Maybe mirror has compressed it? |
2028 | if (-f "$l.gz") { | |
d4fd5c69 | 2029 | $self->debug("found compressed $l.gz") if $CPAN::DEBUG; |
09d9d230 | 2030 | CPAN::Tarzip->gunzip("$l.gz", $aslocal); |
c356248b A |
2031 | if ( -f $aslocal) { |
2032 | $Thesite = $i; | |
2033 | return $aslocal; | |
2034 | } | |
05454584 A |
2035 | } |
2036 | } | |
2e2b7522 | 2037 | if ($CPAN::META->has_inst('LWP')) { |
09d9d230 | 2038 | $CPAN::Frontend->myprint("Fetching with LWP: |
c356248b A |
2039 | $url |
2040 | "); | |
f610777f A |
2041 | unless ($Ua) { |
2042 | require LWP::UserAgent; | |
2043 | $Ua = LWP::UserAgent->new; | |
2044 | } | |
09d9d230 A |
2045 | my $res = $Ua->mirror($url, $aslocal); |
2046 | if ($res->is_success) { | |
2047 | $Thesite = $i; | |
2048 | return $aslocal; | |
2049 | } elsif ($url !~ /\.gz$/) { | |
2050 | my $gzurl = "$url.gz"; | |
2051 | $CPAN::Frontend->myprint("Fetching with LWP: | |
c356248b A |
2052 | $gzurl |
2053 | "); | |
09d9d230 A |
2054 | $res = $Ua->mirror($gzurl, "$aslocal.gz"); |
2055 | if ($res->is_success && | |
2056 | CPAN::Tarzip->gunzip("$aslocal.gz",$aslocal) | |
2057 | ) { | |
2058 | $Thesite = $i; | |
2059 | return $aslocal; | |
c356248b | 2060 | } else { |
09d9d230 | 2061 | # next HOSTEASY ; |
05454584 | 2062 | } |
09d9d230 A |
2063 | } else { |
2064 | # Alan Burlison informed me that in firewall envs Net::FTP | |
2065 | # can still succeed where LWP fails. So we do not skip | |
2066 | # Net::FTP anymore when LWP is available. | |
2067 | # next HOSTEASY ; | |
2068 | } | |
2069 | } else { | |
2070 | $self->debug("LWP not installed") if $CPAN::DEBUG; | |
05454584 A |
2071 | } |
2072 | if ($url =~ m|^ftp://(.*?)/(.*)/(.*)|) { | |
2073 | # that's the nice and easy way thanks to Graham | |
2074 | my($host,$dir,$getfile) = ($1,$2,$3); | |
55e314ee | 2075 | if ($CPAN::META->has_inst('Net::FTP')) { |
05454584 | 2076 | $dir =~ s|/+|/|g; |
c356248b | 2077 | $CPAN::Frontend->myprint("Fetching with Net::FTP: |
09d9d230 | 2078 | $url |
c356248b A |
2079 | "); |
2080 | $self->debug("getfile[$getfile]dir[$dir]host[$host]" . | |
2081 | "aslocal[$aslocal]") if $CPAN::DEBUG; | |
2082 | if (CPAN::FTP->ftp_get($host,$dir,$getfile,$aslocal)) { | |
2083 | $Thesite = $i; | |
2084 | return $aslocal; | |
2085 | } | |
2086 | if ($aslocal !~ /\.gz$/) { | |
2087 | my $gz = "$aslocal.gz"; | |
2088 | $CPAN::Frontend->myprint("Fetching with Net::FTP | |
09d9d230 | 2089 | $url.gz |
c356248b | 2090 | "); |
2e2b7522 | 2091 | if (CPAN::FTP->ftp_get($host, |
09d9d230 A |
2092 | $dir, |
2093 | "$getfile.gz", | |
2094 | $gz) && | |
2095 | CPAN::Tarzip->gunzip($gz,$aslocal) | |
2096 | ){ | |
c356248b A |
2097 | $Thesite = $i; |
2098 | return $aslocal; | |
2099 | } | |
2100 | } | |
09d9d230 | 2101 | # next HOSTEASY; |
05454584 A |
2102 | } |
2103 | } | |
c356248b A |
2104 | } |
2105 | } | |
05454584 | 2106 | |
c356248b | 2107 | sub hosthard { |
2e2b7522 | 2108 | my($self,$host_seq,$file,$aslocal) = @_; |
05454584 | 2109 | |
2e2b7522 GS |
2110 | # Came back if Net::FTP couldn't establish connection (or |
2111 | # failed otherwise) Maybe they are behind a firewall, but they | |
2112 | # gave us a socksified (or other) ftp program... | |
c356248b | 2113 | |
2e2b7522 | 2114 | my($i); |
f610777f | 2115 | my($devnull) = $CPAN::Config->{devnull} || ""; |
2e2b7522 GS |
2116 | # < /dev/null "; |
2117 | my($aslocal_dir) = File::Basename::dirname($aslocal); | |
2118 | File::Path::mkpath($aslocal_dir); | |
c356248b | 2119 | HOSTHARD: for $i (@$host_seq) { |
09d9d230 | 2120 | my $url = $CPAN::Config->{urllist}[$i] || $CPAN::Defaultsite; |
c356248b A |
2121 | unless ($self->is_reachable($url)) { |
2122 | $CPAN::Frontend->myprint("Skipping $url (not reachable)\n"); | |
2123 | next; | |
2124 | } | |
2125 | $url .= "/" unless substr($url,-1) eq "/"; | |
2126 | $url .= $file; | |
09d9d230 A |
2127 | my($proto,$host,$dir,$getfile); |
2128 | ||
2129 | # Courtesy Mark Conty mark_conty@cargill.com change from | |
2130 | # if ($url =~ m|^ftp://(.*?)/(.*)/(.*)|) { | |
2131 | # to | |
2132 | if ($url =~ m|^([^:]+)://(.*?)/(.*)/(.*)|) { | |
2133 | # proto not yet used | |
2134 | ($proto,$host,$dir,$getfile) = ($1,$2,$3,$4); | |
c356248b A |
2135 | } else { |
2136 | next HOSTHARD; # who said, we could ftp anything except ftp? | |
2137 | } | |
2138 | $self->debug("localizing funkyftpwise[$url]") if $CPAN::DEBUG; | |
2139 | my($f,$funkyftp); | |
2e2b7522 | 2140 | for $f ('lynx','ncftpget','ncftp') { |
c356248b A |
2141 | next unless exists $CPAN::Config->{$f}; |
2142 | $funkyftp = $CPAN::Config->{$f}; | |
05454584 | 2143 | next unless defined $funkyftp; |
55e314ee | 2144 | next if $funkyftp =~ /^\s*$/; |
05454584 | 2145 | my($want_compressed); |
c356248b A |
2146 | my $aslocal_uncompressed; |
2147 | ($aslocal_uncompressed = $aslocal) =~ s/\.gz//; | |
05454584 | 2148 | my($source_switch) = ""; |
2e2b7522 GS |
2149 | $source_switch = " -source" if $funkyftp =~ /\blynx$/; |
2150 | $source_switch = " -c" if $funkyftp =~ /\bncftp$/; | |
c356248b | 2151 | $CPAN::Frontend->myprint( |
2e2b7522 GS |
2152 | qq[ |
2153 | Trying with "$funkyftp$source_switch" to get | |
c356248b | 2154 | $url |
2e2b7522 GS |
2155 | ]); |
2156 | my($system) = "$funkyftp$source_switch '$url' $devnull > ". | |
c356248b | 2157 | "$aslocal_uncompressed"; |
55e314ee | 2158 | $self->debug("system[$system]") if $CPAN::DEBUG; |
05454584 | 2159 | my($wstatus); |
55e314ee A |
2160 | if (($wstatus = system($system)) == 0 |
2161 | && | |
c356248b A |
2162 | -s $aslocal_uncompressed # lynx returns 0 on my |
2163 | # system even if it fails | |
55e314ee | 2164 | ) { |
c356248b | 2165 | if ($aslocal_uncompressed ne $aslocal) { |
09d9d230 A |
2166 | # test gzip integrity |
2167 | if ( | |
2168 | CPAN::Tarzip->gtest($aslocal_uncompressed) | |
2169 | ) { | |
2170 | rename $aslocal_uncompressed, $aslocal; | |
2171 | } else { | |
2172 | CPAN::Tarzip->gzip($aslocal_uncompressed, | |
2173 | "$aslocal_uncompressed.gz"); | |
2174 | } | |
c356248b | 2175 | } |
f610777f A |
2176 | $Thesite = $i; |
2177 | return $aslocal; | |
c356248b | 2178 | } elsif ($url !~ /\.gz$/) { |
2e2b7522 GS |
2179 | unlink $aslocal_uncompressed if |
2180 | -f $aslocal_uncompressed && -s _ == 0; | |
2181 | my $gz = "$aslocal.gz"; | |
2182 | my $gzurl = "$url.gz"; | |
2183 | $CPAN::Frontend->myprint( | |
2184 | qq[ | |
2185 | Trying with "$funkyftp$source_switch" to get | |
c356248b | 2186 | $url.gz |
2e2b7522 GS |
2187 | ]); |
2188 | my($system) = "$funkyftp$source_switch '$url.gz' $devnull > ". | |
2189 | "$aslocal_uncompressed.gz"; | |
2190 | $self->debug("system[$system]") if $CPAN::DEBUG; | |
2191 | my($wstatus); | |
2192 | if (($wstatus = system($system)) == 0 | |
2193 | && | |
2194 | -s "$aslocal_uncompressed.gz" | |
2195 | ) { | |
2196 | # test gzip integrity | |
2197 | if (CPAN::Tarzip->gtest("$aslocal_uncompressed.gz")) { | |
2198 | CPAN::Tarzip->gunzip("$aslocal_uncompressed.gz", | |
2199 | $aslocal); | |
2200 | } else { | |
2201 | rename $aslocal_uncompressed, $aslocal; | |
05454584 | 2202 | } |
2e2b7522 GS |
2203 | $Thesite = $i; |
2204 | return $aslocal; | |
2205 | } else { | |
2206 | unlink "$aslocal_uncompressed.gz" if | |
2207 | -f "$aslocal_uncompressed.gz"; | |
2208 | } | |
05454584 A |
2209 | } else { |
2210 | my $estatus = $wstatus >> 8; | |
c356248b A |
2211 | my $size = -f $aslocal ? ", left\n$aslocal with size ".-s _ : ""; |
2212 | $CPAN::Frontend->myprint(qq{ | |
05454584 | 2213 | System call "$system" |
c356248b A |
2214 | returned status $estatus (wstat $wstatus)$size |
2215 | }); | |
05454584 A |
2216 | } |
2217 | } | |
c356248b A |
2218 | } |
2219 | } | |
05454584 | 2220 | |
c356248b A |
2221 | sub hosthardest { |
2222 | my($self,$host_seq,$file,$aslocal) = @_; | |
2223 | ||
2224 | my($i); | |
2225 | my($aslocal_dir) = File::Basename::dirname($aslocal); | |
2226 | File::Path::mkpath($aslocal_dir); | |
2227 | HOSTHARDEST: for $i (@$host_seq) { | |
2228 | unless (length $CPAN::Config->{'ftp'}) { | |
2229 | $CPAN::Frontend->myprint("No external ftp command available\n\n"); | |
2230 | last HOSTHARDEST; | |
2231 | } | |
09d9d230 | 2232 | my $url = $CPAN::Config->{urllist}[$i] || $CPAN::Defaultsite; |
c356248b A |
2233 | unless ($self->is_reachable($url)) { |
2234 | $CPAN::Frontend->myprint("Skipping $url (not reachable)\n"); | |
2235 | next; | |
2236 | } | |
2237 | $url .= "/" unless substr($url,-1) eq "/"; | |
2238 | $url .= $file; | |
2239 | $self->debug("localizing ftpwise[$url]") if $CPAN::DEBUG; | |
2240 | unless ($url =~ m|^ftp://(.*?)/(.*)/(.*)|) { | |
2241 | next; | |
2242 | } | |
2243 | my($host,$dir,$getfile) = ($1,$2,$3); | |
2244 | my($netrcfile,$fh); | |
2245 | my $timestamp = 0; | |
2246 | my($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime, | |
2247 | $ctime,$blksize,$blocks) = stat($aslocal); | |
2248 | $timestamp = $mtime ||= 0; | |
2249 | my($netrc) = CPAN::FTP::netrc->new; | |
2250 | my($verbose) = $CPAN::DEBUG{'FTP'} & $CPAN::DEBUG ? " -v" : ""; | |
2251 | my $targetfile = File::Basename::basename($aslocal); | |
2252 | my(@dialog); | |
2253 | push( | |
2254 | @dialog, | |
2255 | "lcd $aslocal_dir", | |
2256 | "cd /", | |
2257 | map("cd $_", split "/", $dir), # RFC 1738 | |
2258 | "bin", | |
2259 | "get $getfile $targetfile", | |
2260 | "quit" | |
2261 | ); | |
2262 | if (! $netrc->netrc) { | |
2263 | CPAN->debug("No ~/.netrc file found") if $CPAN::DEBUG; | |
2264 | } elsif ($netrc->hasdefault || $netrc->contains($host)) { | |
2265 | CPAN->debug(sprintf("hasdef[%d]cont($host)[%d]", | |
2266 | $netrc->hasdefault, | |
2267 | $netrc->contains($host))) if $CPAN::DEBUG; | |
2268 | if ($netrc->protected) { | |
2269 | $CPAN::Frontend->myprint(qq{ | |
05454584 A |
2270 | Trying with external ftp to get |
2271 | $url | |
2272 | As this requires some features that are not thoroughly tested, we\'re | |
2273 | not sure, that we get it right.... | |
2274 | ||
2275 | } | |
c356248b A |
2276 | ); |
2277 | $self->talk_ftp("$CPAN::Config->{'ftp'}$verbose $host", | |
2278 | @dialog); | |
05454584 | 2279 | ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size, |
c356248b | 2280 | $atime,$mtime,$ctime,$blksize,$blocks) = stat($aslocal); |
05454584 A |
2281 | $mtime ||= 0; |
2282 | if ($mtime > $timestamp) { | |
c356248b A |
2283 | $CPAN::Frontend->myprint("GOT $aslocal\n"); |
2284 | $Thesite = $i; | |
05454584 A |
2285 | return $aslocal; |
2286 | } else { | |
c356248b | 2287 | $CPAN::Frontend->myprint("Hmm... Still failed!\n"); |
05454584 | 2288 | } |
c356248b A |
2289 | } else { |
2290 | $CPAN::Frontend->mywarn(qq{Your $netrcfile is not }. | |
2291 | qq{correctly protected.\n}); | |
05454584 | 2292 | } |
c356248b A |
2293 | } else { |
2294 | $CPAN::Frontend->mywarn("Your ~/.netrc neither contains $host | |
2295 | nor does it have a default entry\n"); | |
05454584 | 2296 | } |
36263cb3 | 2297 | |
c356248b A |
2298 | # OK, they don't have a valid ~/.netrc. Use 'ftp -n' |
2299 | # then and login manually to host, using e-mail as | |
2300 | # password. | |
2301 | $CPAN::Frontend->myprint(qq{Issuing "$CPAN::Config->{'ftp'}$verbose -n"\n}); | |
2302 | unshift( | |
2303 | @dialog, | |
2304 | "open $host", | |
2305 | "user anonymous $Config::Config{'cf_email'}" | |
2306 | ); | |
2307 | $self->talk_ftp("$CPAN::Config->{'ftp'}$verbose -n", @dialog); | |
2308 | ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size, | |
2309 | $atime,$mtime,$ctime,$blksize,$blocks) = stat($aslocal); | |
2310 | $mtime ||= 0; | |
2311 | if ($mtime > $timestamp) { | |
2312 | $CPAN::Frontend->myprint("GOT $aslocal\n"); | |
2313 | $Thesite = $i; | |
2314 | return $aslocal; | |
2315 | } else { | |
2316 | $CPAN::Frontend->myprint("Bad luck... Still failed!\n"); | |
05454584 | 2317 | } |
c356248b A |
2318 | $CPAN::Frontend->myprint("Can't access URL $url.\n\n"); |
2319 | sleep 2; | |
e50380aa | 2320 | } |
c356248b A |
2321 | } |
2322 | ||
2323 | sub talk_ftp { | |
2324 | my($self,$command,@dialog) = @_; | |
2325 | my $fh = FileHandle->new; | |
2326 | $fh->open("|$command") or die "Couldn't open ftp: $!"; | |
2327 | foreach (@dialog) { $fh->print("$_\n") } | |
2328 | $fh->close; # Wait for process to complete | |
2329 | my $wstatus = $?; | |
2330 | my $estatus = $wstatus >> 8; | |
2331 | $CPAN::Frontend->myprint(qq{ | |
2332 | Subprocess "|$command" | |
2333 | returned status $estatus (wstat $wstatus) | |
2334 | }) if $wstatus; | |
05454584 A |
2335 | } |
2336 | ||
e50380aa A |
2337 | # find2perl needs modularization, too, all the following is stolen |
2338 | # from there | |
09d9d230 | 2339 | # CPAN::FTP::ls |
e50380aa A |
2340 | sub ls { |
2341 | my($self,$name) = @_; | |
2342 | my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$sizemm, | |
2343 | $atime,$mtime,$ctime,$blksize,$blocks) = lstat($name); | |
2344 | ||
2345 | my($perms,%user,%group); | |
2346 | my $pname = $name; | |
2347 | ||
55e314ee | 2348 | if ($blocks) { |
e50380aa A |
2349 | $blocks = int(($blocks + 1) / 2); |
2350 | } | |
2351 | else { | |
2352 | $blocks = int(($sizemm + 1023) / 1024); | |
2353 | } | |
2354 | ||
2355 | if (-f _) { $perms = '-'; } | |
2356 | elsif (-d _) { $perms = 'd'; } | |
2357 | elsif (-c _) { $perms = 'c'; $sizemm = &sizemm; } | |
2358 | elsif (-b _) { $perms = 'b'; $sizemm = &sizemm; } | |
2359 | elsif (-p _) { $perms = 'p'; } | |
2360 | elsif (-S _) { $perms = 's'; } | |
2361 | else { $perms = 'l'; $pname .= ' -> ' . readlink($_); } | |
2362 | ||
2363 | my(@rwx) = ('---','--x','-w-','-wx','r--','r-x','rw-','rwx'); | |
2364 | my(@moname) = qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec); | |
2365 | my $tmpmode = $mode; | |
2366 | my $tmp = $rwx[$tmpmode & 7]; | |
2367 | $tmpmode >>= 3; | |
2368 | $tmp = $rwx[$tmpmode & 7] . $tmp; | |
2369 | $tmpmode >>= 3; | |
2370 | $tmp = $rwx[$tmpmode & 7] . $tmp; | |
2371 | substr($tmp,2,1) =~ tr/-x/Ss/ if -u _; | |
2372 | substr($tmp,5,1) =~ tr/-x/Ss/ if -g _; | |
2373 | substr($tmp,8,1) =~ tr/-x/Tt/ if -k _; | |
2374 | $perms .= $tmp; | |
2375 | ||
2376 | my $user = $user{$uid} || $uid; # too lazy to implement lookup | |
2377 | my $group = $group{$gid} || $gid; | |
2378 | ||
2379 | my($sec,$min,$hour,$mday,$mon,$year) = localtime($mtime); | |
2380 | my($timeyear); | |
2381 | my($moname) = $moname[$mon]; | |
2382 | if (-M _ > 365.25 / 2) { | |
2383 | $timeyear = $year + 1900; | |
2384 | } | |
2385 | else { | |
2386 | $timeyear = sprintf("%02d:%02d", $hour, $min); | |
2387 | } | |
2388 | ||
2389 | sprintf "%5lu %4ld %-10s %2d %-8s %-8s %8s %s %2d %5s %s\n", | |
2390 | $ino, | |
2391 | $blocks, | |
2392 | $perms, | |
2393 | $nlink, | |
2394 | $user, | |
2395 | $group, | |
2396 | $sizemm, | |
2397 | $moname, | |
2398 | $mday, | |
2399 | $timeyear, | |
2400 | $pname; | |
2401 | } | |
2402 | ||
05454584 A |
2403 | package CPAN::FTP::netrc; |
2404 | ||
2405 | sub new { | |
2406 | my($class) = @_; | |
2407 | my $file = MM->catfile($ENV{HOME},".netrc"); | |
2408 | ||
2409 | my($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size, | |
2410 | $atime,$mtime,$ctime,$blksize,$blocks) | |
2411 | = stat($file); | |
2412 | $mode ||= 0; | |
2413 | my $protected = 0; | |
2414 | ||
42d3b621 A |
2415 | my($fh,@machines,$hasdefault); |
2416 | $hasdefault = 0; | |
da199366 A |
2417 | $fh = FileHandle->new or die "Could not create a filehandle"; |
2418 | ||
2419 | if($fh->open($file)){ | |
2420 | $protected = ($mode & 077) == 0; | |
10b2abe6 | 2421 | local($/) = ""; |
42d3b621 | 2422 | NETRC: while (<$fh>) { |
da199366 | 2423 | my(@tokens) = split " ", $_; |
42d3b621 A |
2424 | TOKEN: while (@tokens) { |
2425 | my($t) = shift @tokens; | |
da199366 A |
2426 | if ($t eq "default"){ |
2427 | $hasdefault++; | |
da199366 A |
2428 | last NETRC; |
2429 | } | |
42d3b621 A |
2430 | last TOKEN if $t eq "macdef"; |
2431 | if ($t eq "machine") { | |
2432 | push @machines, shift @tokens; | |
2433 | } | |
2434 | } | |
10b2abe6 CS |
2435 | } |
2436 | } else { | |
da199366 | 2437 | $file = $hasdefault = $protected = ""; |
10b2abe6 | 2438 | } |
da199366 | 2439 | |
10b2abe6 | 2440 | bless { |
42d3b621 A |
2441 | 'mach' => [@machines], |
2442 | 'netrc' => $file, | |
2443 | 'hasdefault' => $hasdefault, | |
da199366 | 2444 | 'protected' => $protected, |
10b2abe6 CS |
2445 | }, $class; |
2446 | } | |
2447 | ||
42d3b621 | 2448 | sub hasdefault { shift->{'hasdefault'} } |
da199366 A |
2449 | sub netrc { shift->{'netrc'} } |
2450 | sub protected { shift->{'protected'} } | |
10b2abe6 CS |
2451 | sub contains { |
2452 | my($self,$mach) = @_; | |
da199366 A |
2453 | for ( @{$self->{'mach'}} ) { |
2454 | return 1 if $_ eq $mach; | |
2455 | } | |
2456 | return 0; | |
10b2abe6 CS |
2457 | } |
2458 | ||
5f05dabc | 2459 | package CPAN::Complete; |
5f05dabc | 2460 | |
36263cb3 GS |
2461 | sub gnu_cpl { |
2462 | my($text, $line, $start, $end) = @_; | |
2463 | my(@perlret) = cpl($text, $line, $start); | |
2464 | # find longest common match. Can anybody show me how to peruse | |
2465 | # T::R::Gnu to have this done automatically? Seems expensive. | |
2466 | return () unless @perlret; | |
2467 | my($newtext) = $text; | |
2468 | for (my $i = length($text)+1;;$i++) { | |
2469 | last unless length($perlret[0]) && length($perlret[0]) >= $i; | |
2470 | my $try = substr($perlret[0],0,$i); | |
2471 | my @tries = grep {substr($_,0,$i) eq $try} @perlret; | |
2472 | # warn "try[$try]tries[@tries]"; | |
2473 | if (@tries == @perlret) { | |
2474 | $newtext = $try; | |
2475 | } else { | |
2476 | last; | |
2477 | } | |
2478 | } | |
2479 | ($newtext,@perlret); | |
2480 | } | |
2481 | ||
55e314ee A |
2482 | #-> sub CPAN::Complete::cpl ; |
2483 | sub cpl { | |
5f05dabc | 2484 | my($word,$line,$pos) = @_; |
2485 | $word ||= ""; | |
2486 | $line ||= ""; | |
2487 | $pos ||= 0; | |
2488 | CPAN->debug("word [$word] line[$line] pos[$pos]") if $CPAN::DEBUG; | |
2489 | $line =~ s/^\s*//; | |
da199366 A |
2490 | if ($line =~ s/^(force\s*)//) { |
2491 | $pos -= length($1); | |
2492 | } | |
5f05dabc | 2493 | my @return; |
2494 | if ($pos == 0) { | |
da199366 A |
2495 | @return = grep( |
2496 | /^$word/, | |
2497 | sort qw( | |
2498 | ! a b d h i m o q r u autobundle clean | |
2499 | make test install force reload look | |
2500 | ) | |
2501 | ); | |
2502 | } elsif ( $line !~ /^[\!abdhimorutl]/ ) { | |
5f05dabc | 2503 | @return = (); |
2504 | } elsif ($line =~ /^a\s/) { | |
55e314ee | 2505 | @return = cplx('CPAN::Author',$word); |
5f05dabc | 2506 | } elsif ($line =~ /^b\s/) { |
55e314ee | 2507 | @return = cplx('CPAN::Bundle',$word); |
5f05dabc | 2508 | } elsif ($line =~ /^d\s/) { |
55e314ee | 2509 | @return = cplx('CPAN::Distribution',$word); |
da199366 | 2510 | } elsif ($line =~ /^([mru]|make|clean|test|install|readme|look)\s/ ) { |
55e314ee | 2511 | @return = (cplx('CPAN::Module',$word),cplx('CPAN::Bundle',$word)); |
5f05dabc | 2512 | } elsif ($line =~ /^i\s/) { |
55e314ee | 2513 | @return = cpl_any($word); |
5f05dabc | 2514 | } elsif ($line =~ /^reload\s/) { |
55e314ee | 2515 | @return = cpl_reload($word,$line,$pos); |
5f05dabc | 2516 | } elsif ($line =~ /^o\s/) { |
55e314ee | 2517 | @return = cpl_option($word,$line,$pos); |
5f05dabc | 2518 | } else { |
2519 | @return = (); | |
2520 | } | |
2521 | return @return; | |
2522 | } | |
2523 | ||
55e314ee A |
2524 | #-> sub CPAN::Complete::cplx ; |
2525 | sub cplx { | |
5f05dabc | 2526 | my($class, $word) = @_; |
36263cb3 | 2527 | grep /^\Q$word\E/, map { $_->id } $CPAN::META->all_objects($class); |
5f05dabc | 2528 | } |
2529 | ||
55e314ee A |
2530 | #-> sub CPAN::Complete::cpl_any ; |
2531 | sub cpl_any { | |
5f05dabc | 2532 | my($word) = shift; |
2533 | return ( | |
55e314ee A |
2534 | cplx('CPAN::Author',$word), |
2535 | cplx('CPAN::Bundle',$word), | |
2536 | cplx('CPAN::Distribution',$word), | |
2537 | cplx('CPAN::Module',$word), | |
5f05dabc | 2538 | ); |
2539 | } | |
2540 | ||
55e314ee A |
2541 | #-> sub CPAN::Complete::cpl_reload ; |
2542 | sub cpl_reload { | |
5f05dabc | 2543 | my($word,$line,$pos) = @_; |
2544 | $word ||= ""; | |
2545 | my(@words) = split " ", $line; | |
2546 | CPAN->debug("word[$word] line[$line] pos[$pos]") if $CPAN::DEBUG; | |
2547 | my(@ok) = qw(cpan index); | |
e50380aa A |
2548 | return @ok if @words == 1; |
2549 | return grep /^\Q$word\E/, @ok if @words == 2 && $word; | |
5f05dabc | 2550 | } |
2551 | ||
55e314ee A |
2552 | #-> sub CPAN::Complete::cpl_option ; |
2553 | sub cpl_option { | |
5f05dabc | 2554 | my($word,$line,$pos) = @_; |
2555 | $word ||= ""; | |
2556 | my(@words) = split " ", $line; | |
2557 | CPAN->debug("word[$word] line[$line] pos[$pos]") if $CPAN::DEBUG; | |
2558 | my(@ok) = qw(conf debug); | |
e50380aa | 2559 | return @ok if @words == 1; |
c356248b | 2560 | return grep /^\Q$word\E/, @ok if @words == 2 && length($word); |
5f05dabc | 2561 | if (0) { |
2562 | } elsif ($words[1] eq 'index') { | |
2563 | return (); | |
2564 | } elsif ($words[1] eq 'conf') { | |
55e314ee | 2565 | return CPAN::Config::cpl(@_); |
5f05dabc | 2566 | } elsif ($words[1] eq 'debug') { |
2567 | return sort grep /^\Q$word\E/, sort keys %CPAN::DEBUG, 'all'; | |
2568 | } | |
2569 | } | |
2570 | ||
2571 | package CPAN::Index; | |
5f05dabc | 2572 | |
10b2abe6 | 2573 | #-> sub CPAN::Index::force_reload ; |
5f05dabc | 2574 | sub force_reload { |
2575 | my($class) = @_; | |
2576 | $CPAN::Index::last_time = 0; | |
2577 | $class->reload(1); | |
2578 | } | |
2579 | ||
10b2abe6 | 2580 | #-> sub CPAN::Index::reload ; |
5f05dabc | 2581 | sub reload { |
2582 | my($cl,$force) = @_; | |
2583 | my $time = time; | |
2584 | ||
c356248b A |
2585 | # XXX check if a newer one is available. (We currently read it |
2586 | # from time to time) | |
e50380aa | 2587 | for ($CPAN::Config->{index_expire}) { |
36263cb3 | 2588 | $_ = 0.001 unless $_ && $_ > 0.001; |
e50380aa | 2589 | } |
c356248b A |
2590 | return if $last_time + $CPAN::Config->{index_expire}*86400 > $time |
2591 | and ! $force; | |
e50380aa | 2592 | my($debug,$t2); |
5f05dabc | 2593 | $last_time = $time; |
2594 | ||
c356248b A |
2595 | my $needshort = $^O eq "dos"; |
2596 | ||
f14b5cec JH |
2597 | $cl->rd_authindex($cl |
2598 | ->reload_x( | |
2599 | "authors/01mailrc.txt.gz", | |
2600 | $needshort ? | |
2601 | File::Spec->catfile('authors', '01mailrc.gz') : | |
2602 | File::Spec->catfile('authors', '01mailrc.txt.gz'), | |
2603 | $force)); | |
e50380aa A |
2604 | $t2 = time; |
2605 | $debug = "timing reading 01[".($t2 - $time)."]"; | |
2606 | $time = $t2; | |
5f05dabc | 2607 | return if $CPAN::Signal; # this is sometimes lengthy |
f14b5cec JH |
2608 | $cl->rd_modpacks($cl |
2609 | ->reload_x( | |
2610 | "modules/02packages.details.txt.gz", | |
2611 | $needshort ? | |
2612 | File::Spec->catfile('modules', '02packag.gz') : | |
2613 | File::Spec->catfile('modules', '02packages.details.txt.gz'), | |
2614 | $force)); | |
e50380aa A |
2615 | $t2 = time; |
2616 | $debug .= "02[".($t2 - $time)."]"; | |
2617 | $time = $t2; | |
5f05dabc | 2618 | return if $CPAN::Signal; # this is sometimes lengthy |
f14b5cec JH |
2619 | $cl->rd_modlist($cl |
2620 | ->reload_x( | |
2621 | "modules/03modlist.data.gz", | |
2622 | $needshort ? | |
2623 | File::Spec->catfile('modules', '03mlist.gz') : | |
2624 | File::Spec->catfile('modules', '03modlist.data.gz'), | |
2625 | $force)); | |
e50380aa A |
2626 | $t2 = time; |
2627 | $debug .= "03[".($t2 - $time)."]"; | |
2628 | $time = $t2; | |
2629 | CPAN->debug($debug) if $CPAN::DEBUG; | |
5f05dabc | 2630 | } |
2631 | ||
10b2abe6 | 2632 | #-> sub CPAN::Index::reload_x ; |
5f05dabc | 2633 | sub reload_x { |
2634 | my($cl,$wanted,$localname,$force) = @_; | |
c356248b | 2635 | $force |= 2; # means we're dealing with an index here |
55e314ee A |
2636 | CPAN::Config->load; # we should guarantee loading wherever we rely |
2637 | # on Config XXX | |
c356248b A |
2638 | $localname ||= $wanted; |
2639 | my $abs_wanted = MM->catfile($CPAN::Config->{'keep_source_where'}, | |
55e314ee | 2640 | $localname); |
e50380aa A |
2641 | if ( |
2642 | -f $abs_wanted && | |
05454584 | 2643 | -M $abs_wanted < $CPAN::Config->{'index_expire'} && |
c356248b | 2644 | !($force & 1) |
e50380aa A |
2645 | ) { |
2646 | my $s = $CPAN::Config->{'index_expire'} == 1 ? "" : "s"; | |
05454584 | 2647 | $cl->debug(qq{$abs_wanted younger than $CPAN::Config->{'index_expire'} }. |
e50380aa | 2648 | qq{day$s. I\'ll use that.}); |
5f05dabc | 2649 | return $abs_wanted; |
2650 | } else { | |
c356248b | 2651 | $force |= 1; # means we're quite serious about it. |
5f05dabc | 2652 | } |
2653 | return CPAN::FTP->localize($wanted,$abs_wanted,$force); | |
2654 | } | |
2655 | ||
55e314ee A |
2656 | #-> sub CPAN::Index::rd_authindex ; |
2657 | sub rd_authindex { | |
f14b5cec JH |
2658 | my($cl, $index_target) = @_; |
2659 | my @lines; | |
c356248b | 2660 | return unless defined $index_target; |
c356248b | 2661 | $CPAN::Frontend->myprint("Going to read $index_target\n"); |
09d9d230 A |
2662 | # my $fh = CPAN::Tarzip->TIEHANDLE($index_target); |
2663 | # while ($_ = $fh->READLINE) { | |
2664 | # no strict 'refs'; | |
2665 | local(*FH); | |
2666 | tie *FH, CPAN::Tarzip, $index_target; | |
52128c7b | 2667 | local($/) = "\n"; |
f14b5cec JH |
2668 | push @lines, split /\012/ while <FH>; |
2669 | foreach (@lines) { | |
c356248b | 2670 | my($userid,$fullname,$email) = |
f610777f | 2671 | m/alias\s+(\S+)\s+\"([^\"\<]+)\s+\<([^\>]+)\>\"/; |
5f05dabc | 2672 | next unless $userid && $fullname && $email; |
2673 | ||
2674 | # instantiate an author object | |
2675 | my $userobj = $CPAN::META->instance('CPAN::Author',$userid); | |
2676 | $userobj->set('FULLNAME' => $fullname, 'EMAIL' => $email); | |
2677 | return if $CPAN::Signal; | |
2678 | } | |
09d9d230 A |
2679 | } |
2680 | ||
2681 | sub userid { | |
2682 | my($self,$dist) = @_; | |
2683 | $dist = $self->{'id'} unless defined $dist; | |
2684 | my($ret) = $dist =~ m|(?:\w/\w\w/)?([^/]+)/|; | |
2685 | $ret; | |
5f05dabc | 2686 | } |
2687 | ||
55e314ee A |
2688 | #-> sub CPAN::Index::rd_modpacks ; |
2689 | sub rd_modpacks { | |
f14b5cec JH |
2690 | my($cl, $index_target) = @_; |
2691 | my @lines; | |
c356248b | 2692 | return unless defined $index_target; |
c356248b | 2693 | $CPAN::Frontend->myprint("Going to read $index_target\n"); |
09d9d230 | 2694 | my $fh = CPAN::Tarzip->TIEHANDLE($index_target); |
52128c7b | 2695 | local($/) = "\n"; |
09d9d230 | 2696 | while ($_ = $fh->READLINE) { |
f14b5cec JH |
2697 | s/\012/\n/g; |
2698 | my @ls = map {"$_\n"} split /\n/, $_; | |
2699 | unshift @ls, "\n" x length($1) if /^(\n+)/; | |
2700 | push @lines, @ls; | |
e50380aa | 2701 | } |
f14b5cec JH |
2702 | while (@lines) { |
2703 | my $shift = shift(@lines); | |
2704 | last if $shift =~ /^\s*$/; | |
2705 | } | |
2706 | foreach (@lines) { | |
5f05dabc | 2707 | chomp; |
2708 | my($mod,$version,$dist) = split; | |
e50380aa | 2709 | ### $version =~ s/^\+//; |
5f05dabc | 2710 | |
09d9d230 | 2711 | # if it is a bundle, instatiate a bundle object |
e50380aa | 2712 | my($bundle,$id,$userid); |
f610777f | 2713 | |
09d9d230 A |
2714 | if ($mod eq 'CPAN' && |
2715 | ! ( | |
f610777f A |
2716 | CPAN::Queue->exists('Bundle::CPAN') || |
2717 | CPAN::Queue->exists('CPAN') | |
09d9d230 A |
2718 | ) |
2719 | ) { | |
e50380aa | 2720 | local($^W)= 0; |
5f05dabc | 2721 | if ($version > $CPAN::VERSION){ |
c356248b | 2722 | $CPAN::Frontend->myprint(qq{ |
e50380aa A |
2723 | There\'s a new CPAN.pm version (v$version) available! |
2724 | You might want to try | |
09d9d230 | 2725 | install Bundle::CPAN |
5f05dabc | 2726 | reload cpan |
c356248b | 2727 | without quitting the current session. It should be a seamless upgrade |
05454584 | 2728 | while we are running... |
c356248b | 2729 | }); |
05454584 | 2730 | sleep 2; |
c356248b | 2731 | $CPAN::Frontend->myprint(qq{\n}); |
5f05dabc | 2732 | } |
05454584 | 2733 | last if $CPAN::Signal; |
e50380aa A |
2734 | } elsif ($mod =~ /^Bundle::(.*)/) { |
2735 | $bundle = $1; | |
5f05dabc | 2736 | } |
05454584 | 2737 | |
05454584 A |
2738 | if ($bundle){ |
2739 | $id = $CPAN::META->instance('CPAN::Bundle',$mod); | |
2e2b7522 | 2740 | # warn "made mod[$mod]a bundle"; |
c356248b A |
2741 | # Let's make it a module too, because bundles have so much |
2742 | # in common with modules | |
2743 | $CPAN::META->instance('CPAN::Module',$mod); | |
2e2b7522 | 2744 | # warn "made mod[$mod]a module"; |
c356248b | 2745 | |
05454584 A |
2746 | # This "next" makes us faster but if the job is running long, we ignore |
2747 | # rereads which is bad. So we have to be a bit slower again. | |
2748 | # } elsif ($CPAN::META->exists('CPAN::Module',$mod)) { | |
2749 | # next; | |
c356248b A |
2750 | |
2751 | } | |
2752 | else { | |
05454584 A |
2753 | # instantiate a module object |
2754 | $id = $CPAN::META->instance('CPAN::Module',$mod); | |
5f05dabc | 2755 | } |
5f05dabc | 2756 | |
e50380aa | 2757 | if ($id->cpan_file ne $dist){ |
09d9d230 | 2758 | $userid = $cl->userid($dist); |
e50380aa A |
2759 | $id->set( |
2760 | 'CPAN_USERID' => $userid, | |
2761 | 'CPAN_VERSION' => $version, | |
2762 | 'CPAN_FILE' => $dist | |
2763 | ); | |
2764 | } | |
05454584 A |
2765 | |
2766 | # instantiate a distribution object | |
2767 | unless ($CPAN::META->exists('CPAN::Distribution',$dist)) { | |
2768 | $CPAN::META->instance( | |
2769 | 'CPAN::Distribution' => $dist | |
2770 | )->set( | |
2771 | 'CPAN_USERID' => $userid | |
e50380aa | 2772 | ); |
5f05dabc | 2773 | } |
05454584 A |
2774 | |
2775 | return if $CPAN::Signal; | |
5f05dabc | 2776 | } |
09d9d230 | 2777 | undef $fh; |
5f05dabc | 2778 | } |
2779 | ||
55e314ee A |
2780 | #-> sub CPAN::Index::rd_modlist ; |
2781 | sub rd_modlist { | |
05454584 | 2782 | my($cl,$index_target) = @_; |
c356248b | 2783 | return unless defined $index_target; |
c356248b | 2784 | $CPAN::Frontend->myprint("Going to read $index_target\n"); |
09d9d230 A |
2785 | my $fh = CPAN::Tarzip->TIEHANDLE($index_target); |
2786 | my @eval; | |
52128c7b | 2787 | local($/) = "\n"; |
09d9d230 | 2788 | while ($_ = $fh->READLINE) { |
f14b5cec JH |
2789 | s/\012/\n/g; |
2790 | my @ls = map {"$_\n"} split /\n/, $_; | |
2791 | unshift @ls, "\n" x length($1) if /^(\n+)/; | |
2792 | push @eval, @ls; | |
2793 | } | |
2794 | while (@eval) { | |
2795 | my $shift = shift(@eval); | |
2796 | if ($shift =~ /^Date:\s+(.*)/){ | |
e50380aa A |
2797 | return if $date_of_03 eq $1; |
2798 | ($date_of_03) = $1; | |
2799 | } | |
f14b5cec | 2800 | last if $shift =~ /^\s*$/; |
05454584 | 2801 | } |
09d9d230 A |
2802 | undef $fh; |
2803 | push @eval, q{CPAN::Modulelist->data;}; | |
05454584 A |
2804 | local($^W) = 0; |
2805 | my($comp) = Safe->new("CPAN::Safe1"); | |
09d9d230 | 2806 | my($eval) = join("", @eval); |
05454584 A |
2807 | my $ret = $comp->reval($eval); |
2808 | Carp::confess($@) if $@; | |
2809 | return if $CPAN::Signal; | |
2810 | for (keys %$ret) { | |
2811 | my $obj = $CPAN::META->instance(CPAN::Module,$_); | |
2812 | $obj->set(%{$ret->{$_}}); | |
2813 | return if $CPAN::Signal; | |
2814 | } | |
2815 | } | |
5f05dabc | 2816 | |
05454584 | 2817 | package CPAN::InfoObj; |
5f05dabc | 2818 | |
05454584 A |
2819 | #-> sub CPAN::InfoObj::new ; |
2820 | sub new { my $this = bless {}, shift; %$this = @_; $this } | |
5f05dabc | 2821 | |
05454584 A |
2822 | #-> sub CPAN::InfoObj::set ; |
2823 | sub set { | |
2824 | my($self,%att) = @_; | |
2825 | my(%oldatt) = %$self; | |
2826 | %$self = (%oldatt, %att); | |
da199366 A |
2827 | } |
2828 | ||
05454584 A |
2829 | #-> sub CPAN::InfoObj::id ; |
2830 | sub id { shift->{'ID'} } | |
5f05dabc | 2831 | |
05454584 A |
2832 | #-> sub CPAN::InfoObj::as_glimpse ; |
2833 | sub as_glimpse { | |
5f05dabc | 2834 | my($self) = @_; |
05454584 A |
2835 | my(@m); |
2836 | my $class = ref($self); | |
2837 | $class =~ s/^CPAN:://; | |
2838 | push @m, sprintf "%-15s %s\n", $class, $self->{ID}; | |
2839 | join "", @m; | |
5f05dabc | 2840 | } |
2841 | ||
05454584 A |
2842 | #-> sub CPAN::InfoObj::as_string ; |
2843 | sub as_string { | |
2844 | my($self) = @_; | |
2845 | my(@m); | |
2846 | my $class = ref($self); | |
2847 | $class =~ s/^CPAN:://; | |
2848 | push @m, $class, " id = $self->{ID}\n"; | |
2849 | for (sort keys %$self) { | |
2850 | next if $_ eq 'ID'; | |
2851 | my $extra = ""; | |
09d9d230 A |
2852 | if ($_ eq "CPAN_USERID") { |
2853 | $extra .= " (".$self->author; | |
2854 | my $email; # old perls! | |
2855 | if ($email = $CPAN::META->instance(CPAN::Author, | |
2856 | $self->{$_} | |
2857 | )->email) { | |
2858 | $extra .= " <$email>"; | |
2859 | } else { | |
2860 | $extra .= " <no email>"; | |
2861 | } | |
2862 | $extra .= ")"; | |
2863 | } | |
2864 | if (ref($self->{$_}) eq "ARRAY") { # language interface? XXX | |
05454584 | 2865 | push @m, sprintf " %-12s %s%s\n", $_, "@{$self->{$_}}", $extra; |
5f05dabc | 2866 | } else { |
05454584 A |
2867 | push @m, sprintf " %-12s %s%s\n", $_, $self->{$_}, $extra; |
2868 | } | |
5f05dabc | 2869 | } |
05454584 | 2870 | join "", @m, "\n"; |
5f05dabc | 2871 | } |
2872 | ||
05454584 A |
2873 | #-> sub CPAN::InfoObj::author ; |
2874 | sub author { | |
2875 | my($self) = @_; | |
2876 | $CPAN::META->instance(CPAN::Author,$self->{CPAN_USERID})->fullname; | |
5f05dabc | 2877 | } |
2878 | ||
36263cb3 GS |
2879 | sub dump { |
2880 | my($self) = @_; | |
2881 | require Data::Dumper; | |
2882 | Data::Dumper::Dumper($self); | |
2883 | } | |
2884 | ||
05454584 | 2885 | package CPAN::Author; |
05454584 A |
2886 | |
2887 | #-> sub CPAN::Author::as_glimpse ; | |
2888 | sub as_glimpse { | |
5f05dabc | 2889 | my($self) = @_; |
05454584 A |
2890 | my(@m); |
2891 | my $class = ref($self); | |
2892 | $class =~ s/^CPAN:://; | |
2893 | push @m, sprintf "%-15s %s (%s)\n", $class, $self->{ID}, $self->fullname; | |
2894 | join "", @m; | |
5f05dabc | 2895 | } |
2896 | ||
05454584 A |
2897 | # Dead code, I would have liked to have,,, but it was never reached,,, |
2898 | #sub make { | |
2899 | # my($self) = @_; | |
2900 | # return "Don't be silly, you can't make $self->{FULLNAME} ;-)\n"; | |
2901 | #} | |
5f05dabc | 2902 | |
05454584 A |
2903 | #-> sub CPAN::Author::fullname ; |
2904 | sub fullname { shift->{'FULLNAME'} } | |
2905 | *name = \&fullname; | |
36263cb3 | 2906 | |
05454584 A |
2907 | #-> sub CPAN::Author::email ; |
2908 | sub email { shift->{'EMAIL'} } | |
5f05dabc | 2909 | |
05454584 | 2910 | package CPAN::Distribution; |
5f05dabc | 2911 | |
05454584 A |
2912 | #-> sub CPAN::Distribution::called_for ; |
2913 | sub called_for { | |
2914 | my($self,$id) = @_; | |
2915 | $self->{'CALLED_FOR'} = $id if defined $id; | |
2916 | return $self->{'CALLED_FOR'}; | |
5f05dabc | 2917 | } |
2918 | ||
05454584 A |
2919 | #-> sub CPAN::Distribution::get ; |
2920 | sub get { | |
5f05dabc | 2921 | my($self) = @_; |
da199366 A |
2922 | EXCUSE: { |
2923 | my @e; | |
05454584 A |
2924 | exists $self->{'build_dir'} and push @e, |
2925 | "Unwrapped into directory $self->{'build_dir'}"; | |
c356248b | 2926 | $CPAN::Frontend->myprint(join "", map {" $_\n"} @e) and return if @e; |
da199366 | 2927 | } |
05454584 A |
2928 | my($local_file); |
2929 | my($local_wanted) = | |
c356248b | 2930 | MM->catfile( |
05454584 A |
2931 | $CPAN::Config->{keep_source_where}, |
2932 | "authors", | |
2933 | "id", | |
2934 | split("/",$self->{ID}) | |
2935 | ); | |
2936 | ||
2937 | $self->debug("Doing localize") if $CPAN::DEBUG; | |
c356248b A |
2938 | $local_file = |
2939 | CPAN::FTP->localize("authors/id/$self->{ID}", $local_wanted) | |
2940 | or $CPAN::Frontend->mydie("Giving up on '$local_wanted'\n"); | |
05454584 A |
2941 | $self->{localfile} = $local_file; |
2942 | my $builddir = $CPAN::META->{cachemgr}->dir; | |
2943 | $self->debug("doing chdir $builddir") if $CPAN::DEBUG; | |
2944 | chdir $builddir or Carp::croak("Couldn't chdir $builddir: $!"); | |
2945 | my $packagedir; | |
2946 | ||
2947 | $self->debug("local_file[$local_file]") if $CPAN::DEBUG; | |
55e314ee A |
2948 | if ($CPAN::META->has_inst('MD5')) { |
2949 | $self->debug("MD5 is installed, verifying"); | |
05454584 | 2950 | $self->verifyMD5; |
55e314ee A |
2951 | } else { |
2952 | $self->debug("MD5 is NOT installed"); | |
2953 | } | |
2954 | $self->debug("Removing tmp") if $CPAN::DEBUG; | |
2955 | File::Path::rmtree("tmp"); | |
2956 | mkdir "tmp", 0755 or Carp::croak "Couldn't mkdir tmp: $!"; | |
2957 | chdir "tmp"; | |
2958 | $self->debug("Changed directory to tmp") if $CPAN::DEBUG; | |
c356248b A |
2959 | if (! $local_file) { |
2960 | Carp::croak "bad download, can't do anything :-(\n"; | |
2961 | } elsif ($local_file =~ /(\.tar\.(gz|Z)|\.tgz)$/i){ | |
55e314ee A |
2962 | $self->untar_me($local_file); |
2963 | } elsif ( $local_file =~ /\.zip$/i ) { | |
2964 | $self->unzip_me($local_file); | |
2965 | } elsif ( $local_file =~ /\.pm\.(gz|Z)$/) { | |
2966 | $self->pm2dir_me($local_file); | |
2967 | } else { | |
2968 | $self->{archived} = "NO"; | |
5f05dabc | 2969 | } |
f14b5cec | 2970 | chdir File::Spec->updir; |
55e314ee | 2971 | if ($self->{archived} ne 'NO') { |
f14b5cec | 2972 | chdir File::Spec->catdir(File::Spec->curdir, "tmp"); |
05454584 | 2973 | # Let's check if the package has its own directory. |
f14b5cec JH |
2974 | my $dh = DirHandle->new(File::Spec->curdir) |
2975 | or Carp::croak("Couldn't opendir .: $!"); | |
55e314ee A |
2976 | my @readdir = grep $_ !~ /^\.\.?$/, $dh->read; ### MAC?? |
2977 | $dh->close; | |
05454584 A |
2978 | my ($distdir,$packagedir); |
2979 | if (@readdir == 1 && -d $readdir[0]) { | |
2980 | $distdir = $readdir[0]; | |
c356248b A |
2981 | $packagedir = MM->catdir($builddir,$distdir); |
2982 | -d $packagedir and $CPAN::Frontend->myprint("Removing previously used $packagedir\n"); | |
05454584 A |
2983 | File::Path::rmtree($packagedir); |
2984 | rename($distdir,$packagedir) or Carp::confess("Couldn't rename $distdir to $packagedir: $!"); | |
2985 | } else { | |
2986 | my $pragmatic_dir = $self->{'CPAN_USERID'} . '000'; | |
2987 | $pragmatic_dir =~ s/\W_//g; | |
2988 | $pragmatic_dir++ while -d "../$pragmatic_dir"; | |
c356248b | 2989 | $packagedir = MM->catdir($builddir,$pragmatic_dir); |
05454584 A |
2990 | File::Path::mkpath($packagedir); |
2991 | my($f); | |
2992 | for $f (@readdir) { # is already without "." and ".." | |
c356248b | 2993 | my $to = MM->catdir($packagedir,$f); |
05454584 A |
2994 | rename($f,$to) or Carp::confess("Couldn't rename $f to $to: $!"); |
2995 | } | |
2996 | } | |
2997 | $self->{'build_dir'} = $packagedir; | |
f14b5cec | 2998 | chdir File::Spec->updir; |
55e314ee | 2999 | |
05454584 A |
3000 | $self->debug("Changed directory to .. (self is $self [".$self->as_string."])") |
3001 | if $CPAN::DEBUG; | |
3002 | File::Path::rmtree("tmp"); | |
3003 | if ($CPAN::Config->{keep_source_where} =~ /^no/i ){ | |
c356248b | 3004 | $CPAN::Frontend->myprint("Going to unlink $local_file\n"); |
05454584 A |
3005 | unlink $local_file or Carp::carp "Couldn't unlink $local_file"; |
3006 | } | |
c356248b | 3007 | my($makefilepl) = MM->catfile($packagedir,"Makefile.PL"); |
05454584 | 3008 | unless (-f $makefilepl) { |
09d9d230 A |
3009 | my($configure) = MM->catfile($packagedir,"Configure"); |
3010 | if (-f $configure) { | |
3011 | # do we have anything to do? | |
3012 | $self->{'configure'} = $configure; | |
3013 | } elsif (-f MM->catfile($packagedir,"Makefile")) { | |
3014 | $CPAN::Frontend->myprint(qq{ | |
3015 | Package comes with a Makefile and without a Makefile.PL. | |
3016 | We\'ll try to build it with that Makefile then. | |
3017 | }); | |
3018 | $self->{writemakefile} = "YES"; | |
3019 | sleep 2; | |
3020 | } else { | |
3021 | my $fh = FileHandle->new(">$makefilepl") | |
3022 | or Carp::croak("Could not open >$makefilepl"); | |
3023 | my $cf = $self->called_for || "unknown"; | |
3024 | $fh->print( | |
55e314ee A |
3025 | qq{# This Makefile.PL has been autogenerated by the module CPAN.pm |
3026 | # because there was no Makefile.PL supplied. | |
05454584 | 3027 | # Autogenerated on: }.scalar localtime().qq{ |
55e314ee | 3028 | |
09d9d230 A |
3029 | use ExtUtils::MakeMaker; |
3030 | WriteMakefile(NAME => q[$cf]); | |
55e314ee | 3031 | |
05454584 | 3032 | }); |
09d9d230 A |
3033 | $CPAN::Frontend->myprint(qq{Package comes without Makefile.PL. |
3034 | Writing one on our own (calling it $cf)\n}); | |
05454584 A |
3035 | } |
3036 | } | |
5f05dabc | 3037 | } |
05454584 | 3038 | return $self; |
5f05dabc | 3039 | } |
3040 | ||
55e314ee A |
3041 | sub untar_me { |
3042 | my($self,$local_file) = @_; | |
3043 | $self->{archived} = "tar"; | |
09d9d230 | 3044 | if (CPAN::Tarzip->untar($local_file)) { |
55e314ee A |
3045 | $self->{unwrapped} = "YES"; |
3046 | } else { | |
3047 | $self->{unwrapped} = "NO"; | |
3048 | } | |
3049 | } | |
3050 | ||
3051 | sub unzip_me { | |
3052 | my($self,$local_file) = @_; | |
3053 | $self->{archived} = "zip"; | |
3054 | my $system = "$CPAN::Config->{unzip} $local_file"; | |
3055 | if (system($system) == 0) { | |
3056 | $self->{unwrapped} = "YES"; | |
3057 | } else { | |
3058 | $self->{unwrapped} = "NO"; | |
3059 | } | |
3060 | } | |
3061 | ||
3062 | sub pm2dir_me { | |
3063 | my($self,$local_file) = @_; | |
3064 | $self->{archived} = "pm"; | |
3065 | my $to = File::Basename::basename($local_file); | |
3066 | $to =~ s/\.(gz|Z)$//; | |
09d9d230 | 3067 | if (CPAN::Tarzip->gunzip($local_file,$to)) { |
55e314ee A |
3068 | $self->{unwrapped} = "YES"; |
3069 | } else { | |
3070 | $self->{unwrapped} = "NO"; | |
3071 | } | |
3072 | } | |
3073 | ||
05454584 A |
3074 | #-> sub CPAN::Distribution::new ; |
3075 | sub new { | |
3076 | my($class,%att) = @_; | |
5f05dabc | 3077 | |
05454584 | 3078 | $CPAN::META->{cachemgr} ||= CPAN::CacheMgr->new(); |
5f05dabc | 3079 | |
05454584 A |
3080 | my $this = { %att }; |
3081 | return bless $this, $class; | |
5f05dabc | 3082 | } |
3083 | ||
05454584 A |
3084 | #-> sub CPAN::Distribution::look ; |
3085 | sub look { | |
5f05dabc | 3086 | my($self) = @_; |
36263cb3 GS |
3087 | |
3088 | if ($^O eq 'MacOS') { | |
3089 | $self->ExtUtils::MM_MacOS::look; | |
3090 | return; | |
3091 | } | |
3092 | ||
05454584 | 3093 | if ( $CPAN::Config->{'shell'} ) { |
c356248b | 3094 | $CPAN::Frontend->myprint(qq{ |
05454584 | 3095 | Trying to open a subshell in the build directory... |
c356248b | 3096 | }); |
05454584 | 3097 | } else { |
c356248b | 3098 | $CPAN::Frontend->myprint(qq{ |
05454584 A |
3099 | Your configuration does not define a value for subshells. |
3100 | Please define it with "o conf shell <your shell>" | |
c356248b | 3101 | }); |
05454584 | 3102 | return; |
5f05dabc | 3103 | } |
05454584 A |
3104 | my $dist = $self->id; |
3105 | my $dir = $self->dir or $self->get; | |
3106 | $dir = $self->dir; | |
e50380aa A |
3107 | my $getcwd; |
3108 | $getcwd = $CPAN::Config->{'getcwd'} || 'cwd'; | |
55e314ee | 3109 | my $pwd = CPAN->$getcwd(); |
05454584 | 3110 | chdir($dir); |
c356248b A |
3111 | $CPAN::Frontend->myprint(qq{Working directory is $dir\n}); |
3112 | system($CPAN::Config->{'shell'}) == 0 | |
3113 | or $CPAN::Frontend->mydie("Subprocess shell error"); | |
05454584 | 3114 | chdir($pwd); |
5f05dabc | 3115 | } |
3116 | ||
05454584 A |
3117 | #-> sub CPAN::Distribution::readme ; |
3118 | sub readme { | |
5f05dabc | 3119 | my($self) = @_; |
05454584 A |
3120 | my($dist) = $self->id; |
3121 | my($sans,$suffix) = $dist =~ /(.+)\.(tgz|tar[\._-]gz|tar\.Z|zip)$/; | |
3122 | $self->debug("sans[$sans] suffix[$suffix]\n") if $CPAN::DEBUG; | |
3123 | my($local_file); | |
3124 | my($local_wanted) = | |
c356248b | 3125 | MM->catfile( |
05454584 A |
3126 | $CPAN::Config->{keep_source_where}, |
3127 | "authors", | |
3128 | "id", | |
3129 | split("/","$sans.readme"), | |
3130 | ); | |
3131 | $self->debug("Doing localize") if $CPAN::DEBUG; | |
c356248b A |
3132 | $local_file = CPAN::FTP->localize("authors/id/$sans.readme", |
3133 | $local_wanted) | |
3134 | or $CPAN::Frontend->mydie(qq{No $sans.readme found});; | |
f14b5cec JH |
3135 | |
3136 | if ($^O eq 'MacOS') { | |
3137 | ExtUtils::MM_MacOS::launch_file($local_file); | |
3138 | return; | |
3139 | } | |
3140 | ||
05454584 | 3141 | my $fh_pager = FileHandle->new; |
c356248b | 3142 | local($SIG{PIPE}) = "IGNORE"; |
05454584 A |
3143 | $fh_pager->open("|$CPAN::Config->{'pager'}") |
3144 | or die "Could not open pager $CPAN::Config->{'pager'}: $!"; | |
3145 | my $fh_readme = FileHandle->new; | |
c356248b A |
3146 | $fh_readme->open($local_file) |
3147 | or $CPAN::Frontend->mydie(qq{Could not open "$local_file": $!}); | |
3148 | $CPAN::Frontend->myprint(qq{ | |
3149 | Displaying file | |
3150 | $local_file | |
3151 | with pager "$CPAN::Config->{'pager'}" | |
3152 | }); | |
3153 | sleep 2; | |
05454584 | 3154 | $fh_pager->print(<$fh_readme>); |
5f05dabc | 3155 | } |
3156 | ||
05454584 A |
3157 | #-> sub CPAN::Distribution::verifyMD5 ; |
3158 | sub verifyMD5 { | |
5f05dabc | 3159 | my($self) = @_; |
05454584 A |
3160 | EXCUSE: { |
3161 | my @e; | |
3162 | $self->{MD5_STATUS} ||= ""; | |
3163 | $self->{MD5_STATUS} eq "OK" and push @e, "MD5 Checksum was ok"; | |
c356248b | 3164 | $CPAN::Frontend->myprint(join "", map {" $_\n"} @e) and return if @e; |
05454584 | 3165 | } |
55e314ee A |
3166 | my($lc_want,$lc_file,@local,$basename); |
3167 | @local = split("/",$self->{ID}); | |
3168 | pop @local; | |
05454584 | 3169 | push @local, "CHECKSUMS"; |
55e314ee | 3170 | $lc_want = |
c356248b | 3171 | MM->catfile($CPAN::Config->{keep_source_where}, |
55e314ee | 3172 | "authors", "id", @local); |
05454584 A |
3173 | local($") = "/"; |
3174 | if ( | |
c356248b | 3175 | -s $lc_want |
05454584 | 3176 | && |
55e314ee | 3177 | $self->MD5_check_file($lc_want) |
05454584 A |
3178 | ) { |
3179 | return $self->{MD5_STATUS} = "OK"; | |
3180 | } | |
55e314ee | 3181 | $lc_file = CPAN::FTP->localize("authors/id/@local", |
c356248b | 3182 | $lc_want,1); |
55e314ee | 3183 | unless ($lc_file) { |
05454584 | 3184 | $local[-1] .= ".gz"; |
55e314ee | 3185 | $lc_file = CPAN::FTP->localize("authors/id/@local", |
c356248b A |
3186 | "$lc_want.gz",1); |
3187 | if ($lc_file) { | |
c356248b | 3188 | $lc_file =~ s/\.gz$//; |
09d9d230 | 3189 | CPAN::Tarzip->gunzip("$lc_file.gz",$lc_file); |
c356248b A |
3190 | } else { |
3191 | return; | |
3192 | } | |
05454584 | 3193 | } |
55e314ee | 3194 | $self->MD5_check_file($lc_file); |
5f05dabc | 3195 | } |
3196 | ||
05454584 A |
3197 | #-> sub CPAN::Distribution::MD5_check_file ; |
3198 | sub MD5_check_file { | |
55e314ee A |
3199 | my($self,$chk_file) = @_; |
3200 | my($cksum,$file,$basename); | |
c356248b | 3201 | $file = $self->{localfile}; |
55e314ee A |
3202 | $basename = File::Basename::basename($file); |
3203 | my $fh = FileHandle->new; | |
55e314ee | 3204 | if (open $fh, $chk_file){ |
c356248b | 3205 | local($/); |
05454584 | 3206 | my $eval = <$fh>; |
f14b5cec | 3207 | $eval =~ s/\015?\012/\n/g; |
05454584 A |
3208 | close $fh; |
3209 | my($comp) = Safe->new(); | |
3210 | $cksum = $comp->reval($eval); | |
55e314ee A |
3211 | if ($@) { |
3212 | rename $chk_file, "$chk_file.bad"; | |
3213 | Carp::confess($@) if $@; | |
3214 | } | |
3215 | } else { | |
3216 | Carp::carp "Could not open $chk_file for reading"; | |
3217 | } | |
09d9d230 A |
3218 | |
3219 | if (exists $cksum->{$basename}{md5}) { | |
55e314ee | 3220 | $self->debug("Found checksum for $basename:" . |
09d9d230 A |
3221 | "$cksum->{$basename}{md5}\n") if $CPAN::DEBUG; |
3222 | ||
3223 | open($fh, $file); | |
3224 | binmode $fh; | |
3225 | my $eq = $self->eq_MD5($fh,$cksum->{$basename}{'md5'}); | |
3226 | $fh->close; | |
3227 | $fh = CPAN::Tarzip->TIEHANDLE($file); | |
3228 | ||
3229 | unless ($eq) { | |
3230 | # had to inline it, when I tied it, the tiedness got lost on | |
3231 | # the call to eq_MD5. (Jan 1998) | |
3232 | my $md5 = MD5->new; | |
3233 | my($data,$ref); | |
3234 | $ref = \$data; | |
36263cb3 | 3235 | while ($fh->READ($ref, 4096) > 0){ |
09d9d230 A |
3236 | $md5->add($data); |
3237 | } | |
3238 | my $hexdigest = $md5->hexdigest; | |
3239 | $eq += $hexdigest eq $cksum->{$basename}{'md5-ungz'}; | |
3240 | } | |
3241 | ||
3242 | if ($eq) { | |
3243 | $CPAN::Frontend->myprint("Checksum for $file ok\n"); | |
3244 | return $self->{MD5_STATUS} = "OK"; | |
05454584 | 3245 | } else { |
c356248b A |
3246 | $CPAN::Frontend->myprint(qq{Checksum mismatch for }. |
3247 | qq{distribution file. }. | |
3248 | qq{Please investigate.\n\n}. | |
3249 | $self->as_string, | |
3250 | $CPAN::META->instance( | |
3251 | 'CPAN::Author', | |
3252 | $self->{CPAN_USERID} | |
3253 | )->as_string); | |
55e314ee | 3254 | my $wrap = qq{I\'d recommend removing $file. It seems to |
09d9d230 A |
3255 | be a bogus file. Maybe you have configured your \`urllist\' with a |
3256 | bad URL. Please check this array with \`o conf urllist\', and | |
55e314ee | 3257 | retry.}; |
c356248b A |
3258 | $CPAN::Frontend->myprint(Text::Wrap::wrap("","",$wrap)); |
3259 | $CPAN::Frontend->myprint("\n\n"); | |
55e314ee | 3260 | sleep 3; |
05454584 | 3261 | return; |
5f05dabc | 3262 | } |
09d9d230 | 3263 | # close $fh if fileno($fh); |
5f05dabc | 3264 | } else { |
55e314ee A |
3265 | $self->{MD5_STATUS} ||= ""; |
3266 | if ($self->{MD5_STATUS} eq "NIL") { | |
c356248b A |
3267 | $CPAN::Frontend->myprint(qq{ |
3268 | No md5 checksum for $basename in local $chk_file. | |
3269 | Removing $chk_file | |
3270 | }); | |
3271 | unlink $chk_file or $CPAN::Frontend->myprint("Could not unlink: $!"); | |
55e314ee A |
3272 | sleep 1; |
3273 | } | |
3274 | $self->{MD5_STATUS} = "NIL"; | |
3275 | return; | |
5f05dabc | 3276 | } |
3277 | } | |
3278 | ||
05454584 A |
3279 | #-> sub CPAN::Distribution::eq_MD5 ; |
3280 | sub eq_MD5 { | |
3281 | my($self,$fh,$expectMD5) = @_; | |
55e314ee | 3282 | my $md5 = MD5->new; |
09d9d230 A |
3283 | my($data); |
3284 | while (read($fh, $data, 4096)){ | |
3285 | $md5->add($data); | |
3286 | } | |
3287 | # $md5->addfile($fh); | |
05454584 | 3288 | my $hexdigest = $md5->hexdigest; |
09d9d230 | 3289 | # warn "fh[$fh] hex[$hexdigest] aexp[$expectMD5]"; |
05454584 A |
3290 | $hexdigest eq $expectMD5; |
3291 | } | |
5f05dabc | 3292 | |
05454584 | 3293 | #-> sub CPAN::Distribution::force ; |
5f05dabc | 3294 | sub force { |
f610777f A |
3295 | my($self) = @_; |
3296 | $self->{'force_update'}++; | |
3297 | for my $att (qw( | |
3298 | MD5_STATUS archived build_dir localfile make install unwrapped | |
36263cb3 | 3299 | writemakefile |
f610777f A |
3300 | )) { |
3301 | delete $self->{$att}; | |
3302 | } | |
5f05dabc | 3303 | } |
3304 | ||
09d9d230 A |
3305 | sub isa_perl { |
3306 | my($self) = @_; | |
3307 | my $file = File::Basename::basename($self->id); | |
3308 | return unless $file =~ m{ ^ perl | |
3309 | (5) | |
3310 | ([._-]) | |
3311 | (\d{3}(_[0-4][0-9])?) | |
3312 | \.tar[._-]gz | |
3313 | $ | |
3314 | }x; | |
3315 | "$1.$3"; | |
3316 | } | |
3317 | ||
d4fd5c69 A |
3318 | #-> sub CPAN::Distribution::perl ; |
3319 | sub perl { | |
3320 | my($self) = @_; | |
3321 | my($perl) = MM->file_name_is_absolute($^X) ? $^X : ""; | |
e50380aa | 3322 | my $getcwd = $CPAN::Config->{'getcwd'} || 'cwd'; |
55e314ee | 3323 | my $pwd = CPAN->$getcwd(); |
c356248b | 3324 | my $candidate = MM->catfile($pwd,$^X); |
e50380aa | 3325 | $perl ||= $candidate if MM->maybe_command($candidate); |
d4fd5c69 A |
3326 | unless ($perl) { |
3327 | my ($component,$perl_name); | |
3328 | DIST_PERLNAME: foreach $perl_name ($^X, 'perl', 'perl5', "perl$]") { | |
c356248b A |
3329 | PATH_COMPONENT: foreach $component (MM->path(), |
3330 | $Config::Config{'binexp'}) { | |
d4fd5c69 A |
3331 | next unless defined($component) && $component; |
3332 | my($abs) = MM->catfile($component,$perl_name); | |
3333 | if (MM->maybe_command($abs)) { | |
3334 | $perl = $abs; | |
3335 | last DIST_PERLNAME; | |
3336 | } | |
3337 | } | |
3338 | } | |
3339 | } | |
3340 | $perl; | |
3341 | } | |
3342 | ||
05454584 A |
3343 | #-> sub CPAN::Distribution::make ; |
3344 | sub make { | |
3345 | my($self) = @_; | |
c356248b | 3346 | $CPAN::Frontend->myprint(sprintf "Running make for %s\n", $self->id); |
09d9d230 A |
3347 | # Emergency brake if they said install Pippi and get newest perl |
3348 | if ($self->isa_perl) { | |
3349 | if ( | |
3350 | $self->called_for ne $self->id && ! $self->{'force_update'} | |
3351 | ) { | |
3352 | $CPAN::Frontend->mydie(sprintf qq{ | |
3353 | The most recent version "%s" of the module "%s" | |
3354 | comes with the current version of perl (%s). | |
3355 | I\'ll build that only if you ask for something like | |
3356 | force install %s | |
3357 | or | |
3358 | install %s | |
3359 | }, | |
3360 | $CPAN::META->instance( | |
3361 | 'CPAN::Module', | |
3362 | $self->called_for | |
3363 | )->cpan_version, | |
3364 | $self->called_for, | |
3365 | $self->isa_perl, | |
3366 | $self->called_for, | |
3367 | $self->id); | |
3368 | } | |
3369 | } | |
05454584 A |
3370 | $self->get; |
3371 | EXCUSE: { | |
3372 | my @e; | |
3373 | $self->{archived} eq "NO" and push @e, | |
3374 | "Is neither a tar nor a zip archive."; | |
5f05dabc | 3375 | |
d4fd5c69 | 3376 | $self->{unwrapped} eq "NO" and push @e, |
05454584 A |
3377 | "had problems unarchiving. Please build manually"; |
3378 | ||
3379 | exists $self->{writemakefile} && | |
36263cb3 GS |
3380 | $self->{writemakefile} =~ m/ ^ NO\s* ( .* ) /sx and push @e, |
3381 | $1 || "Had some problem writing Makefile"; | |
05454584 A |
3382 | |
3383 | defined $self->{'make'} and push @e, | |
3384 | "Has already been processed within this session"; | |
3385 | ||
c356248b | 3386 | $CPAN::Frontend->myprint(join "", map {" $_\n"} @e) and return if @e; |
5f05dabc | 3387 | } |
c356248b | 3388 | $CPAN::Frontend->myprint("\n CPAN.pm: Going to build ".$self->id."\n\n"); |
05454584 A |
3389 | my $builddir = $self->dir; |
3390 | chdir $builddir or Carp::croak("Couldn't chdir $builddir: $!"); | |
3391 | $self->debug("Changed directory to $builddir") if $CPAN::DEBUG; | |
3392 | ||
f14b5cec JH |
3393 | if ($^O eq 'MacOS') { |
3394 | ExtUtils::MM_MacOS::make($self); | |
3395 | return; | |
3396 | } | |
3397 | ||
05454584 A |
3398 | my $system; |
3399 | if ($self->{'configure'}) { | |
09d9d230 | 3400 | $system = $self->{'configure'}; |
5f05dabc | 3401 | } else { |
d4fd5c69 A |
3402 | my($perl) = $self->perl or die "Couldn\'t find executable perl\n"; |
3403 | my $switch = ""; | |
3404 | # This needs a handler that can be turned on or off: | |
3405 | # $switch = "-MExtUtils::MakeMaker ". | |
3406 | # "-Mops=:default,:filesys_read,:filesys_open,require,chdir" | |
3407 | # if $] > 5.00310; | |
3408 | $system = "$perl $switch Makefile.PL $CPAN::Config->{makepl_arg}"; | |
3409 | } | |
09d9d230 | 3410 | unless (exists $self->{writemakefile}) { |
e50380aa A |
3411 | local($SIG{ALRM}) = sub { die "inactivity_timeout reached\n" }; |
3412 | my($ret,$pid); | |
3413 | $@ = ""; | |
3414 | if ($CPAN::Config->{inactivity_timeout}) { | |
3415 | eval { | |
3416 | alarm $CPAN::Config->{inactivity_timeout}; | |
f14b5cec | 3417 | local $SIG{CHLD}; # = sub { wait }; |
e50380aa A |
3418 | if (defined($pid = fork)) { |
3419 | if ($pid) { #parent | |
f14b5cec JH |
3420 | # wait; |
3421 | waitpid $pid, 0; | |
e50380aa | 3422 | } else { #child |
09d9d230 A |
3423 | # note, this exec isn't necessary if |
3424 | # inactivity_timeout is 0. On the Mac I'd | |
3425 | # suggest, we set it always to 0. | |
3426 | exec $system; | |
e50380aa A |
3427 | } |
3428 | } else { | |
c356248b | 3429 | $CPAN::Frontend->myprint("Cannot fork: $!"); |
e50380aa | 3430 | return; |
05454584 | 3431 | } |
e50380aa A |
3432 | }; |
3433 | alarm 0; | |
3434 | if ($@){ | |
3435 | kill 9, $pid; | |
3436 | waitpid $pid, 0; | |
c356248b | 3437 | $CPAN::Frontend->myprint($@); |
36263cb3 | 3438 | $self->{writemakefile} = "NO $@"; |
e50380aa | 3439 | $@ = ""; |
05454584 A |
3440 | return; |
3441 | } | |
e50380aa | 3442 | } else { |
2e2b7522 GS |
3443 | $ret = system($system); |
3444 | if ($ret != 0) { | |
36263cb3 | 3445 | $self->{writemakefile} = "NO Makefile.PL returned status $ret"; |
2e2b7522 | 3446 | return; |
09d9d230 | 3447 | } |
e50380aa | 3448 | } |
36263cb3 GS |
3449 | if (-f "Makefile") { |
3450 | $self->{writemakefile} = "YES"; | |
3451 | } else { | |
3452 | $self->{writemakefile} = | |
3453 | qq{NO Makefile.PL refused to write a Makefile.}; | |
3454 | # It's probably worth to record the reason, so let's retry | |
3455 | # local $/; | |
3456 | # my $fh = IO::File->new("$system |"); # STDERR? STDIN? | |
3457 | # $self->{writemakefile} .= <$fh>; | |
3458 | } | |
05454584 | 3459 | } |
05454584 | 3460 | return if $CPAN::Signal; |
f610777f A |
3461 | if (my @prereq = $self->needs_prereq){ |
3462 | my $id = $self->id; | |
3463 | $CPAN::Frontend->myprint("---- Dependencies detected ". | |
3464 | "during [$id] -----\n"); | |
3465 | ||
3466 | for my $p (@prereq) { | |
3467 | $CPAN::Frontend->myprint(" $p\n"); | |
3468 | } | |
f610777f A |
3469 | my $follow = 0; |
3470 | if ($CPAN::Config->{prerequisites_policy} eq "follow") { | |
3471 | $follow = 1; | |
3472 | } elsif ($CPAN::Config->{prerequisites_policy} eq "ask") { | |
3473 | require ExtUtils::MakeMaker; | |
3474 | my $answer = ExtUtils::MakeMaker::prompt( | |
3475 | "Shall I follow them and prepend them to the queue | |
3476 | of modules we are processing right now?", "yes"); | |
3477 | $follow = $answer =~ /^\s*y/i; | |
f14b5cec JH |
3478 | } else { |
3479 | local($") = ", "; | |
3480 | $CPAN::Frontend->myprint(" Ignoring dependencies on modules @prereq\n"); | |
f610777f A |
3481 | } |
3482 | if ($follow) { | |
3483 | CPAN::Queue->jumpqueue(@prereq,$id); # requeue yourself | |
3484 | return; | |
3485 | } | |
3486 | } | |
05454584 | 3487 | $system = join " ", $CPAN::Config->{'make'}, $CPAN::Config->{make_arg}; |
e50380aa | 3488 | if (system($system) == 0) { |
c356248b | 3489 | $CPAN::Frontend->myprint(" $system -- OK\n"); |
05454584 A |
3490 | $self->{'make'} = "YES"; |
3491 | } else { | |
36263cb3 | 3492 | $self->{writemakefile} ||= "YES"; |
05454584 | 3493 | $self->{'make'} = "NO"; |
c356248b | 3494 | $CPAN::Frontend->myprint(" $system -- NOT OK\n"); |
5f05dabc | 3495 | } |
5f05dabc | 3496 | } |
3497 | ||
f610777f A |
3498 | #-> sub CPAN::Distribution::needs_prereq ; |
3499 | sub needs_prereq { | |
3500 | my($self) = @_; | |
3501 | return unless -f "Makefile"; # we cannot say much | |
3502 | my $fh = FileHandle->new("<Makefile") or | |
3503 | $CPAN::Frontend->mydie("Couldn't open Makefile: $!"); | |
3504 | local($/) = "\n"; | |
f610777f A |
3505 | |
3506 | my(@p,@need); | |
f14b5cec JH |
3507 | while (<$fh>) { |
3508 | last if /MakeMaker post_initialize section/; | |
3509 | my($p) = m{^[\#] | |
f610777f A |
3510 | \s+PREREQ_PM\s+=>\s+(.+) |
3511 | }x; | |
f14b5cec JH |
3512 | next unless $p; |
3513 | # warn "Found prereq expr[$p]"; | |
f610777f | 3514 | |
f14b5cec JH |
3515 | while ( $p =~ m/(?:\s)([\w\:]+)=>q\[.*?\],?/g ){ |
3516 | push @p, $1; | |
f610777f | 3517 | } |
f14b5cec | 3518 | last; |
f610777f A |
3519 | } |
3520 | for my $p (@p) { | |
f14b5cec JH |
3521 | my $mo = $CPAN::META->instance("CPAN::Module",$p); |
3522 | next if $mo->uptodate; | |
3523 | # it's not needed, so don't push it. We cannot omit this step, because | |
3524 | # if 'force' is in effect, nobody else will check. | |
36263cb3 | 3525 | if ($self->{have_sponsored}{$p}++){ |
f14b5cec JH |
3526 | # We have already sponsored it and for some reason it's still |
3527 | # not available. So we do nothing. Or what should we do? | |
3528 | # if we push it again, we have a potential infinite loop | |
3529 | next; | |
f610777f | 3530 | } |
f14b5cec | 3531 | push @need, $p; |
f610777f A |
3532 | } |
3533 | return @need; | |
3534 | } | |
3535 | ||
05454584 A |
3536 | #-> sub CPAN::Distribution::test ; |
3537 | sub test { | |
5f05dabc | 3538 | my($self) = @_; |
05454584 A |
3539 | $self->make; |
3540 | return if $CPAN::Signal; | |
c356248b | 3541 | $CPAN::Frontend->myprint("Running make test\n"); |
05454584 A |
3542 | EXCUSE: { |
3543 | my @e; | |
3544 | exists $self->{'make'} or push @e, | |
3545 | "Make had some problems, maybe interrupted? Won't test"; | |
3546 | ||
3547 | exists $self->{'make'} and | |
3548 | $self->{'make'} eq 'NO' and | |
3549 | push @e, "Oops, make had returned bad status"; | |
3550 | ||
3551 | exists $self->{'build_dir'} or push @e, "Has no own directory"; | |
c356248b | 3552 | $CPAN::Frontend->myprint(join "", map {" $_\n"} @e) and return if @e; |
05454584 | 3553 | } |
c356248b A |
3554 | chdir $self->{'build_dir'} or |
3555 | Carp::croak("Couldn't chdir to $self->{'build_dir'}"); | |
3556 | $self->debug("Changed directory to $self->{'build_dir'}") | |
3557 | if $CPAN::DEBUG; | |
f14b5cec JH |
3558 | |
3559 | if ($^O eq 'MacOS') { | |
3560 | ExtUtils::MM_MacOS::make_test($self); | |
3561 | return; | |
3562 | } | |
3563 | ||
05454584 | 3564 | my $system = join " ", $CPAN::Config->{'make'}, "test"; |
e50380aa | 3565 | if (system($system) == 0) { |
c356248b | 3566 | $CPAN::Frontend->myprint(" $system -- OK\n"); |
05454584 A |
3567 | $self->{'make_test'} = "YES"; |
3568 | } else { | |
3569 | $self->{'make_test'} = "NO"; | |
c356248b | 3570 | $CPAN::Frontend->myprint(" $system -- NOT OK\n"); |
5f05dabc | 3571 | } |
3572 | } | |
3573 | ||
05454584 A |
3574 | #-> sub CPAN::Distribution::clean ; |
3575 | sub clean { | |
5f05dabc | 3576 | my($self) = @_; |
c356248b | 3577 | $CPAN::Frontend->myprint("Running make clean\n"); |
05454584 A |
3578 | EXCUSE: { |
3579 | my @e; | |
3580 | exists $self->{'build_dir'} or push @e, "Has no own directory"; | |
c356248b | 3581 | $CPAN::Frontend->myprint(join "", map {" $_\n"} @e) and return if @e; |
05454584 | 3582 | } |
c356248b A |
3583 | chdir $self->{'build_dir'} or |
3584 | Carp::croak("Couldn't chdir to $self->{'build_dir'}"); | |
05454584 | 3585 | $self->debug("Changed directory to $self->{'build_dir'}") if $CPAN::DEBUG; |
f14b5cec JH |
3586 | |
3587 | if ($^O eq 'MacOS') { | |
3588 | ExtUtils::MM_MacOS::make_clean($self); | |
3589 | return; | |
3590 | } | |
3591 | ||
05454584 | 3592 | my $system = join " ", $CPAN::Config->{'make'}, "clean"; |
e50380aa | 3593 | if (system($system) == 0) { |
c356248b | 3594 | $CPAN::Frontend->myprint(" $system -- OK\n"); |
05454584 A |
3595 | $self->force; |
3596 | } else { | |
3597 | # Hmmm, what to do if make clean failed? | |
5f05dabc | 3598 | } |
3599 | } | |
3600 | ||
05454584 A |
3601 | #-> sub CPAN::Distribution::install ; |
3602 | sub install { | |
5f05dabc | 3603 | my($self) = @_; |
05454584 A |
3604 | $self->test; |
3605 | return if $CPAN::Signal; | |
c356248b | 3606 | $CPAN::Frontend->myprint("Running make install\n"); |
05454584 A |
3607 | EXCUSE: { |
3608 | my @e; | |
3609 | exists $self->{'build_dir'} or push @e, "Has no own directory"; | |
5f05dabc | 3610 | |
05454584 A |
3611 | exists $self->{'make'} or push @e, |
3612 | "Make had some problems, maybe interrupted? Won't install"; | |
5f05dabc | 3613 | |
05454584 A |
3614 | exists $self->{'make'} and |
3615 | $self->{'make'} eq 'NO' and | |
3616 | push @e, "Oops, make had returned bad status"; | |
3617 | ||
c356248b A |
3618 | push @e, "make test had returned bad status, ". |
3619 | "won't install without force" | |
d4fd5c69 A |
3620 | if exists $self->{'make_test'} and |
3621 | $self->{'make_test'} eq 'NO' and | |
3622 | ! $self->{'force_update'}; | |
3623 | ||
05454584 A |
3624 | exists $self->{'install'} and push @e, |
3625 | $self->{'install'} eq "YES" ? | |
3626 | "Already done" : "Already tried without success"; | |
3627 | ||
c356248b | 3628 | $CPAN::Frontend->myprint(join "", map {" $_\n"} @e) and return if @e; |
05454584 | 3629 | } |
c356248b A |
3630 | chdir $self->{'build_dir'} or |
3631 | Carp::croak("Couldn't chdir to $self->{'build_dir'}"); | |
3632 | $self->debug("Changed directory to $self->{'build_dir'}") | |
3633 | if $CPAN::DEBUG; | |
f14b5cec JH |
3634 | |
3635 | if ($^O eq 'MacOS') { | |
3636 | ExtUtils::MM_MacOS::make_install($self); | |
3637 | return; | |
3638 | } | |
3639 | ||
c356248b A |
3640 | my $system = join(" ", $CPAN::Config->{'make'}, |
3641 | "install", $CPAN::Config->{make_install_arg}); | |
f610777f A |
3642 | my($stderr) = $^O =~ /Win/i ? "" : " 2>&1 "; |
3643 | my($pipe) = FileHandle->new("$system $stderr |"); | |
05454584 A |
3644 | my($makeout) = ""; |
3645 | while (<$pipe>){ | |
c356248b | 3646 | $CPAN::Frontend->myprint($_); |
05454584 A |
3647 | $makeout .= $_; |
3648 | } | |
3649 | $pipe->close; | |
3650 | if ($?==0) { | |
c356248b | 3651 | $CPAN::Frontend->myprint(" $system -- OK\n"); |
f610777f | 3652 | return $self->{'install'} = "YES"; |
5f05dabc | 3653 | } else { |
05454584 | 3654 | $self->{'install'} = "NO"; |
c356248b | 3655 | $CPAN::Frontend->myprint(" $system -- NOT OK\n"); |
05454584 | 3656 | if ($makeout =~ /permission/s && $> > 0) { |
c356248b A |
3657 | $CPAN::Frontend->myprint(qq{ You may have to su }. |
3658 | qq{to root to install the package\n}); | |
05454584 | 3659 | } |
5f05dabc | 3660 | } |
3661 | } | |
3662 | ||
05454584 A |
3663 | #-> sub CPAN::Distribution::dir ; |
3664 | sub dir { | |
3665 | shift->{'build_dir'}; | |
5f05dabc | 3666 | } |
3667 | ||
05454584 | 3668 | package CPAN::Bundle; |
5f05dabc | 3669 | |
05454584 A |
3670 | #-> sub CPAN::Bundle::as_string ; |
3671 | sub as_string { | |
3672 | my($self) = @_; | |
3673 | $self->contains; | |
3674 | $self->{INST_VERSION} = $self->inst_version; | |
3675 | return $self->SUPER::as_string; | |
3676 | } | |
3677 | ||
3678 | #-> sub CPAN::Bundle::contains ; | |
3679 | sub contains { | |
2e2b7522 GS |
3680 | my($self) = @_; |
3681 | my($parsefile) = $self->inst_file; | |
3682 | my($id) = $self->id; | |
3683 | $self->debug("parsefile[$parsefile]id[$id]") if $CPAN::DEBUG; | |
3684 | unless ($parsefile) { | |
3685 | # Try to get at it in the cpan directory | |
3686 | $self->debug("no parsefile") if $CPAN::DEBUG; | |
3687 | Carp::confess "I don't know a $id" unless $self->{CPAN_FILE}; | |
3688 | my $dist = $CPAN::META->instance('CPAN::Distribution', | |
3689 | $self->{CPAN_FILE}); | |
3690 | $dist->get; | |
3691 | $self->debug($dist->as_string) if $CPAN::DEBUG; | |
3692 | my($todir) = $CPAN::Config->{'cpan_home'}; | |
3693 | my(@me,$from,$to,$me); | |
3694 | @me = split /::/, $self->id; | |
3695 | $me[-1] .= ".pm"; | |
3696 | $me = MM->catfile(@me); | |
3697 | $from = $self->find_bundle_file($dist->{'build_dir'},$me); | |
3698 | $to = MM->catfile($todir,$me); | |
3699 | File::Path::mkpath(File::Basename::dirname($to)); | |
3700 | File::Copy::copy($from, $to) | |
3701 | or Carp::confess("Couldn't copy $from to $to: $!"); | |
3702 | $parsefile = $to; | |
3703 | } | |
3704 | my @result; | |
3705 | my $fh = FileHandle->new; | |
3706 | local $/ = "\n"; | |
3707 | open($fh,$parsefile) or die "Could not open '$parsefile': $!"; | |
3708 | my $inpod = 0; | |
3709 | $self->debug("parsefile[$parsefile]") if $CPAN::DEBUG; | |
3710 | while (<$fh>) { | |
3711 | $inpod = m/^=(?!head1\s+CONTENTS)/ ? 0 : | |
3712 | m/^=head1\s+CONTENTS/ ? 1 : $inpod; | |
3713 | next unless $inpod; | |
3714 | next if /^=/; | |
3715 | next if /^\s+$/; | |
3716 | chomp; | |
3717 | push @result, (split " ", $_, 2)[0]; | |
3718 | } | |
3719 | close $fh; | |
3720 | delete $self->{STATUS}; | |
3721 | $self->{CONTAINS} = join ", ", @result; | |
3722 | $self->debug("CONTAINS[@result]") if $CPAN::DEBUG; | |
3723 | unless (@result) { | |
3724 | $CPAN::Frontend->mywarn(qq{ | |
3725 | The bundle file "$parsefile" may be a broken | |
3726 | bundlefile. It seems not to contain any bundle definition. | |
3727 | Please check the file and if it is bogus, please delete it. | |
3728 | Sorry for the inconvenience. | |
3729 | }); | |
3730 | } | |
3731 | @result; | |
5f05dabc | 3732 | } |
3733 | ||
e50380aa A |
3734 | #-> sub CPAN::Bundle::find_bundle_file |
3735 | sub find_bundle_file { | |
3736 | my($self,$where,$what) = @_; | |
c356248b | 3737 | $self->debug("where[$where]what[$what]") if $CPAN::DEBUG; |
2e2b7522 GS |
3738 | ### The following two lines let CPAN.pm become Bundle/CPAN.pm :-( |
3739 | ### my $bu = MM->catfile($where,$what); | |
3740 | ### return $bu if -f $bu; | |
c356248b | 3741 | my $manifest = MM->catfile($where,"MANIFEST"); |
e50380aa A |
3742 | unless (-f $manifest) { |
3743 | require ExtUtils::Manifest; | |
3744 | my $getcwd = $CPAN::Config->{'getcwd'} || 'cwd'; | |
55e314ee | 3745 | my $cwd = CPAN->$getcwd(); |
e50380aa A |
3746 | chdir $where; |
3747 | ExtUtils::Manifest::mkmanifest(); | |
3748 | chdir $cwd; | |
3749 | } | |
c356248b A |
3750 | my $fh = FileHandle->new($manifest) |
3751 | or Carp::croak("Couldn't open $manifest: $!"); | |
e50380aa | 3752 | local($/) = "\n"; |
f610777f | 3753 | my $what2 = $what; |
f14b5cec JH |
3754 | if ($^O eq 'MacOS') { |
3755 | $what =~ s/^://; | |
3756 | $what2 =~ tr|:|/|; | |
3757 | $what2 =~ s/:Bundle://; | |
3758 | $what2 =~ tr|:|/|; | |
3759 | } else { | |
3760 | $what2 =~ s|Bundle/||; | |
3761 | } | |
f610777f | 3762 | my $bu; |
e50380aa A |
3763 | while (<$fh>) { |
3764 | next if /^\s*\#/; | |
3765 | my($file) = /(\S+)/; | |
c356248b | 3766 | if ($file =~ m|\Q$what\E$|) { |
e50380aa | 3767 | $bu = $file; |
f610777f A |
3768 | # return MM->catfile($where,$bu); # bad |
3769 | last; | |
e50380aa | 3770 | } |
f610777f A |
3771 | # retry if she managed to |
3772 | # have no Bundle directory | |
3773 | $bu = $file if $file =~ m|\Q$what2\E$|; | |
e50380aa | 3774 | } |
f14b5cec | 3775 | $bu =~ tr|/|:| if $^O eq 'MacOS'; |
f610777f | 3776 | return MM->catfile($where, $bu) if $bu; |
c356248b | 3777 | Carp::croak("Couldn't find a Bundle file in $where"); |
e50380aa A |
3778 | } |
3779 | ||
05454584 A |
3780 | #-> sub CPAN::Bundle::inst_file ; |
3781 | sub inst_file { | |
3782 | my($self) = @_; | |
3783 | my($me,$inst_file); | |
3784 | ($me = $self->id) =~ s/.*://; | |
c356248b A |
3785 | ## my(@me,$inst_file); |
3786 | ## @me = split /::/, $self->id; | |
3787 | ## $me[-1] .= ".pm"; | |
3788 | $inst_file = MM->catfile($CPAN::Config->{'cpan_home'}, | |
3789 | "Bundle", "$me.pm"); | |
3790 | ## "Bundle", @me); | |
05454584 | 3791 | return $self->{'INST_FILE'} = $inst_file if -f $inst_file; |
55e314ee | 3792 | # $inst_file = |
d4fd5c69 A |
3793 | $self->SUPER::inst_file; |
3794 | # return $self->{'INST_FILE'} = $inst_file if -f $inst_file; | |
3795 | # return $self->{'INST_FILE'}; # even if undefined? | |
5f05dabc | 3796 | } |
3797 | ||
05454584 A |
3798 | #-> sub CPAN::Bundle::rematein ; |
3799 | sub rematein { | |
3800 | my($self,$meth) = @_; | |
3801 | $self->debug("self[$self] meth[$meth]") if $CPAN::DEBUG; | |
c356248b A |
3802 | my($id) = $self->id; |
3803 | Carp::croak "Can't $meth $id, don't have an associated bundle file. :-(\n" | |
3804 | unless $self->inst_file || $self->{CPAN_FILE}; | |
f610777f | 3805 | my($s,%fail); |
05454584 A |
3806 | for $s ($self->contains) { |
3807 | my($type) = $s =~ m|/| ? 'CPAN::Distribution' : | |
3808 | $s =~ m|^Bundle::| ? 'CPAN::Bundle' : 'CPAN::Module'; | |
3809 | if ($type eq 'CPAN::Distribution') { | |
c356248b | 3810 | $CPAN::Frontend->mywarn(qq{ |
05454584 A |
3811 | The Bundle }.$self->id.qq{ contains |
3812 | explicitly a file $s. | |
c356248b | 3813 | }); |
05454584 | 3814 | sleep 3; |
5f05dabc | 3815 | } |
f610777f A |
3816 | # possibly noisy action: |
3817 | my $obj = $CPAN::META->instance($type,$s); | |
3818 | $obj->$meth(); | |
3819 | my $success = $obj->can("uptodate") ? $obj->uptodate : 0; | |
3820 | $success ||= $obj->{'install'} && $obj->{'install'} eq "YES"; | |
3821 | $fail{$s} = 1 unless $success; | |
3822 | } | |
3823 | # recap with less noise | |
3824 | if ( $meth eq "install") { | |
3825 | if (%fail) { | |
3826 | $CPAN::Frontend->myprint(qq{\nBundle summary: }. | |
3827 | qq{The following items seem to }. | |
3828 | qq{have had installation problems:\n}); | |
3829 | for $s ($self->contains) { | |
3830 | $CPAN::Frontend->myprint( "$s " ) if $fail{$s}; | |
3831 | } | |
3832 | $CPAN::Frontend->myprint(qq{\n}); | |
3833 | } else { | |
3834 | $self->{'install'} = 'YES'; | |
3835 | } | |
5f05dabc | 3836 | } |
5f05dabc | 3837 | } |
3838 | ||
e50380aa A |
3839 | #sub CPAN::Bundle::xs_file |
3840 | sub xs_file { | |
3841 | # If a bundle contains another that contains an xs_file we have | |
3842 | # here, we just don't bother I suppose | |
3843 | return 0; | |
3844 | } | |
3845 | ||
05454584 A |
3846 | #-> sub CPAN::Bundle::force ; |
3847 | sub force { shift->rematein('force',@_); } | |
3848 | #-> sub CPAN::Bundle::get ; | |
3849 | sub get { shift->rematein('get',@_); } | |
3850 | #-> sub CPAN::Bundle::make ; | |
3851 | sub make { shift->rematein('make',@_); } | |
3852 | #-> sub CPAN::Bundle::test ; | |
3853 | sub test { shift->rematein('test',@_); } | |
3854 | #-> sub CPAN::Bundle::install ; | |
09d9d230 A |
3855 | sub install { |
3856 | my $self = shift; | |
3857 | $self->rematein('install',@_); | |
09d9d230 | 3858 | } |
05454584 A |
3859 | #-> sub CPAN::Bundle::clean ; |
3860 | sub clean { shift->rematein('clean',@_); } | |
5f05dabc | 3861 | |
05454584 A |
3862 | #-> sub CPAN::Bundle::readme ; |
3863 | sub readme { | |
3864 | my($self) = @_; | |
c356248b A |
3865 | my($file) = $self->cpan_file or $CPAN::Frontend->myprint(qq{ |
3866 | No File found for bundle } . $self->id . qq{\n}), return; | |
05454584 A |
3867 | $self->debug("self[$self] file[$file]") if $CPAN::DEBUG; |
3868 | $CPAN::META->instance('CPAN::Distribution',$file)->readme; | |
5f05dabc | 3869 | } |
3870 | ||
05454584 | 3871 | package CPAN::Module; |
5f05dabc | 3872 | |
05454584 A |
3873 | #-> sub CPAN::Module::as_glimpse ; |
3874 | sub as_glimpse { | |
3875 | my($self) = @_; | |
3876 | my(@m); | |
3877 | my $class = ref($self); | |
3878 | $class =~ s/^CPAN:://; | |
c356248b A |
3879 | push @m, sprintf("%-15s %-15s (%s)\n", $class, $self->{ID}, |
3880 | $self->cpan_file); | |
05454584 A |
3881 | join "", @m; |
3882 | } | |
5f05dabc | 3883 | |
05454584 A |
3884 | #-> sub CPAN::Module::as_string ; |
3885 | sub as_string { | |
3886 | my($self) = @_; | |
3887 | my(@m); | |
3888 | CPAN->debug($self) if $CPAN::DEBUG; | |
3889 | my $class = ref($self); | |
3890 | $class =~ s/^CPAN:://; | |
3891 | local($^W) = 0; | |
3892 | push @m, $class, " id = $self->{ID}\n"; | |
3893 | my $sprintf = " %-12s %s\n"; | |
c356248b A |
3894 | push @m, sprintf($sprintf, 'DESCRIPTION', $self->{description}) |
3895 | if $self->{description}; | |
05454584 A |
3896 | my $sprintf2 = " %-12s %s (%s)\n"; |
3897 | my($userid); | |
3898 | if ($userid = $self->{'CPAN_USERID'} || $self->{'userid'}){ | |
c356248b A |
3899 | my $author; |
3900 | if ($author = CPAN::Shell->expand('Author',$userid)) { | |
09d9d230 A |
3901 | my $email = ""; |
3902 | my $m; # old perls | |
3903 | if ($m = $author->email) { | |
3904 | $email = " <$m>"; | |
3905 | } | |
3906 | push @m, sprintf( | |
3907 | $sprintf2, | |
3908 | 'CPAN_USERID', | |
3909 | $userid, | |
3910 | $author->fullname . $email | |
3911 | ); | |
c356248b A |
3912 | } |
3913 | } | |
3914 | push @m, sprintf($sprintf, 'CPAN_VERSION', $self->{CPAN_VERSION}) | |
3915 | if $self->{CPAN_VERSION}; | |
3916 | push @m, sprintf($sprintf, 'CPAN_FILE', $self->{CPAN_FILE}) | |
3917 | if $self->{CPAN_FILE}; | |
05454584 A |
3918 | my $sprintf3 = " %-12s %1s%1s%1s%1s (%s,%s,%s,%s)\n"; |
3919 | my(%statd,%stats,%statl,%stati); | |
c356248b A |
3920 | @statd{qw,? i c a b R M S,} = qw,unknown idea |
3921 | pre-alpha alpha beta released mature standard,; | |
3922 | @stats{qw,? m d u n,} = qw,unknown mailing-list | |
3923 | developer comp.lang.perl.* none,; | |
2e2b7522 GS |
3924 | @statl{qw,? p c + o h,} = qw,unknown perl C C++ other hybrid,; |
3925 | @stati{qw,? f r O h,} = qw,unknown functions | |
3926 | references+ties object-oriented hybrid,; | |
05454584 A |
3927 | $statd{' '} = 'unknown'; |
3928 | $stats{' '} = 'unknown'; | |
3929 | $statl{' '} = 'unknown'; | |
3930 | $stati{' '} = 'unknown'; | |
3931 | push @m, sprintf( | |
3932 | $sprintf3, | |
3933 | 'DSLI_STATUS', | |
3934 | $self->{statd}, | |
3935 | $self->{stats}, | |
3936 | $self->{statl}, | |
3937 | $self->{stati}, | |
3938 | $statd{$self->{statd}}, | |
3939 | $stats{$self->{stats}}, | |
3940 | $statl{$self->{statl}}, | |
3941 | $stati{$self->{stati}} | |
3942 | ) if $self->{statd}; | |
3943 | my $local_file = $self->inst_file; | |
09d9d230 A |
3944 | if ($local_file) { |
3945 | $self->{MANPAGE} ||= $self->manpage_headline($local_file); | |
5f05dabc | 3946 | } |
d4fd5c69 A |
3947 | my($item); |
3948 | for $item (qw/MANPAGE CONTAINS/) { | |
c356248b A |
3949 | push @m, sprintf($sprintf, $item, $self->{$item}) |
3950 | if exists $self->{$item}; | |
d4fd5c69 | 3951 | } |
c356248b A |
3952 | push @m, sprintf($sprintf, 'INST_FILE', |
3953 | $local_file || "(not installed)"); | |
3954 | push @m, sprintf($sprintf, 'INST_VERSION', | |
3955 | $self->inst_version) if $local_file; | |
05454584 | 3956 | join "", @m, "\n"; |
5f05dabc | 3957 | } |
3958 | ||
09d9d230 A |
3959 | sub manpage_headline { |
3960 | my($self,$local_file) = @_; | |
3961 | my(@local_file) = $local_file; | |
3962 | $local_file =~ s/\.pm$/.pod/; | |
3963 | push @local_file, $local_file; | |
3964 | my(@result,$locf); | |
3965 | for $locf (@local_file) { | |
3966 | next unless -f $locf; | |
3967 | my $fh = FileHandle->new($locf) | |
3968 | or $Carp::Frontend->mydie("Couldn't open $locf: $!"); | |
3969 | my $inpod = 0; | |
3970 | local $/ = "\n"; | |
3971 | while (<$fh>) { | |
2e2b7522 GS |
3972 | $inpod = m/^=(?!head1\s+NAME)/ ? 0 : |
3973 | m/^=head1\s+NAME/ ? 1 : $inpod; | |
09d9d230 A |
3974 | next unless $inpod; |
3975 | next if /^=/; | |
3976 | next if /^\s+$/; | |
3977 | chomp; | |
3978 | push @result, $_; | |
3979 | } | |
3980 | close $fh; | |
3981 | last if @result; | |
3982 | } | |
3983 | join " ", @result; | |
3984 | } | |
3985 | ||
05454584 A |
3986 | #-> sub CPAN::Module::cpan_file ; |
3987 | sub cpan_file { | |
3988 | my $self = shift; | |
3989 | CPAN->debug($self->id) if $CPAN::DEBUG; | |
3990 | unless (defined $self->{'CPAN_FILE'}) { | |
3991 | CPAN::Index->reload; | |
3992 | } | |
c356248b | 3993 | if (exists $self->{'CPAN_FILE'} && defined $self->{'CPAN_FILE'}){ |
05454584 | 3994 | return $self->{'CPAN_FILE'}; |
c356248b A |
3995 | } elsif (exists $self->{'userid'} && defined $self->{'userid'}) { |
3996 | my $fullname = $CPAN::META->instance(CPAN::Author, | |
3997 | $self->{'userid'})->fullname; | |
09d9d230 A |
3998 | my $email = $CPAN::META->instance(CPAN::Author, |
3999 | $self->{'userid'})->email; | |
4000 | unless (defined $fullname && defined $email) { | |
4001 | return "Contact Author $self->{userid} (Try ``a $self->{userid}'')"; | |
c356248b | 4002 | } |
09d9d230 | 4003 | return "Contact Author $fullname <$email>"; |
10b2abe6 | 4004 | } else { |
05454584 | 4005 | return "N/A"; |
5f05dabc | 4006 | } |
4007 | } | |
4008 | ||
05454584 | 4009 | *name = \&cpan_file; |
5f05dabc | 4010 | |
05454584 | 4011 | #-> sub CPAN::Module::cpan_version ; |
c356248b A |
4012 | sub cpan_version { |
4013 | my $self = shift; | |
f610777f | 4014 | $self->{'CPAN_VERSION'} = 'undef' |
c356248b A |
4015 | unless defined $self->{'CPAN_VERSION'}; # I believe this is |
4016 | # always a bug in the | |
4017 | # index and should be | |
4018 | # reported as such, | |
4019 | # but usually I find | |
4020 | # out such an error | |
4021 | # and do not want to | |
4022 | # provoke too many | |
4023 | # bugreports | |
4024 | $self->{'CPAN_VERSION'}; | |
4025 | } | |
5f05dabc | 4026 | |
05454584 A |
4027 | #-> sub CPAN::Module::force ; |
4028 | sub force { | |
4029 | my($self) = @_; | |
4030 | $self->{'force_update'}++; | |
5f05dabc | 4031 | } |
4032 | ||
05454584 A |
4033 | #-> sub CPAN::Module::rematein ; |
4034 | sub rematein { | |
4035 | my($self,$meth) = @_; | |
4036 | $self->debug($self->id) if $CPAN::DEBUG; | |
4037 | my $cpan_file = $self->cpan_file; | |
09d9d230 A |
4038 | if ($cpan_file eq "N/A" || $cpan_file =~ /^Contact Author/){ |
4039 | $CPAN::Frontend->mywarn(sprintf qq{ | |
4040 | The module %s isn\'t available on CPAN. | |
4041 | ||
4042 | Either the module has not yet been uploaded to CPAN, or it is | |
4043 | temporary unavailable. Please contact the author to find out | |
4044 | more about the status. Try ``i %s''. | |
4045 | }, | |
4046 | $self->id, | |
4047 | $self->id, | |
4048 | ); | |
4049 | return; | |
4050 | } | |
05454584 A |
4051 | my $pack = $CPAN::META->instance('CPAN::Distribution',$cpan_file); |
4052 | $pack->called_for($self->id); | |
4053 | $pack->force if exists $self->{'force_update'}; | |
4054 | $pack->$meth(); | |
4055 | delete $self->{'force_update'}; | |
5f05dabc | 4056 | } |
4057 | ||
05454584 A |
4058 | #-> sub CPAN::Module::readme ; |
4059 | sub readme { shift->rematein('readme') } | |
4060 | #-> sub CPAN::Module::look ; | |
4061 | sub look { shift->rematein('look') } | |
4062 | #-> sub CPAN::Module::get ; | |
4063 | sub get { shift->rematein('get',@_); } | |
4064 | #-> sub CPAN::Module::make ; | |
4065 | sub make { shift->rematein('make') } | |
4066 | #-> sub CPAN::Module::test ; | |
4067 | sub test { shift->rematein('test') } | |
f610777f A |
4068 | #-> sub CPAN::Module::uptodate ; |
4069 | sub uptodate { | |
5f05dabc | 4070 | my($self) = @_; |
05454584 A |
4071 | my($latest) = $self->cpan_version; |
4072 | $latest ||= 0; | |
4073 | my($inst_file) = $self->inst_file; | |
4074 | my($have) = 0; | |
4075 | if (defined $inst_file) { | |
4076 | $have = $self->inst_version; | |
4077 | } | |
f14b5cec JH |
4078 | local($^W)=0; |
4079 | if ($inst_file | |
4080 | && | |
4081 | $have >= $latest | |
4082 | ) { | |
4083 | return 1; | |
5f05dabc | 4084 | } |
f610777f A |
4085 | return; |
4086 | } | |
4087 | #-> sub CPAN::Module::install ; | |
4088 | sub install { | |
4089 | my($self) = @_; | |
4090 | my($doit) = 0; | |
4091 | if ($self->uptodate | |
4092 | && | |
4093 | not exists $self->{'force_update'} | |
4094 | ) { | |
4095 | $CPAN::Frontend->myprint( $self->id. " is up to date.\n"); | |
4096 | } else { | |
4097 | $doit = 1; | |
4098 | } | |
05454584 | 4099 | $self->rematein('install') if $doit; |
5f05dabc | 4100 | } |
05454584 A |
4101 | #-> sub CPAN::Module::clean ; |
4102 | sub clean { shift->rematein('clean') } | |
5f05dabc | 4103 | |
05454584 A |
4104 | #-> sub CPAN::Module::inst_file ; |
4105 | sub inst_file { | |
4106 | my($self) = @_; | |
4107 | my($dir,@packpath); | |
4108 | @packpath = split /::/, $self->{ID}; | |
4109 | $packpath[-1] .= ".pm"; | |
4110 | foreach $dir (@INC) { | |
c356248b | 4111 | my $pmfile = MM->catfile($dir,@packpath); |
05454584 A |
4112 | if (-f $pmfile){ |
4113 | return $pmfile; | |
da199366 | 4114 | } |
5f05dabc | 4115 | } |
d4fd5c69 | 4116 | return; |
5f05dabc | 4117 | } |
4118 | ||
05454584 A |
4119 | #-> sub CPAN::Module::xs_file ; |
4120 | sub xs_file { | |
4121 | my($self) = @_; | |
4122 | my($dir,@packpath); | |
4123 | @packpath = split /::/, $self->{ID}; | |
4124 | push @packpath, $packpath[-1]; | |
4125 | $packpath[-1] .= "." . $Config::Config{'dlext'}; | |
4126 | foreach $dir (@INC) { | |
c356248b | 4127 | my $xsfile = MM->catfile($dir,'auto',@packpath); |
05454584 A |
4128 | if (-f $xsfile){ |
4129 | return $xsfile; | |
4130 | } | |
4131 | } | |
d4fd5c69 | 4132 | return; |
5f05dabc | 4133 | } |
4134 | ||
05454584 A |
4135 | #-> sub CPAN::Module::inst_version ; |
4136 | sub inst_version { | |
4137 | my($self) = @_; | |
c356248b | 4138 | my $parsefile = $self->inst_file or return; |
05454584 | 4139 | local($^W) = 0 if $] < 5.00303 && $ExtUtils::MakeMaker::VERSION < 5.38; |
2e2b7522 | 4140 | # warn "HERE"; |
c356248b | 4141 | my $have = MM->parse_version($parsefile) || "undef"; |
05454584 | 4142 | $have =~ s/\s+//g; |
05454584 | 4143 | $have; |
5f05dabc | 4144 | } |
4145 | ||
09d9d230 A |
4146 | package CPAN::Tarzip; |
4147 | ||
4148 | sub gzip { | |
4149 | my($class,$read,$write) = @_; | |
4150 | if ($CPAN::META->has_inst("Compress::Zlib")) { | |
4151 | my($buffer,$fhw); | |
4152 | $fhw = FileHandle->new($read) | |
4153 | or $CPAN::Frontend->mydie("Could not open $read: $!"); | |
4154 | my $gz = Compress::Zlib::gzopen($write, "wb") | |
4155 | or $CPAN::Frontend->mydie("Cannot gzopen $write: $!\n"); | |
4156 | $gz->gzwrite($buffer) | |
4157 | while read($fhw,$buffer,4096) > 0 ; | |
4158 | $gz->gzclose() ; | |
4159 | $fhw->close; | |
4160 | return 1; | |
4161 | } else { | |
f610777f | 4162 | system("$CPAN::Config->{'gzip'} -c $read > $write")==0; |
09d9d230 A |
4163 | } |
4164 | } | |
4165 | ||
4166 | sub gunzip { | |
4167 | my($class,$read,$write) = @_; | |
4168 | if ($CPAN::META->has_inst("Compress::Zlib")) { | |
4169 | my($buffer,$fhw); | |
4170 | $fhw = FileHandle->new(">$write") | |
4171 | or $CPAN::Frontend->mydie("Could not open >$write: $!"); | |
4172 | my $gz = Compress::Zlib::gzopen($read, "rb") | |
4173 | or $CPAN::Frontend->mydie("Cannot gzopen $read: $!\n"); | |
4174 | $fhw->print($buffer) | |
4175 | while $gz->gzread($buffer) > 0 ; | |
4176 | $CPAN::Frontend->mydie("Error reading from $read: $!\n") | |
4177 | if $gz->gzerror != Compress::Zlib::Z_STREAM_END(); | |
4178 | $gz->gzclose() ; | |
4179 | $fhw->close; | |
4180 | return 1; | |
4181 | } else { | |
4182 | system("$CPAN::Config->{'gzip'} -dc $read > $write")==0; | |
4183 | } | |
4184 | } | |
4185 | ||
4186 | sub gtest { | |
4187 | my($class,$read) = @_; | |
4188 | if ($CPAN::META->has_inst("Compress::Zlib")) { | |
4189 | my($buffer); | |
4190 | my $gz = Compress::Zlib::gzopen($read, "rb") | |
4191 | or $CPAN::Frontend->mydie("Cannot open $read: $!\n"); | |
4192 | 1 while $gz->gzread($buffer) > 0 ; | |
4193 | $CPAN::Frontend->mydie("Error reading from $read: $!\n") | |
4194 | if $gz->gzerror != Compress::Zlib::Z_STREAM_END(); | |
4195 | $gz->gzclose() ; | |
4196 | return 1; | |
4197 | } else { | |
4198 | return system("$CPAN::Config->{'gzip'} -dt $read")==0; | |
4199 | } | |
4200 | } | |
4201 | ||
4202 | sub TIEHANDLE { | |
4203 | my($class,$file) = @_; | |
4204 | my $ret; | |
4205 | $class->debug("file[$file]"); | |
4206 | if ($CPAN::META->has_inst("Compress::Zlib")) { | |
4207 | my $gz = Compress::Zlib::gzopen($file,"rb") or | |
4208 | die "Could not gzopen $file"; | |
4209 | $ret = bless {GZ => $gz}, $class; | |
4210 | } else { | |
4211 | my $pipe = "$CPAN::Config->{'gzip'} --decompress --stdout $file |"; | |
4212 | my $fh = FileHandle->new($pipe) or die "Could pipe[$pipe]: $!"; | |
4213 | binmode $fh; | |
4214 | $ret = bless {FH => $fh}, $class; | |
4215 | } | |
4216 | $ret; | |
4217 | } | |
4218 | ||
4219 | sub READLINE { | |
4220 | my($self) = @_; | |
4221 | if (exists $self->{GZ}) { | |
4222 | my $gz = $self->{GZ}; | |
4223 | my($line,$bytesread); | |
4224 | $bytesread = $gz->gzreadline($line); | |
36263cb3 | 4225 | return undef if $bytesread <= 0; |
09d9d230 A |
4226 | return $line; |
4227 | } else { | |
4228 | my $fh = $self->{FH}; | |
4229 | return scalar <$fh>; | |
4230 | } | |
4231 | } | |
4232 | ||
4233 | sub READ { | |
4234 | my($self,$ref,$length,$offset) = @_; | |
4235 | die "read with offset not implemented" if defined $offset; | |
4236 | if (exists $self->{GZ}) { | |
4237 | my $gz = $self->{GZ}; | |
4238 | my $byteread = $gz->gzread($$ref,$length);# 30eaf79e8b446ef52464b5422da328a8 | |
4239 | return $byteread; | |
4240 | } else { | |
4241 | my $fh = $self->{FH}; | |
4242 | return read($fh,$$ref,$length); | |
4243 | } | |
4244 | } | |
4245 | ||
4246 | sub DESTROY { | |
4247 | my($self) = @_; | |
4248 | if (exists $self->{GZ}) { | |
4249 | my $gz = $self->{GZ}; | |
4250 | $gz->gzclose(); | |
4251 | } else { | |
4252 | my $fh = $self->{FH}; | |
4253 | $fh->close; | |
4254 | } | |
4255 | undef $self; | |
4256 | } | |
4257 | ||
4258 | sub untar { | |
4259 | my($class,$file) = @_; | |
4260 | # had to disable, because version 0.07 seems to be buggy | |
4261 | if (MM->maybe_command($CPAN::Config->{'gzip'}) | |
4262 | && | |
4263 | MM->maybe_command($CPAN::Config->{'tar'})) { | |
f610777f A |
4264 | if ($^O =~ /win/i) { # irgggh |
4265 | # people find the most curious tar binaries that cannot handle | |
4266 | # pipes | |
4267 | my $system = "$CPAN::Config->{'gzip'} --decompress $file"; | |
4268 | if (system($system)==0) { | |
4269 | $CPAN::Frontend->myprint(qq{Uncompressed $file successfully\n}); | |
4270 | } else { | |
4271 | $CPAN::Frontend->mydie( | |
4272 | qq{Couldn\'t uncompress $file\n} | |
4273 | ); | |
4274 | } | |
4275 | $file =~ s/\.gz$//; | |
4276 | $system = "$CPAN::Config->{tar} xvf $file"; | |
4277 | if (system($system)==0) { | |
4278 | $CPAN::Frontend->myprint(qq{Untarred $file successfully\n}); | |
4279 | } else { | |
4280 | $CPAN::Frontend->mydie(qq{Couldn\'t untar $file\n}); | |
4281 | } | |
4282 | return 1; | |
4283 | } else { | |
4284 | my $system = "$CPAN::Config->{'gzip'} --decompress --stdout " . | |
4285 | "< $file | $CPAN::Config->{tar} xvf -"; | |
4286 | return system($system) == 0; | |
4287 | } | |
09d9d230 A |
4288 | } elsif ($CPAN::META->has_inst("Archive::Tar") |
4289 | && | |
4290 | $CPAN::META->has_inst("Compress::Zlib") ) { | |
4291 | my $tar = Archive::Tar->new($file,1); | |
4292 | $tar->extract($tar->list_files); # I'm pretty sure we have nothing | |
4293 | # that isn't compressed | |
f14b5cec JH |
4294 | |
4295 | ExtUtils::MM_MacOS::convert_files([$tar->list_files], 1) | |
4296 | if ($^O eq 'MacOS'); | |
4297 | ||
09d9d230 A |
4298 | return 1; |
4299 | } else { | |
4300 | $CPAN::Frontend->mydie(qq{ | |
4301 | CPAN.pm needs either both external programs tar and gzip installed or | |
4302 | both the modules Archive::Tar and Compress::Zlib. Neither prerequisite | |
4303 | is available. Can\'t continue. | |
4304 | }); | |
4305 | } | |
4306 | } | |
4307 | ||
55e314ee | 4308 | package CPAN; |
d4fd5c69 | 4309 | |
5f05dabc | 4310 | 1; |
55e314ee | 4311 | |
e50380aa | 4312 | __END__ |
5f05dabc | 4313 | |
4314 | =head1 NAME | |
4315 | ||
4316 | CPAN - query, download and build perl modules from CPAN sites | |
4317 | ||
4318 | =head1 SYNOPSIS | |
4319 | ||
4320 | Interactive mode: | |
4321 | ||
4322 | perl -MCPAN -e shell; | |
4323 | ||
4324 | Batch mode: | |
4325 | ||
4326 | use CPAN; | |
4327 | ||
10b2abe6 | 4328 | autobundle, clean, install, make, recompile, test |
5f05dabc | 4329 | |
4330 | =head1 DESCRIPTION | |
4331 | ||
10b2abe6 | 4332 | The CPAN module is designed to automate the make and install of perl |
42d3b621 A |
4333 | modules and extensions. It includes some searching capabilities and |
4334 | knows how to use Net::FTP or LWP (or lynx or an external ftp client) | |
4335 | to fetch the raw data from the net. | |
5f05dabc | 4336 | |
4337 | Modules are fetched from one or more of the mirrored CPAN | |
4338 | (Comprehensive Perl Archive Network) sites and unpacked in a dedicated | |
4339 | directory. | |
4340 | ||
4341 | The CPAN module also supports the concept of named and versioned | |
4342 | 'bundles' of modules. Bundles simplify the handling of sets of | |
4343 | related modules. See BUNDLES below. | |
4344 | ||
4345 | The package contains a session manager and a cache manager. There is | |
4346 | no status retained between sessions. The session manager keeps track | |
4347 | of what has been fetched, built and installed in the current | |
4348 | session. The cache manager keeps track of the disk space occupied by | |
42d3b621 A |
4349 | the make processes and deletes excess space according to a simple FIFO |
4350 | mechanism. | |
5f05dabc | 4351 | |
2e2b7522 GS |
4352 | For extended searching capabilities there's a plugin for CPAN available, |
4353 | L<CPAN::WAIT>. C<CPAN::WAIT> is a full-text search engine that indexes | |
4354 | all documents available in CPAN authors directories. If C<CPAN::WAIT> | |
4355 | is installed on your system, the interactive shell of <CPAN.pm> will | |
4356 | enable the C<wq>, C<wr>, C<wd>, C<wl>, and C<wh> commands which send | |
4357 | queries to the WAIT server that has been configured for your | |
4358 | installation. | |
4359 | ||
4360 | All other methods provided are accessible in a programmer style and in an | |
10b2abe6 CS |
4361 | interactive shell style. |
4362 | ||
5f05dabc | 4363 | =head2 Interactive Mode |
4364 | ||
4365 | The interactive mode is entered by running | |
4366 | ||
4367 | perl -MCPAN -e shell | |
4368 | ||
09d9d230 | 4369 | which puts you into a readline interface. You will have the most fun if |
5f05dabc | 4370 | you install Term::ReadKey and Term::ReadLine to enjoy both history and |
09d9d230 | 4371 | command completion. |
5f05dabc | 4372 | |
4373 | Once you are on the command line, type 'h' and the rest should be | |
4374 | self-explanatory. | |
4375 | ||
10b2abe6 CS |
4376 | The most common uses of the interactive modes are |
4377 | ||
4378 | =over 2 | |
4379 | ||
4380 | =item Searching for authors, bundles, distribution files and modules | |
4381 | ||
4382 | There are corresponding one-letter commands C<a>, C<b>, C<d>, and C<m> | |
42d3b621 A |
4383 | for each of the four categories and another, C<i> for any of the |
4384 | mentioned four. Each of the four entities is implemented as a class | |
4385 | with slightly differing methods for displaying an object. | |
10b2abe6 | 4386 | |
09d9d230 | 4387 | Arguments you pass to these commands are either strings exactly matching |
10b2abe6 CS |
4388 | the identification string of an object or regular expressions that are |
4389 | then matched case-insensitively against various attributes of the | |
09d9d230 | 4390 | objects. The parser recognizes a regular expression only if you |
10b2abe6 CS |
4391 | enclose it between two slashes. |
4392 | ||
4393 | The principle is that the number of found objects influences how an | |
09d9d230 A |
4394 | item is displayed. If the search finds one item, the result is displayed |
4395 | as object-E<gt>as_string, but if we find more than one, we display | |
10b2abe6 CS |
4396 | each as object-E<gt>as_glimpse. E.g. |
4397 | ||
55e314ee | 4398 | cpan> a ANDK |
10b2abe6 CS |
4399 | Author id = ANDK |
4400 | EMAIL a.koenig@franz.ww.TU-Berlin.DE | |
4401 | FULLNAME Andreas König | |
4402 | ||
4403 | ||
55e314ee | 4404 | cpan> a /andk/ |
10b2abe6 CS |
4405 | Author id = ANDK |
4406 | EMAIL a.koenig@franz.ww.TU-Berlin.DE | |
4407 | FULLNAME Andreas König | |
4408 | ||
4409 | ||
4410 | cpan> a /and.*rt/ | |
4411 | Author ANDYD (Andy Dougherty) | |
4412 | Author MERLYN (Randal L. Schwartz) | |
4413 | ||
da199366 | 4414 | =item make, test, install, clean modules or distributions |
10b2abe6 | 4415 | |
f14b5cec | 4416 | These commands take any number of arguments and investigates what is |
09d9d230 | 4417 | necessary to perform the action. If the argument is a distribution |
f14b5cec JH |
4418 | file name (recognized by embedded slashes), it is processed. If it is |
4419 | a module, CPAN determines the distribution file in which this module | |
4420 | is included and processes that, following any dependencies named in | |
4421 | the module's Makefile.PL (this behavior is controlled by | |
4422 | I<prerequisites_policy>.) | |
10b2abe6 | 4423 | |
09d9d230 | 4424 | Any C<make> or C<test> are run unconditionally. An |
42d3b621 | 4425 | |
05454584 | 4426 | install <distribution_file> |
42d3b621 | 4427 | |
09d9d230 | 4428 | also is run unconditionally. But for |
42d3b621 | 4429 | |
05454584 | 4430 | install <module> |
42d3b621 A |
4431 | |
4432 | CPAN checks if an install is actually needed for it and prints | |
09d9d230 A |
4433 | I<module up to date> in the case that the distribution file containing |
4434 | the module doesnE<39>t need to be updated. | |
10b2abe6 CS |
4435 | |
4436 | CPAN also keeps track of what it has done within the current session | |
4437 | and doesnE<39>t try to build a package a second time regardless if it | |
09d9d230 A |
4438 | succeeded or not. The C<force> command takes as a first argument the |
4439 | method to invoke (currently: C<make>, C<test>, or C<install>) and executes the | |
10b2abe6 CS |
4440 | command from scratch. |
4441 | ||
4442 | Example: | |
4443 | ||
4444 | cpan> install OpenGL | |
4445 | OpenGL is up to date. | |
4446 | cpan> force install OpenGL | |
4447 | Running make | |
4448 | OpenGL-0.4/ | |
4449 | OpenGL-0.4/COPYRIGHT | |
4450 | [...] | |
4451 | ||
f610777f | 4452 | A C<clean> command results in a |
09d9d230 A |
4453 | |
4454 | make clean | |
4455 | ||
4456 | being executed within the distribution file's working directory. | |
4457 | ||
da199366 A |
4458 | =item readme, look module or distribution |
4459 | ||
4460 | These two commands take only one argument, be it a module or a | |
09d9d230 A |
4461 | distribution file. C<readme> unconditionally runs, displaying the |
4462 | README of the associated distribution file. C<Look> gets and | |
4463 | untars (if not yet done) the distribution file, changes to the | |
4464 | appropriate directory and opens a subshell process in that directory. | |
4465 | ||
4466 | =item Signals | |
4467 | ||
4468 | CPAN.pm installs signal handlers for SIGINT and SIGTERM. While you are | |
4469 | in the cpan-shell it is intended that you can press C<^C> anytime and | |
4470 | return to the cpan-shell prompt. A SIGTERM will cause the cpan-shell | |
4471 | to clean up and leave the shell loop. You can emulate the effect of a | |
4472 | SIGTERM by sending two consecutive SIGINTs, which usually means by | |
4473 | pressing C<^C> twice. | |
4474 | ||
4475 | CPAN.pm ignores a SIGPIPE. If the user sets inactivity_timeout, a | |
4476 | SIGALRM is used during the run of the C<perl Makefile.PL> subprocess. | |
da199366 | 4477 | |
10b2abe6 CS |
4478 | =back |
4479 | ||
5f05dabc | 4480 | =head2 CPAN::Shell |
4481 | ||
4482 | The commands that are available in the shell interface are methods in | |
4483 | the package CPAN::Shell. If you enter the shell command, all your | |
10b2abe6 CS |
4484 | input is split by the Text::ParseWords::shellwords() routine which |
4485 | acts like most shells do. The first word is being interpreted as the | |
4486 | method to be called and the rest of the words are treated as arguments | |
c356248b A |
4487 | to this method. Continuation lines are supported if a line ends with a |
4488 | literal backslash. | |
10b2abe6 | 4489 | |
da199366 A |
4490 | =head2 autobundle |
4491 | ||
4492 | C<autobundle> writes a bundle file into the | |
4493 | C<$CPAN::Config-E<gt>{cpan_home}/Bundle> directory. The file contains | |
4494 | a list of all modules that are both available from CPAN and currently | |
4495 | installed within @INC. The name of the bundle file is based on the | |
4496 | current date and a counter. | |
4497 | ||
4498 | =head2 recompile | |
4499 | ||
4500 | recompile() is a very special command in that it takes no argument and | |
4501 | runs the make/test/install cycle with brute force over all installed | |
4502 | dynamically loadable extensions (aka XS modules) with 'force' in | |
09d9d230 | 4503 | effect. The primary purpose of this command is to finish a network |
da199366 A |
4504 | installation. Imagine, you have a common source tree for two different |
4505 | architectures. You decide to do a completely independent fresh | |
4506 | installation. You start on one architecture with the help of a Bundle | |
4507 | file produced earlier. CPAN installs the whole Bundle for you, but | |
4508 | when you try to repeat the job on the second architecture, CPAN | |
4509 | responds with a C<"Foo up to date"> message for all modules. So you | |
09d9d230 | 4510 | invoke CPAN's recompile on the second architecture and youE<39>re done. |
da199366 A |
4511 | |
4512 | Another popular use for C<recompile> is to act as a rescue in case your | |
4513 | perl breaks binary compatibility. If one of the modules that CPAN uses | |
4514 | is in turn depending on binary compatibility (so you cannot run CPAN | |
4515 | commands), then you should try the CPAN::Nox module for recovery. | |
4516 | ||
c356248b | 4517 | =head2 The four C<CPAN::*> Classes: Author, Bundle, Module, Distribution |
e50380aa | 4518 | |
09d9d230 A |
4519 | Although it may be considered internal, the class hierarchy does matter |
4520 | for both users and programmer. CPAN.pm deals with above mentioned four | |
4521 | classes, and all those classes share a set of methods. A classical | |
4522 | single polymorphism is in effect. A metaclass object registers all | |
4523 | objects of all kinds and indexes them with a string. The strings | |
4524 | referencing objects have a separated namespace (well, not completely | |
4525 | separated): | |
e50380aa A |
4526 | |
4527 | Namespace Class | |
4528 | ||
4529 | words containing a "/" (slash) Distribution | |
4530 | words starting with Bundle:: Bundle | |
4531 | everything else Module or Author | |
4532 | ||
4533 | Modules know their associated Distribution objects. They always refer | |
09d9d230 A |
4534 | to the most recent official release. Developers may mark their releases |
4535 | as unstable development versions (by inserting an underbar into the | |
4536 | visible version number), so the really hottest and newest distribution | |
4537 | file is not always the default. If a module Foo circulates on CPAN in | |
4538 | both version 1.23 and 1.23_90, CPAN.pm offers a convenient way to | |
4539 | install version 1.23 by saying | |
e50380aa A |
4540 | |
4541 | install Foo | |
4542 | ||
4543 | This would install the complete distribution file (say | |
09d9d230 A |
4544 | BAR/Foo-1.23.tar.gz) with all accompanying material. But if you would |
4545 | like to install version 1.23_90, you need to know where the | |
e50380aa | 4546 | distribution file resides on CPAN relative to the authors/id/ |
09d9d230 | 4547 | directory. If the author is BAR, this might be BAR/Foo-1.23_90.tar.gz; |
c356248b | 4548 | so you would have to say |
e50380aa A |
4549 | |
4550 | install BAR/Foo-1.23_90.tar.gz | |
4551 | ||
4552 | The first example will be driven by an object of the class | |
c356248b | 4553 | CPAN::Module, the second by an object of class CPAN::Distribution. |
e50380aa | 4554 | |
10b2abe6 | 4555 | =head2 ProgrammerE<39>s interface |
5f05dabc | 4556 | |
10b2abe6 CS |
4557 | If you do not enter the shell, the available shell commands are both |
4558 | available as methods (C<CPAN::Shell-E<gt>install(...)>) and as | |
e50380aa A |
4559 | functions in the calling package (C<install(...)>). |
4560 | ||
09d9d230 | 4561 | There's currently only one class that has a stable interface - |
e50380aa | 4562 | CPAN::Shell. All commands that are available in the CPAN shell are |
55e314ee | 4563 | methods of the class CPAN::Shell. Each of the commands that produce |
36263cb3 GS |
4564 | listings of modules (C<r>, C<autobundle>, C<u>) also return a list of |
4565 | the IDs of all modules within the list. | |
e50380aa A |
4566 | |
4567 | =over 2 | |
4568 | ||
4569 | =item expand($type,@things) | |
4570 | ||
4571 | The IDs of all objects available within a program are strings that can | |
4572 | be expanded to the corresponding real objects with the | |
55e314ee A |
4573 | C<CPAN::Shell-E<gt>expand("Module",@things)> method. Expand returns a |
4574 | list of CPAN::Module objects according to the C<@things> arguments | |
4575 | given. In scalar context it only returns the first element of the | |
4576 | list. | |
e50380aa A |
4577 | |
4578 | =item Programming Examples | |
4579 | ||
55e314ee A |
4580 | This enables the programmer to do operations that combine |
4581 | functionalities that are available in the shell. | |
e50380aa A |
4582 | |
4583 | # install everything that is outdated on my disk: | |
4584 | perl -MCPAN -e 'CPAN::Shell->install(CPAN::Shell->r)' | |
4585 | ||
4586 | # install my favorite programs if necessary: | |
4587 | for $mod (qw(Net::FTP MD5 Data::Dumper)){ | |
4588 | my $obj = CPAN::Shell->expand('Module',$mod); | |
4589 | $obj->install; | |
4590 | } | |
4591 | ||
55e314ee A |
4592 | # list all modules on my disk that have no VERSION number |
4593 | for $mod (CPAN::Shell->expand("Module","/./")){ | |
4594 | next unless $mod->inst_file; | |
c356248b A |
4595 | # MakeMaker convention for undefined $VERSION: |
4596 | next unless $mod->inst_version eq "undef"; | |
55e314ee A |
4597 | print "No VERSION in ", $mod->id, "\n"; |
4598 | } | |
4599 | ||
36263cb3 GS |
4600 | Or if you want to write a cronjob to watch The CPAN, you could list |
4601 | all modules that need updating: | |
4602 | ||
4603 | perl -e 'use CPAN; CPAN::Shell->r;' | |
4604 | ||
4605 | If you don't want to get any output if all modules are up to date, you | |
4606 | can parse the output of above command for the regular expression | |
4607 | //modules are up to date// and decide to mail the output only if it | |
4608 | doesn't match. Ick? | |
4609 | ||
4610 | If you prefer to do it more in a programmer style in one single | |
4611 | process, maybe something like this suites you better: | |
4612 | ||
4613 | # list all modules on my disk that have newer versions on CPAN | |
4614 | for $mod (CPAN::Shell->expand("Module","/./")){ | |
4615 | next unless $mod->inst_file; | |
4616 | next if $mod->uptodate; | |
4617 | printf "Module %s is installed as %s, could be updated to %s from CPAN\n", | |
4618 | $mod->id, $mod->inst_version, $mod->cpan_version; | |
4619 | } | |
4620 | ||
4621 | If that gives you too much output every day, you maybe only want to | |
4622 | watch for three modules. You can write | |
4623 | ||
4624 | for $mod (CPAN::Shell->expand("Module","/Apache|LWP|CGI/")){ | |
4625 | ||
4626 | as the first line instead. Or you can combine some of the above | |
4627 | tricks: | |
4628 | ||
4629 | # watch only for a new mod_perl module | |
4630 | $mod = CPAN::Shell->expand("Module","mod_perl"); | |
4631 | exit if $mod->uptodate; | |
4632 | # new mod_perl arrived, let me know all update recommendations | |
4633 | CPAN::Shell->r; | |
4634 | ||
e50380aa | 4635 | =back |
5f05dabc | 4636 | |
f610777f | 4637 | =head2 Methods in the four Classes |
55e314ee | 4638 | |
5f05dabc | 4639 | =head2 Cache Manager |
4640 | ||
4641 | Currently the cache manager only keeps track of the build directory | |
4642 | ($CPAN::Config->{build_dir}). It is a simple FIFO mechanism that | |
42d3b621 | 4643 | deletes complete directories below C<build_dir> as soon as the size of |
5f05dabc | 4644 | all directories there gets bigger than $CPAN::Config->{build_cache} |
4645 | (in MB). The contents of this cache may be used for later | |
4646 | re-installations that you intend to do manually, but will never be | |
10b2abe6 CS |
4647 | trusted by CPAN itself. This is due to the fact that the user might |
4648 | use these directories for building modules on different architectures. | |
5f05dabc | 4649 | |
4650 | There is another directory ($CPAN::Config->{keep_source_where}) where | |
4651 | the original distribution files are kept. This directory is not | |
4652 | covered by the cache manager and must be controlled by the user. If | |
4653 | you choose to have the same directory as build_dir and as | |
4654 | keep_source_where directory, then your sources will be deleted with | |
4655 | the same fifo mechanism. | |
4656 | ||
4657 | =head2 Bundles | |
4658 | ||
4659 | A bundle is just a perl module in the namespace Bundle:: that does not | |
4660 | define any functions or methods. It usually only contains documentation. | |
4661 | ||
4662 | It starts like a perl module with a package declaration and a $VERSION | |
4663 | variable. After that the pod section looks like any other pod with the | |
09d9d230 | 4664 | only difference being that I<one special pod section> exists starting with |
10b2abe6 | 4665 | (verbatim): |
5f05dabc | 4666 | |
4667 | =head1 CONTENTS | |
4668 | ||
4669 | In this pod section each line obeys the format | |
4670 | ||
4671 | Module_Name [Version_String] [- optional text] | |
4672 | ||
4673 | The only required part is the first field, the name of a module | |
09d9d230 | 4674 | (e.g. Foo::Bar, ie. I<not> the name of the distribution file). The rest |
5f05dabc | 4675 | of the line is optional. The comment part is delimited by a dash just |
4676 | as in the man page header. | |
4677 | ||
4678 | The distribution of a bundle should follow the same convention as | |
42d3b621 | 4679 | other distributions. |
5f05dabc | 4680 | |
4681 | Bundles are treated specially in the CPAN package. If you say 'install | |
4682 | Bundle::Tkkit' (assuming such a bundle exists), CPAN will install all | |
09d9d230 | 4683 | the modules in the CONTENTS section of the pod. You can install your |
5f05dabc | 4684 | own Bundles locally by placing a conformant Bundle file somewhere into |
4685 | your @INC path. The autobundle() command which is available in the | |
4686 | shell interface does that for you by including all currently installed | |
4687 | modules in a snapshot bundle file. | |
4688 | ||
da199366 | 4689 | =head2 Prerequisites |
5f05dabc | 4690 | |
da199366 A |
4691 | If you have a local mirror of CPAN and can access all files with |
4692 | "file:" URLs, then you only need a perl better than perl5.003 to run | |
4693 | this module. Otherwise Net::FTP is strongly recommended. LWP may be | |
4694 | required for non-UNIX systems or if your nearest CPAN site is | |
4695 | associated with an URL that is not C<ftp:>. | |
5f05dabc | 4696 | |
da199366 A |
4697 | If you have neither Net::FTP nor LWP, there is a fallback mechanism |
4698 | implemented for an external ftp command or for an external lynx | |
4699 | command. | |
5f05dabc | 4700 | |
09d9d230 A |
4701 | =head2 Finding packages and VERSION |
4702 | ||
da199366 | 4703 | This module presumes that all packages on CPAN |
5f05dabc | 4704 | |
da199366 A |
4705 | =over 2 |
4706 | ||
4707 | =item * | |
4708 | ||
4709 | declare their $VERSION variable in an easy to parse manner. This | |
09d9d230 | 4710 | prerequisite can hardly be relaxed because it consumes far too much |
da199366 | 4711 | memory to load all packages into the running program just to determine |
09d9d230 | 4712 | the $VERSION variable. Currently all programs that are dealing with |
da199366 A |
4713 | version use something like this |
4714 | ||
4715 | perl -MExtUtils::MakeMaker -le \ | |
2e2b7522 | 4716 | 'print MM->parse_version(shift)' filename |
da199366 A |
4717 | |
4718 | If you are author of a package and wonder if your $VERSION can be | |
4719 | parsed, please try the above method. | |
4720 | ||
4721 | =item * | |
4722 | ||
4723 | come as compressed or gzipped tarfiles or as zip files and contain a | |
09d9d230 | 4724 | Makefile.PL (well, we try to handle a bit more, but without much |
da199366 A |
4725 | enthusiasm). |
4726 | ||
4727 | =back | |
4728 | ||
4729 | =head2 Debugging | |
4730 | ||
4731 | The debugging of this module is pretty difficult, because we have | |
4732 | interferences of the software producing the indices on CPAN, of the | |
4733 | mirroring process on CPAN, of packaging, of configuration, of | |
4734 | synchronicity, and of bugs within CPAN.pm. | |
4735 | ||
4736 | In interactive mode you can try "o debug" which will list options for | |
4737 | debugging the various parts of the package. The output may not be very | |
09d9d230 | 4738 | useful for you as it's just a by-product of my own testing, but if you |
da199366 A |
4739 | have an idea which part of the package may have a bug, it's sometimes |
4740 | worth to give it a try and send me more specific output. You should | |
4741 | know that "o debug" has built-in completion support. | |
4742 | ||
f610777f | 4743 | =head2 Floppy, Zip, Offline Mode |
da199366 A |
4744 | |
4745 | CPAN.pm works nicely without network too. If you maintain machines | |
4746 | that are not networked at all, you should consider working with file: | |
4747 | URLs. Of course, you have to collect your modules somewhere first. So | |
4748 | you might use CPAN.pm to put together all you need on a networked | |
4749 | machine. Then copy the $CPAN::Config->{keep_source_where} (but not | |
4750 | $CPAN::Config->{build_dir}) directory on a floppy. This floppy is kind | |
4751 | of a personal CPAN. CPAN.pm on the non-networked machines works nicely | |
36263cb3 | 4752 | with this floppy. See also below the paragraph about CD-ROM support. |
10b2abe6 | 4753 | |
5f05dabc | 4754 | =head1 CONFIGURATION |
4755 | ||
09d9d230 | 4756 | When the CPAN module is installed, a site wide configuration file is |
5f05dabc | 4757 | created as CPAN/Config.pm. The default values defined there can be |
4758 | overridden in another configuration file: CPAN/MyConfig.pm. You can | |
4759 | store this file in $HOME/.cpan/CPAN/MyConfig.pm if you want, because | |
4760 | $HOME/.cpan is added to the search path of the CPAN module before the | |
4761 | use() or require() statements. | |
4762 | ||
4763 | Currently the following keys in the hash reference $CPAN::Config are | |
4764 | defined: | |
4765 | ||
42d3b621 A |
4766 | build_cache size of cache for directories to build modules |
4767 | build_dir locally accessible directory to build modules | |
09d9d230 | 4768 | index_expire after this many days refetch index files |
42d3b621 A |
4769 | cpan_home local directory reserved for this package |
4770 | gzip location of external program gzip | |
09d9d230 | 4771 | inactivity_timeout breaks interactive Makefile.PLs after this |
42d3b621 | 4772 | many seconds inactivity. Set to 0 to never break. |
5f05dabc | 4773 | inhibit_startup_message |
42d3b621 | 4774 | if true, does not print the startup message |
09d9d230 A |
4775 | keep_source_where directory in which to keep the source (if we do) |
4776 | make location of external make program | |
42d3b621 A |
4777 | make_arg arguments that should always be passed to 'make' |
4778 | make_install_arg same as make_arg for 'make install' | |
4779 | makepl_arg arguments passed to 'perl Makefile.PL' | |
4780 | pager location of external program more (or any pager) | |
f14b5cec JH |
4781 | prerequisites_policy |
4782 | what to do if you are missing module prerequisites | |
4783 | ('follow' automatically, 'ask' me, or 'ignore') | |
f610777f | 4784 | scan_cache controls scanning of cache ('atstart' or 'never') |
42d3b621 A |
4785 | tar location of external program tar |
4786 | unzip location of external program unzip | |
4787 | urllist arrayref to nearby CPAN sites (or equivalent locations) | |
09d9d230 | 4788 | wait_list arrayref to a wait server to try (See CPAN::WAIT) |
f610777f A |
4789 | ftp_proxy, } the three usual variables for configuring |
4790 | http_proxy, } proxy requests. Both as CPAN::Config variables | |
4791 | no_proxy } and as environment variables configurable. | |
5f05dabc | 4792 | |
4793 | You can set and query each of these options interactively in the cpan | |
4794 | shell with the command set defined within the C<o conf> command: | |
4795 | ||
4796 | =over 2 | |
4797 | ||
4798 | =item o conf E<lt>scalar optionE<gt> | |
4799 | ||
4800 | prints the current value of the I<scalar option> | |
4801 | ||
4802 | =item o conf E<lt>scalar optionE<gt> E<lt>valueE<gt> | |
4803 | ||
4804 | Sets the value of the I<scalar option> to I<value> | |
4805 | ||
4806 | =item o conf E<lt>list optionE<gt> | |
4807 | ||
4808 | prints the current value of the I<list option> in MakeMaker's | |
4809 | neatvalue format. | |
4810 | ||
4811 | =item o conf E<lt>list optionE<gt> [shift|pop] | |
4812 | ||
4813 | shifts or pops the array in the I<list option> variable | |
4814 | ||
4815 | =item o conf E<lt>list optionE<gt> [unshift|push|splice] E<lt>listE<gt> | |
4816 | ||
42d3b621 | 4817 | works like the corresponding perl commands. |
5f05dabc | 4818 | |
4819 | =back | |
4820 | ||
36263cb3 GS |
4821 | =head2 Note on urllist parameter's format |
4822 | ||
4823 | urllist parameters are URLs according to RFC 1738. We do a little | |
4824 | guessing if your URL is not compliant, but if you have problems with file URLs, please try the correct format. Either: | |
4825 | ||
4826 | file://localhost/whatever/ftp/pub/CPAN/ | |
4827 | ||
4828 | or | |
4829 | ||
4830 | file:///home/ftp/pub/CPAN/ | |
4831 | ||
2e2b7522 | 4832 | =head2 urllist parameter has CD-ROM support |
c356248b A |
4833 | |
4834 | The C<urllist> parameter of the configuration table contains a list of | |
4835 | URLs that are to be used for downloading. If the list contains any | |
4836 | C<file> URLs, CPAN always tries to get files from there first. This | |
4837 | feature is disabled for index files. So the recommendation for the | |
4838 | owner of a CD-ROM with CPAN contents is: include your local, possibly | |
4839 | outdated CD-ROM as a C<file> URL at the end of urllist, e.g. | |
4840 | ||
4841 | o conf urllist push file://localhost/CDROM/CPAN | |
4842 | ||
4843 | CPAN.pm will then fetch the index files from one of the CPAN sites | |
4844 | that come at the beginning of urllist. It will later check for each | |
4845 | module if there is a local copy of the most recent version. | |
4846 | ||
2e2b7522 GS |
4847 | Another peculiarity of urllist is that the site that we could |
4848 | successfully fetch the last file from automatically gets a preference | |
4849 | token and is tried as the first site for the next request. So if you | |
4850 | add a new site at runtime it may happen that the previously preferred | |
4851 | site will be tried another time. This means that if you want to disallow | |
4852 | a site for the next transfer, it must be explicitly removed from | |
4853 | urllist. | |
4854 | ||
5f05dabc | 4855 | =head1 SECURITY |
4856 | ||
4857 | There's no strong security layer in CPAN.pm. CPAN.pm helps you to | |
4858 | install foreign, unmasked, unsigned code on your machine. We compare | |
4859 | to a checksum that comes from the net just as the distribution file | |
4860 | itself. If somebody has managed to tamper with the distribution file, | |
4861 | they may have as well tampered with the CHECKSUMS file. Future | |
f14b5cec | 4862 | development will go towards strong authentication. |
5f05dabc | 4863 | |
4864 | =head1 EXPORT | |
4865 | ||
4866 | Most functions in package CPAN are exported per default. The reason | |
4867 | for this is that the primary use is intended for the cpan shell or for | |
4868 | oneliners. | |
4869 | ||
f610777f A |
4870 | =head1 POPULATE AN INSTALLATION WITH LOTS OF MODULES |
4871 | ||
4872 | To populate a freshly installed perl with my favorite modules is pretty | |
4873 | easiest by maintaining a private bundle definition file. To get a useful | |
4874 | blueprint of a bundle definition file, the command autobundle can be used | |
4875 | on the CPAN shell command line. This command writes a bundle definition | |
36263cb3 | 4876 | file for all modules that are installed for the currently running perl |
f610777f A |
4877 | interpreter. It's recommended to run this command only once and from then |
4878 | on maintain the file manually under a private name, say | |
4879 | Bundle/my_bundle.pm. With a clever bundle file you can then simply say | |
4880 | ||
4881 | cpan> install Bundle::my_bundle | |
4882 | ||
36263cb3 | 4883 | then answer a few questions and then go out for a coffee. |
f610777f | 4884 | |
36263cb3 GS |
4885 | Maintaining a bundle definition file means to keep track of two |
4886 | things: dependencies and interactivity. CPAN.pm sometimes fails on | |
4887 | calculating dependencies because not all modules define all MakeMaker | |
4888 | attributes correctly, so a bundle definition file should specify | |
4889 | prerequisites as early as possible. On the other hand, it's a bit | |
4890 | annoying that many distributions need some interactive configuring. So | |
4891 | what I try to accomplish in my private bundle file is to have the | |
4892 | packages that need to be configured early in the file and the gentle | |
4893 | ones later, so I can go out after a few minutes and leave CPAN.pm | |
4894 | unattained. | |
f610777f A |
4895 | |
4896 | =head1 WORKING WITH CPAN.pm BEHIND FIREWALLS | |
4897 | ||
36263cb3 GS |
4898 | Thanks to Graham Barr for contributing the following paragraphs about |
4899 | the interaction between perl, and various firewall configurations. | |
f610777f A |
4900 | |
4901 | Firewalls can be categorized into three basic types. | |
4902 | ||
4903 | =over | |
4904 | ||
4905 | =item http firewall | |
4906 | ||
4907 | This is where the firewall machine runs a web server and to access the | |
4908 | outside world you must do it via the web server. If you set environment | |
4909 | variables like http_proxy or ftp_proxy to a values beginning with http:// | |
4910 | or in your web browser you have to set proxy information then you know | |
4911 | you are running a http firewall. | |
4912 | ||
4913 | To access servers outside these types of firewalls with perl (even for | |
4914 | ftp) you will need to use LWP. | |
4915 | ||
4916 | =item ftp firewall | |
4917 | ||
4918 | This where the firewall machine runs a ftp server. This kind of firewall will | |
4919 | only let you access ftp serves outside the firewall. This is usually done by | |
4920 | connecting to the firewall with ftp, then entering a username like | |
4921 | "user@outside.host.com" | |
4922 | ||
4923 | To access servers outside these type of firewalls with perl you | |
4924 | will need to use Net::FTP. | |
4925 | ||
4926 | =item One way visibility | |
4927 | ||
f14b5cec | 4928 | I say one way visibility as these firewalls try to make themselve look |
f610777f A |
4929 | invisible to the users inside the firewall. An FTP data connection is |
4930 | normally created by sending the remote server your IP address and then | |
4931 | listening for the connection. But the remote server will not be able to | |
4932 | connect to you because of the firewall. So for these types of firewall | |
4933 | FTP connections need to be done in a passive mode. | |
4934 | ||
4935 | There are two that I can think off. | |
4936 | ||
4937 | =over | |
4938 | ||
4939 | =item SOCKS | |
4940 | ||
4941 | If you are using a SOCKS firewall you will need to compile perl and link | |
4942 | it with the SOCKS library, this is what is normally called a ``socksified'' | |
4943 | perl. With this executable you will be able to connect to servers outside | |
4944 | the firewall as if it is not there. | |
4945 | ||
4946 | =item IP Masquerade | |
4947 | ||
4948 | This is the firewall implemented in the Linux kernel, it allows you to | |
4949 | hide a complete network behind one IP address. With this firewall no | |
4950 | special compiling is need as you can access hosts directly. | |
4951 | ||
4952 | =back | |
4953 | ||
4954 | =back | |
4955 | ||
da199366 | 4956 | =head1 BUGS |
5f05dabc | 4957 | |
36263cb3 | 4958 | We should give coverage for B<all> of the CPAN and not just the PAUSE |
09d9d230 A |
4959 | part, right? In this discussion CPAN and PAUSE have become equal -- |
4960 | but they are not. PAUSE is authors/ and modules/. CPAN is PAUSE plus | |
4961 | the clpa/, doc/, misc/, ports/, src/, scripts/. | |
5f05dabc | 4962 | |
c356248b | 4963 | Future development should be directed towards a better integration of |
da199366 | 4964 | the other parts. |
5f05dabc | 4965 | |
09d9d230 A |
4966 | If a Makefile.PL requires special customization of libraries, prompts |
4967 | the user for special input, etc. then you may find CPAN is not able to | |
4968 | build the distribution. In that case, you should attempt the | |
4969 | traditional method of building a Perl module package from a shell. | |
4970 | ||
5f05dabc | 4971 | =head1 AUTHOR |
4972 | ||
2e2b7522 | 4973 | Andreas König E<lt>a.koenig@kulturbox.deE<gt> |
5f05dabc | 4974 | |
4975 | =head1 SEE ALSO | |
4976 | ||
4977 | perl(1), CPAN::Nox(3) | |
4978 | ||
4979 | =cut | |
4980 |