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