Commit | Line | Data |
f9916dde |
1 | package CPAN::Shell; |
2 | use strict; |
3 | |
4 | # -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*- |
5 | # vim: ts=4 sts=4 sw=4: |
6 | |
7 | use vars qw( |
8 | $ADVANCED_QUERY |
9 | $AUTOLOAD |
10 | $COLOR_REGISTERED |
11 | $Help |
12 | $autoload_recursion |
13 | $reload |
14 | @ISA |
15 | @relo |
16 | $VERSION |
17 | ); |
18 | @relo = ( |
19 | "CPAN.pm", |
2f2071b1 |
20 | "CPAN/Author.pm", |
21 | "CPAN/CacheMgr.pm", |
22 | "CPAN/Complete.pm", |
f9916dde |
23 | "CPAN/Debug.pm", |
2f2071b1 |
24 | "CPAN/DeferredCode.pm", |
25 | "CPAN/Distribution.pm", |
f9916dde |
26 | "CPAN/Distroprefs.pm", |
2f2071b1 |
27 | "CPAN/Distrostatus.pm", |
28 | "CPAN/Exception/RecursiveDependency.pm", |
29 | "CPAN/Exception/yaml_not_installed.pm", |
f9916dde |
30 | "CPAN/FirstTime.pm", |
2f2071b1 |
31 | "CPAN/FTP.pm", |
32 | "CPAN/FTP/netrc.pm", |
f9916dde |
33 | "CPAN/HandleConfig.pm", |
2f2071b1 |
34 | "CPAN/Index.pm", |
35 | "CPAN/InfoObj.pm", |
f9916dde |
36 | "CPAN/Kwalify.pm", |
2f2071b1 |
37 | "CPAN/LWP/UserAgent.pm", |
38 | "CPAN/Module.pm", |
39 | "CPAN/Prompt.pm", |
f9916dde |
40 | "CPAN/Queue.pm", |
41 | "CPAN/Reporter/Config.pm", |
42 | "CPAN/Reporter/History.pm", |
43 | "CPAN/Reporter/PrereqCheck.pm", |
44 | "CPAN/Reporter.pm", |
2f2071b1 |
45 | "CPAN/Shell.pm", |
f9916dde |
46 | "CPAN/SQLite.pm", |
47 | "CPAN/Tarzip.pm", |
48 | "CPAN/Version.pm", |
49 | ); |
50 | $VERSION = "5.5"; |
51 | # record the initial timestamp for reload. |
52 | $reload = { map {$INC{$_} ? ($_,(stat $INC{$_})[9]) : ()} @relo }; |
53 | @CPAN::Shell::ISA = qw(CPAN::Debug); |
54 | use Cwd qw(chdir); |
55 | use Carp (); |
56 | $COLOR_REGISTERED ||= 0; |
57 | $Help = { |
58 | '?' => \"help", |
59 | '!' => "eval the rest of the line as perl", |
60 | a => "whois author", |
61 | autobundle => "write inventory into a bundle file", |
62 | b => "info about bundle", |
63 | bye => \"quit", |
64 | clean => "clean up a distribution's build directory", |
65 | # cvs_import |
66 | d => "info about a distribution", |
67 | # dump |
68 | exit => \"quit", |
69 | failed => "list all failed actions within current session", |
70 | fforce => "redo a command from scratch", |
71 | force => "redo a command", |
72 | get => "download a distribution", |
73 | h => \"help", |
74 | help => "overview over commands; 'help ...' explains specific commands", |
75 | hosts => "statistics about recently used hosts", |
76 | i => "info about authors/bundles/distributions/modules", |
77 | install => "install a distribution", |
78 | install_tested => "install all distributions tested OK", |
79 | is_tested => "list all distributions tested OK", |
80 | look => "open a subshell in a distribution's directory", |
81 | ls => "list distributions matching a fileglob", |
82 | m => "info about a module", |
83 | make => "make/build a distribution", |
84 | mkmyconfig => "write current config into a CPAN/MyConfig.pm file", |
85 | notest => "run a (usually install) command but leave out the test phase", |
86 | o => "'o conf ...' for config stuff; 'o debug ...' for debugging", |
87 | perldoc => "try to get a manpage for a module", |
88 | q => \"quit", |
89 | quit => "leave the cpan shell", |
90 | r => "review upgradable modules", |
91 | readme => "display the README of a distro with a pager", |
92 | recent => "show recent uploads to the CPAN", |
93 | # recompile |
94 | reload => "'reload cpan' or 'reload index'", |
95 | report => "test a distribution and send a test report to cpantesters", |
96 | reports => "info about reported tests from cpantesters", |
97 | # scripts |
98 | # smoke |
99 | test => "test a distribution", |
100 | u => "display uninstalled modules", |
101 | upgrade => "combine 'r' command with immediate installation", |
102 | }; |
103 | { |
104 | $autoload_recursion ||= 0; |
105 | |
106 | #-> sub CPAN::Shell::AUTOLOAD ; |
107 | sub AUTOLOAD { ## no critic |
108 | $autoload_recursion++; |
109 | my($l) = $AUTOLOAD; |
110 | my $class = shift(@_); |
111 | # warn "autoload[$l] class[$class]"; |
112 | $l =~ s/.*:://; |
113 | if ($CPAN::Signal) { |
114 | warn "Refusing to autoload '$l' while signal pending"; |
115 | $autoload_recursion--; |
116 | return; |
117 | } |
118 | if ($autoload_recursion > 1) { |
119 | my $fullcommand = join " ", map { "'$_'" } $l, @_; |
120 | warn "Refusing to autoload $fullcommand in recursion\n"; |
121 | $autoload_recursion--; |
122 | return; |
123 | } |
124 | if ($l =~ /^w/) { |
125 | # XXX needs to be reconsidered |
126 | if ($CPAN::META->has_inst('CPAN::WAIT')) { |
127 | CPAN::WAIT->$l(@_); |
128 | } else { |
129 | $CPAN::Frontend->mywarn(qq{ |
130 | Commands starting with "w" require CPAN::WAIT to be installed. |
131 | Please consider installing CPAN::WAIT to use the fulltext index. |
132 | For this you just need to type |
133 | install CPAN::WAIT |
134 | }); |
135 | } |
136 | } else { |
137 | $CPAN::Frontend->mywarn(qq{Unknown shell command '$l'. }. |
138 | qq{Type ? for help. |
139 | }); |
140 | } |
141 | $autoload_recursion--; |
142 | } |
143 | } |
144 | |
145 | |
146 | #-> sub CPAN::Shell::h ; |
147 | sub h { |
148 | my($class,$about) = @_; |
149 | if (defined $about) { |
150 | my $help; |
151 | if (exists $Help->{$about}) { |
152 | if (ref $Help->{$about}) { # aliases |
153 | $about = ${$Help->{$about}}; |
154 | } |
155 | $help = $Help->{$about}; |
156 | } else { |
157 | $help = "No help available"; |
158 | } |
159 | $CPAN::Frontend->myprint("$about\: $help\n"); |
160 | } else { |
161 | my $filler = " " x (80 - 28 - length($CPAN::VERSION)); |
162 | $CPAN::Frontend->myprint(qq{ |
163 | Display Information $filler (ver $CPAN::VERSION) |
164 | command argument description |
165 | a,b,d,m WORD or /REGEXP/ about authors, bundles, distributions, modules |
166 | i WORD or /REGEXP/ about any of the above |
167 | ls AUTHOR or GLOB about files in the author's directory |
168 | (with WORD being a module, bundle or author name or a distribution |
169 | name of the form AUTHOR/DISTRIBUTION) |
170 | |
171 | Download, Test, Make, Install... |
172 | get download clean make clean |
173 | make make (implies get) look open subshell in dist directory |
174 | test make test (implies make) readme display these README files |
175 | install make install (implies test) perldoc display POD documentation |
176 | |
177 | Upgrade |
178 | r WORDs or /REGEXP/ or NONE report updates for some/matching/all modules |
179 | upgrade WORDs or /REGEXP/ or NONE upgrade some/matching/all modules |
180 | |
181 | Pragmas |
182 | force CMD try hard to do command fforce CMD try harder |
183 | notest CMD skip testing |
184 | |
185 | Other |
186 | h,? display this menu ! perl-code eval a perl command |
187 | o conf [opt] set and query options q quit the cpan shell |
188 | reload cpan load CPAN.pm again reload index load newer indices |
189 | autobundle Snapshot recent latest CPAN uploads}); |
190 | } |
191 | } |
192 | |
193 | *help = \&h; |
194 | |
195 | #-> sub CPAN::Shell::a ; |
196 | sub a { |
197 | my($self,@arg) = @_; |
198 | # authors are always UPPERCASE |
199 | for (@arg) { |
200 | $_ = uc $_ unless /=/; |
201 | } |
202 | $CPAN::Frontend->myprint($self->format_result('Author',@arg)); |
203 | } |
204 | |
205 | #-> sub CPAN::Shell::globls ; |
206 | sub globls { |
207 | my($self,$s,$pragmas) = @_; |
208 | # ls is really very different, but we had it once as an ordinary |
209 | # command in the Shell (upto rev. 321) and we could not handle |
210 | # force well then |
211 | my(@accept,@preexpand); |
212 | if ($s =~ /[\*\?\/]/) { |
213 | if ($CPAN::META->has_inst("Text::Glob")) { |
214 | if (my($au,$pathglob) = $s =~ m|(.*?)/(.*)|) { |
215 | my $rau = Text::Glob::glob_to_regex(uc $au); |
216 | CPAN::Shell->debug("au[$au]pathglob[$pathglob]rau[$rau]") |
217 | if $CPAN::DEBUG; |
218 | push @preexpand, map { $_->id . "/" . $pathglob } |
219 | CPAN::Shell->expand_by_method('CPAN::Author',['id'],"/$rau/"); |
220 | } else { |
221 | my $rau = Text::Glob::glob_to_regex(uc $s); |
222 | push @preexpand, map { $_->id } |
223 | CPAN::Shell->expand_by_method('CPAN::Author', |
224 | ['id'], |
225 | "/$rau/"); |
226 | } |
227 | } else { |
228 | $CPAN::Frontend->mydie("Text::Glob not installed, cannot proceed"); |
229 | } |
230 | } else { |
231 | push @preexpand, uc $s; |
232 | } |
233 | for (@preexpand) { |
234 | unless (/^[A-Z0-9\-]+(\/|$)/i) { |
235 | $CPAN::Frontend->mywarn("ls command rejects argument $_: not an author\n"); |
236 | next; |
237 | } |
238 | push @accept, $_; |
239 | } |
240 | my $silent = @accept>1; |
241 | my $last_alpha = ""; |
242 | my @results; |
243 | for my $a (@accept) { |
244 | my($author,$pathglob); |
245 | if ($a =~ m|(.*?)/(.*)|) { |
246 | my $a2 = $1; |
247 | $pathglob = $2; |
248 | $author = CPAN::Shell->expand_by_method('CPAN::Author', |
249 | ['id'], |
250 | $a2) |
251 | or $CPAN::Frontend->mydie("No author found for $a2\n"); |
252 | } else { |
253 | $author = CPAN::Shell->expand_by_method('CPAN::Author', |
254 | ['id'], |
255 | $a) |
256 | or $CPAN::Frontend->mydie("No author found for $a\n"); |
257 | } |
258 | if ($silent) { |
259 | my $alpha = substr $author->id, 0, 1; |
260 | my $ad; |
261 | if ($alpha eq $last_alpha) { |
262 | $ad = ""; |
263 | } else { |
264 | $ad = "[$alpha]"; |
265 | $last_alpha = $alpha; |
266 | } |
267 | $CPAN::Frontend->myprint($ad); |
268 | } |
269 | for my $pragma (@$pragmas) { |
270 | if ($author->can($pragma)) { |
271 | $author->$pragma(); |
272 | } |
273 | } |
2f2071b1 |
274 | CPAN->debug("author[$author]pathglob[$pathglob]silent[$silent]") if $CPAN::DEBUG; |
f9916dde |
275 | push @results, $author->ls($pathglob,$silent); # silent if |
276 | # more than one |
277 | # author |
278 | for my $pragma (@$pragmas) { |
279 | my $unpragma = "un$pragma"; |
280 | if ($author->can($unpragma)) { |
281 | $author->$unpragma(); |
282 | } |
283 | } |
284 | } |
285 | @results; |
286 | } |
287 | |
288 | #-> sub CPAN::Shell::local_bundles ; |
289 | sub local_bundles { |
290 | my($self,@which) = @_; |
291 | my($incdir,$bdir,$dh); |
292 | foreach $incdir ($CPAN::Config->{'cpan_home'},@INC) { |
293 | my @bbase = "Bundle"; |
294 | while (my $bbase = shift @bbase) { |
295 | $bdir = File::Spec->catdir($incdir,split /::/, $bbase); |
296 | CPAN->debug("bdir[$bdir]\@bbase[@bbase]") if $CPAN::DEBUG; |
297 | if ($dh = DirHandle->new($bdir)) { # may fail |
298 | my($entry); |
299 | for $entry ($dh->read) { |
300 | next if $entry =~ /^\./; |
301 | next unless $entry =~ /^\w+(\.pm)?(?!\n)\Z/; |
302 | if (-d File::Spec->catdir($bdir,$entry)) { |
303 | push @bbase, "$bbase\::$entry"; |
304 | } else { |
305 | next unless $entry =~ s/\.pm(?!\n)\Z//; |
306 | $CPAN::META->instance('CPAN::Bundle',"$bbase\::$entry"); |
307 | } |
308 | } |
309 | } |
310 | } |
311 | } |
312 | } |
313 | |
314 | #-> sub CPAN::Shell::b ; |
315 | sub b { |
316 | my($self,@which) = @_; |
317 | CPAN->debug("which[@which]") if $CPAN::DEBUG; |
318 | $self->local_bundles; |
319 | $CPAN::Frontend->myprint($self->format_result('Bundle',@which)); |
320 | } |
321 | |
322 | #-> sub CPAN::Shell::d ; |
323 | sub d { $CPAN::Frontend->myprint(shift->format_result('Distribution',@_));} |
324 | |
325 | #-> sub CPAN::Shell::m ; |
326 | sub m { # emacs confused here }; sub mimimimimi { # emacs in sync here |
327 | my $self = shift; |
328 | $CPAN::Frontend->myprint($self->format_result('Module',@_)); |
329 | } |
330 | |
331 | #-> sub CPAN::Shell::i ; |
332 | sub i { |
333 | my($self) = shift; |
334 | my(@args) = @_; |
335 | @args = '/./' unless @args; |
336 | my(@result); |
337 | for my $type (qw/Bundle Distribution Module/) { |
338 | push @result, $self->expand($type,@args); |
339 | } |
340 | # Authors are always uppercase. |
341 | push @result, $self->expand("Author", map { uc $_ } @args); |
342 | |
343 | my $result = @result == 1 ? |
344 | $result[0]->as_string : |
345 | @result == 0 ? |
346 | "No objects found of any type for argument @args\n" : |
347 | join("", |
348 | (map {$_->as_glimpse} @result), |
349 | scalar @result, " items found\n", |
350 | ); |
351 | $CPAN::Frontend->myprint($result); |
352 | } |
353 | |
354 | #-> sub CPAN::Shell::o ; |
355 | |
356 | # CPAN::Shell::o and CPAN::HandleConfig::edit are closely related. 'o |
357 | # conf' calls through to CPAN::HandleConfig::edit. 'o conf' should |
358 | # probably have been called 'set' and 'o debug' maybe 'set debug' or |
359 | # 'debug'; 'o conf ARGS' calls ->edit in CPAN/HandleConfig.pm |
360 | sub o { |
361 | my($self,$o_type,@o_what) = @_; |
362 | $o_type ||= ""; |
363 | CPAN->debug("o_type[$o_type] o_what[".join(" | ",@o_what)."]\n"); |
364 | if ($o_type eq 'conf') { |
365 | my($cfilter); |
366 | ($cfilter) = $o_what[0] =~ m|^/(.*)/$| if @o_what; |
367 | if (!@o_what or $cfilter) { # print all things, "o conf" |
368 | $cfilter ||= ""; |
369 | my $qrfilter = eval 'qr/$cfilter/'; |
370 | my($k,$v); |
371 | $CPAN::Frontend->myprint("\$CPAN::Config options from "); |
372 | my @from; |
373 | if (exists $INC{'CPAN/Config.pm'}) { |
374 | push @from, $INC{'CPAN/Config.pm'}; |
375 | } |
376 | if (exists $INC{'CPAN/MyConfig.pm'}) { |
377 | push @from, $INC{'CPAN/MyConfig.pm'}; |
378 | } |
379 | $CPAN::Frontend->myprint(join " and ", map {"'$_'"} @from); |
380 | $CPAN::Frontend->myprint(":\n"); |
381 | for $k (sort keys %CPAN::HandleConfig::can) { |
382 | next unless $k =~ /$qrfilter/; |
383 | $v = $CPAN::HandleConfig::can{$k}; |
384 | $CPAN::Frontend->myprint(sprintf " %-18s [%s]\n", $k, $v); |
385 | } |
386 | $CPAN::Frontend->myprint("\n"); |
387 | for $k (sort keys %CPAN::HandleConfig::keys) { |
388 | next unless $k =~ /$qrfilter/; |
389 | CPAN::HandleConfig->prettyprint($k); |
390 | } |
391 | $CPAN::Frontend->myprint("\n"); |
392 | } else { |
393 | if (CPAN::HandleConfig->edit(@o_what)) { |
394 | } else { |
395 | $CPAN::Frontend->myprint(qq{Type 'o conf' to view all configuration }. |
396 | qq{items\n\n}); |
397 | } |
398 | } |
399 | } elsif ($o_type eq 'debug') { |
400 | my(%valid); |
401 | @o_what = () if defined $o_what[0] && $o_what[0] =~ /help/i; |
402 | if (@o_what) { |
403 | while (@o_what) { |
404 | my($what) = shift @o_what; |
405 | if ($what =~ s/^-// && exists $CPAN::DEBUG{$what}) { |
406 | $CPAN::DEBUG &= $CPAN::DEBUG ^ $CPAN::DEBUG{$what}; |
407 | next; |
408 | } |
409 | if ( exists $CPAN::DEBUG{$what} ) { |
410 | $CPAN::DEBUG |= $CPAN::DEBUG{$what}; |
411 | } elsif ($what =~ /^\d/) { |
412 | $CPAN::DEBUG = $what; |
413 | } elsif (lc $what eq 'all') { |
414 | my($max) = 0; |
415 | for (values %CPAN::DEBUG) { |
416 | $max += $_; |
417 | } |
418 | $CPAN::DEBUG = $max; |
419 | } else { |
420 | my($known) = 0; |
421 | for (keys %CPAN::DEBUG) { |
422 | next unless lc($_) eq lc($what); |
423 | $CPAN::DEBUG |= $CPAN::DEBUG{$_}; |
424 | $known = 1; |
425 | } |
426 | $CPAN::Frontend->myprint("unknown argument [$what]\n") |
427 | unless $known; |
428 | } |
429 | } |
430 | } else { |
431 | my $raw = "Valid options for debug are ". |
432 | join(", ",sort(keys %CPAN::DEBUG), 'all'). |
433 | qq{ or a number. Completion works on the options. }. |
434 | qq{Case is ignored.}; |
435 | require Text::Wrap; |
436 | $CPAN::Frontend->myprint(Text::Wrap::fill("","",$raw)); |
437 | $CPAN::Frontend->myprint("\n\n"); |
438 | } |
439 | if ($CPAN::DEBUG) { |
440 | $CPAN::Frontend->myprint("Options set for debugging ($CPAN::DEBUG):\n"); |
441 | my($k,$v); |
442 | for $k (sort {$CPAN::DEBUG{$a} <=> $CPAN::DEBUG{$b}} keys %CPAN::DEBUG) { |
443 | $v = $CPAN::DEBUG{$k}; |
444 | $CPAN::Frontend->myprint(sprintf " %-14s(%s)\n", $k, $v) |
445 | if $v & $CPAN::DEBUG; |
446 | } |
447 | } else { |
448 | $CPAN::Frontend->myprint("Debugging turned off completely.\n"); |
449 | } |
450 | } else { |
451 | $CPAN::Frontend->myprint(qq{ |
452 | Known options: |
453 | conf set or get configuration variables |
454 | debug set or get debugging options |
455 | }); |
456 | } |
457 | } |
458 | |
459 | # CPAN::Shell::paintdots_onreload |
460 | sub paintdots_onreload { |
461 | my($ref) = shift; |
462 | sub { |
463 | if ( $_[0] =~ /[Ss]ubroutine ([\w:]+) redefined/ ) { |
464 | my($subr) = $1; |
465 | ++$$ref; |
466 | local($|) = 1; |
467 | # $CPAN::Frontend->myprint(".($subr)"); |
468 | $CPAN::Frontend->myprint("."); |
469 | if ($subr =~ /\bshell\b/i) { |
470 | # warn "debug[$_[0]]"; |
471 | |
472 | # It would be nice if we could detect that a |
473 | # subroutine has actually changed, but for now we |
474 | # practically always set the GOTOSHELL global |
475 | |
476 | $CPAN::GOTOSHELL=1; |
477 | } |
478 | return; |
479 | } |
480 | warn @_; |
481 | }; |
482 | } |
483 | |
484 | #-> sub CPAN::Shell::hosts ; |
485 | sub hosts { |
486 | my($self) = @_; |
487 | my $fullstats = CPAN::FTP->_ftp_statistics(); |
488 | my $history = $fullstats->{history} || []; |
489 | my %S; # statistics |
490 | while (my $last = pop @$history) { |
491 | my $attempts = $last->{attempts} or next; |
492 | my $start; |
493 | if (@$attempts) { |
494 | $start = $attempts->[-1]{start}; |
495 | if ($#$attempts > 0) { |
496 | for my $i (0..$#$attempts-1) { |
497 | my $url = $attempts->[$i]{url} or next; |
498 | $S{no}{$url}++; |
499 | } |
500 | } |
501 | } else { |
502 | $start = $last->{start}; |
503 | } |
504 | next unless $last->{thesiteurl}; # C-C? bad filenames? |
505 | $S{start} = $start; |
506 | $S{end} ||= $last->{end}; |
507 | my $dltime = $last->{end} - $start; |
508 | my $dlsize = $last->{filesize} || 0; |
509 | my $url = ref $last->{thesiteurl} ? $last->{thesiteurl}->text : $last->{thesiteurl}; |
510 | my $s = $S{ok}{$url} ||= {}; |
511 | $s->{n}++; |
512 | $s->{dlsize} ||= 0; |
513 | $s->{dlsize} += $dlsize/1024; |
514 | $s->{dltime} ||= 0; |
515 | $s->{dltime} += $dltime; |
516 | } |
517 | my $res; |
518 | for my $url (keys %{$S{ok}}) { |
519 | next if $S{ok}{$url}{dltime} == 0; # div by zero |
520 | push @{$res->{ok}}, [@{$S{ok}{$url}}{qw(n dlsize dltime)}, |
521 | $S{ok}{$url}{dlsize}/$S{ok}{$url}{dltime}, |
522 | $url, |
523 | ]; |
524 | } |
525 | for my $url (keys %{$S{no}}) { |
526 | push @{$res->{no}}, [$S{no}{$url}, |
527 | $url, |
528 | ]; |
529 | } |
530 | my $R = ""; # report |
531 | if ($S{start} && $S{end}) { |
532 | $R .= sprintf "Log starts: %s\n", $S{start} ? scalar(localtime $S{start}) : "unknown"; |
533 | $R .= sprintf "Log ends : %s\n", $S{end} ? scalar(localtime $S{end}) : "unknown"; |
534 | } |
535 | if ($res->{ok} && @{$res->{ok}}) { |
536 | $R .= sprintf "\nSuccessful downloads: |
537 | N kB secs kB/s url\n"; |
538 | my $i = 20; |
539 | for (sort { $b->[3] <=> $a->[3] } @{$res->{ok}}) { |
540 | $R .= sprintf "%4d %8d %5d %9.1f %s\n", @$_; |
541 | last if --$i<=0; |
542 | } |
543 | } |
544 | if ($res->{no} && @{$res->{no}}) { |
545 | $R .= sprintf "\nUnsuccessful downloads:\n"; |
546 | my $i = 20; |
547 | for (sort { $b->[0] <=> $a->[0] } @{$res->{no}}) { |
548 | $R .= sprintf "%4d %s\n", @$_; |
549 | last if --$i<=0; |
550 | } |
551 | } |
552 | $CPAN::Frontend->myprint($R); |
553 | } |
554 | |
555 | # here is where 'reload cpan' is done |
556 | #-> sub CPAN::Shell::reload ; |
557 | sub reload { |
558 | my($self,$command,@arg) = @_; |
559 | $command ||= ""; |
560 | $self->debug("self[$self]command[$command]arg[@arg]") if $CPAN::DEBUG; |
561 | if ($command =~ /^cpan$/i) { |
562 | my $redef = 0; |
563 | chdir $CPAN::iCwd if $CPAN::iCwd; # may fail |
564 | my $failed; |
565 | MFILE: for my $f (@relo) { |
566 | next unless exists $INC{$f}; |
567 | my $p = $f; |
568 | $p =~ s/\.pm$//; |
569 | $p =~ s|/|::|g; |
570 | $CPAN::Frontend->myprint("($p"); |
571 | local($SIG{__WARN__}) = paintdots_onreload(\$redef); |
572 | $self->_reload_this($f) or $failed++; |
573 | my $v = eval "$p\::->VERSION"; |
574 | $CPAN::Frontend->myprint("v$v)"); |
575 | } |
576 | $CPAN::Frontend->myprint("\n$redef subroutines redefined\n"); |
577 | if ($failed) { |
578 | my $errors = $failed == 1 ? "error" : "errors"; |
579 | $CPAN::Frontend->mywarn("\n$failed $errors during reload. You better quit ". |
580 | "this session.\n"); |
581 | } |
582 | } elsif ($command =~ /^index$/i) { |
583 | CPAN::Index->force_reload; |
584 | } else { |
585 | $CPAN::Frontend->myprint(qq{cpan re-evals the CPAN modules |
586 | index re-reads the index files\n}); |
587 | } |
588 | } |
589 | |
590 | # reload means only load again what we have loaded before |
591 | #-> sub CPAN::Shell::_reload_this ; |
592 | sub _reload_this { |
593 | my($self,$f,$args) = @_; |
594 | CPAN->debug("f[$f]") if $CPAN::DEBUG; |
595 | return 1 unless $INC{$f}; # we never loaded this, so we do not |
596 | # reload but say OK |
597 | my $pwd = CPAN::anycwd(); |
598 | CPAN->debug("pwd[$pwd]") if $CPAN::DEBUG; |
599 | my($file); |
600 | for my $inc (@INC) { |
601 | $file = File::Spec->catfile($inc,split /\//, $f); |
602 | last if -f $file; |
603 | $file = ""; |
604 | } |
605 | CPAN->debug("file[$file]") if $CPAN::DEBUG; |
606 | my @inc = @INC; |
607 | unless ($file && -f $file) { |
608 | # this thingie is not in the INC path, maybe CPAN/MyConfig.pm? |
609 | $file = $INC{$f}; |
610 | unless (CPAN->has_inst("File::Basename")) { |
611 | @inc = File::Basename::dirname($file); |
612 | } else { |
613 | # do we ever need this? |
614 | @inc = substr($file,0,-length($f)-1); # bring in back to me! |
615 | } |
616 | } |
617 | CPAN->debug("file[$file]inc[@inc]") if $CPAN::DEBUG; |
618 | unless (-f $file) { |
619 | $CPAN::Frontend->mywarn("Found no file to reload for '$f'\n"); |
620 | return; |
621 | } |
622 | my $mtime = (stat $file)[9]; |
623 | $reload->{$f} ||= -1; |
624 | my $must_reload = $mtime != $reload->{$f}; |
625 | $args ||= {}; |
626 | $must_reload ||= $args->{reloforce}; # o conf defaults needs this |
627 | if ($must_reload) { |
628 | my $fh = FileHandle->new($file) or |
629 | $CPAN::Frontend->mydie("Could not open $file: $!"); |
630 | local($/); |
631 | local $^W = 1; |
632 | my $content = <$fh>; |
633 | CPAN->debug(sprintf("reload file[%s] content[%s...]",$file,substr($content,0,128))) |
634 | if $CPAN::DEBUG; |
635 | delete $INC{$f}; |
636 | local @INC = @inc; |
637 | eval "require '$f'"; |
638 | if ($@) { |
639 | warn $@; |
640 | return; |
641 | } |
642 | $reload->{$f} = $mtime; |
643 | } else { |
644 | $CPAN::Frontend->myprint("__unchanged__"); |
645 | } |
646 | return 1; |
647 | } |
648 | |
649 | #-> sub CPAN::Shell::mkmyconfig ; |
650 | sub mkmyconfig { |
651 | my($self, $cpanpm, %args) = @_; |
652 | require CPAN::FirstTime; |
653 | my $home = CPAN::HandleConfig::home(); |
654 | $cpanpm = $INC{'CPAN/MyConfig.pm'} || |
655 | File::Spec->catfile(split /\//, "$home/.cpan/CPAN/MyConfig.pm"); |
656 | File::Path::mkpath(File::Basename::dirname($cpanpm)) unless -e $cpanpm; |
657 | CPAN::HandleConfig::require_myconfig_or_config(); |
658 | $CPAN::Config ||= {}; |
659 | $CPAN::Config = { |
660 | %$CPAN::Config, |
661 | build_dir => undef, |
662 | cpan_home => undef, |
663 | keep_source_where => undef, |
664 | histfile => undef, |
665 | }; |
666 | CPAN::FirstTime::init($cpanpm, %args); |
667 | } |
668 | |
669 | #-> sub CPAN::Shell::_binary_extensions ; |
670 | sub _binary_extensions { |
671 | my($self) = shift @_; |
672 | my(@result,$module,%seen,%need,$headerdone); |
673 | for $module ($self->expand('Module','/./')) { |
674 | my $file = $module->cpan_file; |
675 | next if $file eq "N/A"; |
676 | next if $file =~ /^Contact Author/; |
677 | my $dist = $CPAN::META->instance('CPAN::Distribution',$file); |
678 | next if $dist->isa_perl; |
679 | next unless $module->xs_file; |
680 | local($|) = 1; |
681 | $CPAN::Frontend->myprint("."); |
682 | push @result, $module; |
683 | } |
684 | # print join " | ", @result; |
685 | $CPAN::Frontend->myprint("\n"); |
686 | return @result; |
687 | } |
688 | |
689 | #-> sub CPAN::Shell::recompile ; |
690 | sub recompile { |
691 | my($self) = shift @_; |
692 | my($module,@module,$cpan_file,%dist); |
693 | @module = $self->_binary_extensions(); |
694 | for $module (@module) { # we force now and compile later, so we |
695 | # don't do it twice |
696 | $cpan_file = $module->cpan_file; |
697 | my $pack = $CPAN::META->instance('CPAN::Distribution',$cpan_file); |
698 | $pack->force; |
699 | $dist{$cpan_file}++; |
700 | } |
701 | for $cpan_file (sort keys %dist) { |
702 | $CPAN::Frontend->myprint(" CPAN: Recompiling $cpan_file\n\n"); |
703 | my $pack = $CPAN::META->instance('CPAN::Distribution',$cpan_file); |
704 | $pack->install; |
705 | $CPAN::Signal = 0; # it's tempting to reset Signal, so we can |
706 | # stop a package from recompiling, |
707 | # e.g. IO-1.12 when we have perl5.003_10 |
708 | } |
709 | } |
710 | |
711 | #-> sub CPAN::Shell::scripts ; |
712 | sub scripts { |
713 | my($self, $arg) = @_; |
714 | $CPAN::Frontend->mywarn(">>>> experimental command, currently unsupported <<<<\n\n"); |
715 | |
716 | for my $req (qw( HTML::LinkExtor Sort::Versions List::Util )) { |
717 | unless ($CPAN::META->has_inst($req)) { |
718 | $CPAN::Frontend->mywarn(" $req not available\n"); |
719 | } |
720 | } |
721 | my $p = HTML::LinkExtor->new(); |
722 | my $indexfile = "/home/ftp/pub/PAUSE/scripts/new/index.html"; |
723 | unless (-f $indexfile) { |
724 | $CPAN::Frontend->mydie("found no indexfile[$indexfile]\n"); |
725 | } |
726 | $p->parse_file($indexfile); |
727 | my @hrefs; |
728 | my $qrarg; |
729 | if ($arg =~ s|^/(.+)/$|$1|) { |
730 | $qrarg = eval 'qr/$arg/'; # hide construct from 5.004 |
731 | } |
732 | for my $l ($p->links) { |
733 | my $tag = shift @$l; |
734 | next unless $tag eq "a"; |
735 | my %att = @$l; |
736 | my $href = $att{href}; |
737 | next unless $href =~ s|^\.\./authors/id/./../||; |
738 | if ($arg) { |
739 | if ($qrarg) { |
740 | if ($href =~ $qrarg) { |
741 | push @hrefs, $href; |
742 | } |
743 | } else { |
744 | if ($href =~ /\Q$arg\E/) { |
745 | push @hrefs, $href; |
746 | } |
747 | } |
748 | } else { |
749 | push @hrefs, $href; |
750 | } |
751 | } |
752 | # now filter for the latest version if there is more than one of a name |
753 | my %stems; |
754 | for (sort @hrefs) { |
755 | my $href = $_; |
756 | s/-v?\d.*//; |
757 | my $stem = $_; |
758 | $stems{$stem} ||= []; |
759 | push @{$stems{$stem}}, $href; |
760 | } |
761 | for (sort keys %stems) { |
762 | my $highest; |
763 | if (@{$stems{$_}} > 1) { |
764 | $highest = List::Util::reduce { |
765 | Sort::Versions::versioncmp($a,$b) > 0 ? $a : $b |
766 | } @{$stems{$_}}; |
767 | } else { |
768 | $highest = $stems{$_}[0]; |
769 | } |
770 | $CPAN::Frontend->myprint("$highest\n"); |
771 | } |
772 | } |
773 | |
774 | #-> sub CPAN::Shell::report ; |
775 | sub report { |
776 | my($self,@args) = @_; |
777 | unless ($CPAN::META->has_inst("CPAN::Reporter")) { |
778 | $CPAN::Frontend->mydie("CPAN::Reporter not installed; cannot continue"); |
779 | } |
780 | local $CPAN::Config->{test_report} = 1; |
781 | $self->force("test",@args); # force is there so that the test be |
782 | # re-run (as documented) |
783 | } |
784 | |
785 | # compare with is_tested |
786 | #-> sub CPAN::Shell::install_tested |
787 | sub install_tested { |
788 | my($self,@some) = @_; |
789 | $CPAN::Frontend->mywarn("install_tested() must not be called with arguments.\n"), |
790 | return if @some; |
791 | CPAN::Index->reload; |
792 | |
793 | for my $b (reverse $CPAN::META->_list_sorted_descending_is_tested) { |
794 | my $yaml = "$b.yml"; |
795 | unless (-f $yaml) { |
796 | $CPAN::Frontend->mywarn("No YAML file for $b available, skipping\n"); |
797 | next; |
798 | } |
799 | my $yaml_content = CPAN->_yaml_loadfile($yaml); |
800 | my $id = $yaml_content->[0]{distribution}{ID}; |
801 | unless ($id) { |
802 | $CPAN::Frontend->mywarn("No ID found in '$yaml', skipping\n"); |
803 | next; |
804 | } |
805 | my $do = CPAN::Shell->expandany($id); |
806 | unless ($do) { |
807 | $CPAN::Frontend->mywarn("Could not expand ID '$id', skipping\n"); |
808 | next; |
809 | } |
810 | unless ($do->{build_dir}) { |
811 | $CPAN::Frontend->mywarn("Distro '$id' has no build_dir, skipping\n"); |
812 | next; |
813 | } |
814 | unless ($do->{build_dir} eq $b) { |
815 | $CPAN::Frontend->mywarn("Distro '$id' has build_dir '$do->{build_dir}' but expected '$b', skipping\n"); |
816 | next; |
817 | } |
818 | push @some, $do; |
819 | } |
820 | |
821 | $CPAN::Frontend->mywarn("No tested distributions found.\n"), |
822 | return unless @some; |
823 | |
824 | @some = grep { $_->{make_test} && ! $_->{make_test}->failed } @some; |
825 | $CPAN::Frontend->mywarn("No distributions tested with this build of perl found.\n"), |
826 | return unless @some; |
827 | |
828 | # @some = grep { not $_->uptodate } @some; |
829 | # $CPAN::Frontend->mywarn("No non-uptodate distributions tested with this build of perl found.\n"), |
830 | # return unless @some; |
831 | |
832 | CPAN->debug("some[@some]"); |
833 | for my $d (@some) { |
834 | my $id = $d->can("pretty_id") ? $d->pretty_id : $d->id; |
835 | $CPAN::Frontend->myprint("install_tested: Running for $id\n"); |
836 | $CPAN::Frontend->mysleep(1); |
837 | $self->install($d); |
838 | } |
839 | } |
840 | |
841 | #-> sub CPAN::Shell::upgrade ; |
842 | sub upgrade { |
843 | my($self,@args) = @_; |
844 | $self->install($self->r(@args)); |
845 | } |
846 | |
847 | #-> sub CPAN::Shell::_u_r_common ; |
848 | sub _u_r_common { |
849 | my($self) = shift @_; |
850 | my($what) = shift @_; |
851 | CPAN->debug("self[$self] what[$what] args[@_]") if $CPAN::DEBUG; |
852 | Carp::croak "Usage: \$obj->_u_r_common(a|r|u)" unless |
853 | $what && $what =~ /^[aru]$/; |
854 | my(@args) = @_; |
855 | @args = '/./' unless @args; |
856 | my(@result,$module,%seen,%need,$headerdone, |
857 | $version_undefs,$version_zeroes, |
858 | @version_undefs,@version_zeroes); |
859 | $version_undefs = $version_zeroes = 0; |
860 | my $sprintf = "%s%-25s%s %9s %9s %s\n"; |
861 | my @expand = $self->expand('Module',@args); |
862 | if ($CPAN::DEBUG) { # Looks like noise to me, was very useful for debugging |
863 | # for metadata cache |
864 | my $expand = scalar @expand; |
865 | $CPAN::Frontend->myprint(sprintf "%d matches in the database, time[%d]\n", $expand, time); |
866 | } |
867 | my @sexpand; |
868 | if ($] < 5.008) { |
869 | # hard to believe that the more complex sorting can lead to |
870 | # stack curruptions on older perl |
871 | @sexpand = sort {$a->id cmp $b->id} @expand; |
872 | } else { |
873 | @sexpand = map { |
874 | $_->[1] |
875 | } sort { |
876 | $b->[0] <=> $a->[0] |
877 | || |
878 | $a->[1]{ID} cmp $b->[1]{ID}, |
879 | } map { |
880 | [$_->_is_representative_module, |
881 | $_ |
882 | ] |
883 | } @expand; |
884 | } |
885 | if ($CPAN::DEBUG) { |
886 | $CPAN::Frontend->myprint(sprintf "sorted at time[%d]\n", time); |
887 | sleep 1; |
888 | } |
889 | MODULE: for $module (@sexpand) { |
890 | my $file = $module->cpan_file; |
891 | next MODULE unless defined $file; # ?? |
892 | $file =~ s!^./../!!; |
893 | my($latest) = $module->cpan_version; |
894 | my($inst_file) = $module->inst_file; |
895 | CPAN->debug("file[$file]latest[$latest]") if $CPAN::DEBUG; |
896 | my($have); |
897 | return if $CPAN::Signal; |
898 | my($next_MODULE); |
899 | eval { # version.pm involved! |
900 | if ($inst_file) { |
901 | if ($what eq "a") { |
902 | $have = $module->inst_version; |
903 | } elsif ($what eq "r") { |
904 | $have = $module->inst_version; |
905 | local($^W) = 0; |
906 | if ($have eq "undef") { |
907 | $version_undefs++; |
908 | push @version_undefs, $module->as_glimpse; |
909 | } elsif (CPAN::Version->vcmp($have,0)==0) { |
910 | $version_zeroes++; |
911 | push @version_zeroes, $module->as_glimpse; |
912 | } |
913 | ++$next_MODULE unless CPAN::Version->vgt($latest, $have); |
914 | # to be pedantic we should probably say: |
915 | # && !($have eq "undef" && $latest ne "undef" && $latest gt ""); |
916 | # to catch the case where CPAN has a version 0 and we have a version undef |
917 | } elsif ($what eq "u") { |
918 | ++$next_MODULE; |
919 | } |
920 | } else { |
921 | if ($what eq "a") { |
922 | ++$next_MODULE; |
923 | } elsif ($what eq "r") { |
924 | ++$next_MODULE; |
925 | } elsif ($what eq "u") { |
926 | $have = "-"; |
927 | } |
928 | } |
929 | }; |
930 | next MODULE if $next_MODULE; |
931 | if ($@) { |
932 | $CPAN::Frontend->mywarn |
933 | (sprintf("Error while comparing cpan/installed versions of '%s': |
934 | INST_FILE: %s |
935 | INST_VERSION: %s %s |
936 | CPAN_VERSION: %s %s |
937 | ", |
938 | $module->id, |
939 | $inst_file || "", |
940 | (defined $have ? $have : "[UNDEFINED]"), |
941 | (ref $have ? ref $have : ""), |
942 | $latest, |
943 | (ref $latest ? ref $latest : ""), |
944 | )); |
945 | next MODULE; |
946 | } |
947 | return if $CPAN::Signal; # this is sometimes lengthy |
948 | $seen{$file} ||= 0; |
949 | if ($what eq "a") { |
950 | push @result, sprintf "%s %s\n", $module->id, $have; |
951 | } elsif ($what eq "r") { |
952 | push @result, $module->id; |
953 | next MODULE if $seen{$file}++; |
954 | } elsif ($what eq "u") { |
955 | push @result, $module->id; |
956 | next MODULE if $seen{$file}++; |
957 | next MODULE if $file =~ /^Contact/; |
958 | } |
959 | unless ($headerdone++) { |
960 | $CPAN::Frontend->myprint("\n"); |
961 | $CPAN::Frontend->myprint(sprintf( |
962 | $sprintf, |
963 | "", |
964 | "Package namespace", |
965 | "", |
966 | "installed", |
967 | "latest", |
968 | "in CPAN file" |
969 | )); |
970 | } |
971 | my $color_on = ""; |
972 | my $color_off = ""; |
973 | if ( |
974 | $COLOR_REGISTERED |
975 | && |
976 | $CPAN::META->has_inst("Term::ANSIColor") |
977 | && |
978 | $module->description |
979 | ) { |
980 | $color_on = Term::ANSIColor::color("green"); |
981 | $color_off = Term::ANSIColor::color("reset"); |
982 | } |
983 | $CPAN::Frontend->myprint(sprintf $sprintf, |
984 | $color_on, |
985 | $module->id, |
986 | $color_off, |
987 | $have, |
988 | $latest, |
989 | $file); |
990 | $need{$module->id}++; |
991 | } |
992 | unless (%need) { |
993 | if ($what eq "u") { |
994 | $CPAN::Frontend->myprint("No modules found for @args\n"); |
995 | } elsif ($what eq "r") { |
996 | $CPAN::Frontend->myprint("All modules are up to date for @args\n"); |
997 | } |
998 | } |
999 | if ($what eq "r") { |
1000 | if ($version_zeroes) { |
1001 | my $s_has = $version_zeroes > 1 ? "s have" : " has"; |
1002 | $CPAN::Frontend->myprint(qq{$version_zeroes installed module$s_has }. |
1003 | qq{a version number of 0\n}); |
1004 | if ($CPAN::Config->{show_zero_versions}) { |
1005 | local $" = "\t"; |
1006 | $CPAN::Frontend->myprint(qq{ they are\n\t@version_zeroes\n}); |
1007 | $CPAN::Frontend->myprint(qq{(use 'o conf show_zero_versions 0' }. |
1008 | qq{to hide them)\n}); |
1009 | } else { |
1010 | $CPAN::Frontend->myprint(qq{(use 'o conf show_zero_versions 1' }. |
1011 | qq{to show them)\n}); |
1012 | } |
1013 | } |
1014 | if ($version_undefs) { |
1015 | my $s_has = $version_undefs > 1 ? "s have" : " has"; |
1016 | $CPAN::Frontend->myprint(qq{$version_undefs installed module$s_has no }. |
1017 | qq{parsable version number\n}); |
1018 | if ($CPAN::Config->{show_unparsable_versions}) { |
1019 | local $" = "\t"; |
1020 | $CPAN::Frontend->myprint(qq{ they are\n\t@version_undefs\n}); |
1021 | $CPAN::Frontend->myprint(qq{(use 'o conf show_unparsable_versions 0' }. |
1022 | qq{to hide them)\n}); |
1023 | } else { |
1024 | $CPAN::Frontend->myprint(qq{(use 'o conf show_unparsable_versions 1' }. |
1025 | qq{to show them)\n}); |
1026 | } |
1027 | } |
1028 | } |
1029 | @result; |
1030 | } |
1031 | |
1032 | #-> sub CPAN::Shell::r ; |
1033 | sub r { |
1034 | shift->_u_r_common("r",@_); |
1035 | } |
1036 | |
1037 | #-> sub CPAN::Shell::u ; |
1038 | sub u { |
1039 | shift->_u_r_common("u",@_); |
1040 | } |
1041 | |
1042 | #-> sub CPAN::Shell::failed ; |
1043 | sub failed { |
1044 | my($self,$only_id,$silent) = @_; |
1045 | my @failed; |
1046 | DIST: for my $d ($CPAN::META->all_objects("CPAN::Distribution")) { |
1047 | my $failed = ""; |
1048 | NAY: for my $nosayer ( # order matters! |
1049 | "unwrapped", |
1050 | "writemakefile", |
1051 | "signature_verify", |
1052 | "make", |
1053 | "make_test", |
1054 | "install", |
1055 | "make_clean", |
1056 | ) { |
1057 | next unless exists $d->{$nosayer}; |
1058 | next unless defined $d->{$nosayer}; |
1059 | next unless ( |
1060 | UNIVERSAL::can($d->{$nosayer},"failed") ? |
1061 | $d->{$nosayer}->failed : |
1062 | $d->{$nosayer} =~ /^NO/ |
1063 | ); |
1064 | next NAY if $only_id && $only_id != ( |
1065 | UNIVERSAL::can($d->{$nosayer},"commandid") |
1066 | ? |
1067 | $d->{$nosayer}->commandid |
1068 | : |
1069 | $CPAN::CurrentCommandId |
1070 | ); |
1071 | $failed = $nosayer; |
1072 | last; |
1073 | } |
1074 | next DIST unless $failed; |
1075 | my $id = $d->id; |
1076 | $id =~ s|^./../||; |
1077 | #$print .= sprintf( |
1078 | # " %-45s: %s %s\n", |
1079 | push @failed, |
1080 | ( |
1081 | UNIVERSAL::can($d->{$failed},"failed") ? |
1082 | [ |
1083 | $d->{$failed}->commandid, |
1084 | $id, |
1085 | $failed, |
1086 | $d->{$failed}->text, |
1087 | $d->{$failed}{TIME}||0, |
1088 | ] : |
1089 | [ |
1090 | 1, |
1091 | $id, |
1092 | $failed, |
1093 | $d->{$failed}, |
1094 | 0, |
1095 | ] |
1096 | ); |
1097 | } |
1098 | my $scope; |
1099 | if ($only_id) { |
1100 | $scope = "this command"; |
1101 | } elsif ($CPAN::Index::HAVE_REANIMATED) { |
1102 | $scope = "this or a previous session"; |
1103 | # it might be nice to have a section for previous session and |
1104 | # a second for this |
1105 | } else { |
1106 | $scope = "this session"; |
1107 | } |
1108 | if (@failed) { |
1109 | my $print; |
1110 | my $debug = 0; |
1111 | if ($debug) { |
1112 | $print = join "", |
1113 | map { sprintf "%5d %-45s: %s %s\n", @$_ } |
1114 | sort { $a->[0] <=> $b->[0] } @failed; |
1115 | } else { |
1116 | $print = join "", |
1117 | map { sprintf " %-45s: %s %s\n", @$_[1..3] } |
1118 | sort { |
1119 | $a->[0] <=> $b->[0] |
1120 | || |
1121 | $a->[4] <=> $b->[4] |
1122 | } @failed; |
1123 | } |
1124 | $CPAN::Frontend->myprint("Failed during $scope:\n$print"); |
1125 | } elsif (!$only_id || !$silent) { |
1126 | $CPAN::Frontend->myprint("Nothing failed in $scope\n"); |
1127 | } |
1128 | } |
1129 | |
1130 | # XXX intentionally undocumented because completely bogus, unportable, |
1131 | # useless, etc. |
1132 | |
1133 | #-> sub CPAN::Shell::status ; |
1134 | sub status { |
1135 | my($self) = @_; |
1136 | require Devel::Size; |
1137 | my $ps = FileHandle->new; |
1138 | open $ps, "/proc/$$/status"; |
1139 | my $vm = 0; |
1140 | while (<$ps>) { |
1141 | next unless /VmSize:\s+(\d+)/; |
1142 | $vm = $1; |
1143 | last; |
1144 | } |
1145 | $CPAN::Frontend->mywarn(sprintf( |
1146 | "%-27s %6d\n%-27s %6d\n", |
1147 | "vm", |
1148 | $vm, |
1149 | "CPAN::META", |
1150 | Devel::Size::total_size($CPAN::META)/1024, |
1151 | )); |
1152 | for my $k (sort keys %$CPAN::META) { |
1153 | next unless substr($k,0,4) eq "read"; |
1154 | warn sprintf " %-26s %6d\n", $k, Devel::Size::total_size($CPAN::META->{$k})/1024; |
1155 | for my $k2 (sort keys %{$CPAN::META->{$k}}) { |
1156 | warn sprintf " %-25s %6d (keys: %6d)\n", |
1157 | $k2, |
1158 | Devel::Size::total_size($CPAN::META->{$k}{$k2})/1024, |
1159 | scalar keys %{$CPAN::META->{$k}{$k2}}; |
1160 | } |
1161 | } |
1162 | } |
1163 | |
1164 | # compare with install_tested |
1165 | #-> sub CPAN::Shell::is_tested |
1166 | sub is_tested { |
1167 | my($self) = @_; |
1168 | CPAN::Index->reload; |
1169 | for my $b (reverse $CPAN::META->_list_sorted_descending_is_tested) { |
1170 | my $time; |
1171 | if ($CPAN::META->{is_tested}{$b}) { |
1172 | $time = scalar(localtime $CPAN::META->{is_tested}{$b}); |
1173 | } else { |
1174 | $time = scalar localtime; |
1175 | $time =~ s/\S/?/g; |
1176 | } |
1177 | $CPAN::Frontend->myprint(sprintf "%s %s\n", $time, $b); |
1178 | } |
1179 | } |
1180 | |
1181 | #-> sub CPAN::Shell::autobundle ; |
1182 | sub autobundle { |
1183 | my($self) = shift; |
1184 | CPAN::HandleConfig->load unless $CPAN::Config_loaded++; |
1185 | my(@bundle) = $self->_u_r_common("a",@_); |
1186 | my($todir) = File::Spec->catdir($CPAN::Config->{'cpan_home'},"Bundle"); |
1187 | File::Path::mkpath($todir); |
1188 | unless (-d $todir) { |
1189 | $CPAN::Frontend->myprint("Couldn't mkdir $todir for some reason\n"); |
1190 | return; |
1191 | } |
1192 | my($y,$m,$d) = (localtime)[5,4,3]; |
1193 | $y+=1900; |
1194 | $m++; |
1195 | my($c) = 0; |
1196 | my($me) = sprintf "Snapshot_%04d_%02d_%02d_%02d", $y, $m, $d, $c; |
1197 | my($to) = File::Spec->catfile($todir,"$me.pm"); |
1198 | while (-f $to) { |
1199 | $me = sprintf "Snapshot_%04d_%02d_%02d_%02d", $y, $m, $d, ++$c; |
1200 | $to = File::Spec->catfile($todir,"$me.pm"); |
1201 | } |
1202 | my($fh) = FileHandle->new(">$to") or Carp::croak "Can't open >$to: $!"; |
1203 | $fh->print( |
1204 | "package Bundle::$me;\n\n", |
1205 | "\$VERSION = '0.01';\n\n", |
1206 | "1;\n\n", |
1207 | "__END__\n\n", |
1208 | "=head1 NAME\n\n", |
1209 | "Bundle::$me - Snapshot of installation on ", |
1210 | $Config::Config{'myhostname'}, |
1211 | " on ", |
1212 | scalar(localtime), |
1213 | "\n\n=head1 SYNOPSIS\n\n", |
1214 | "perl -MCPAN -e 'install Bundle::$me'\n\n", |
1215 | "=head1 CONTENTS\n\n", |
1216 | join("\n", @bundle), |
1217 | "\n\n=head1 CONFIGURATION\n\n", |
1218 | Config->myconfig, |
1219 | "\n\n=head1 AUTHOR\n\n", |
1220 | "This Bundle has been generated automatically ", |
1221 | "by the autobundle routine in CPAN.pm.\n", |
1222 | ); |
1223 | $fh->close; |
1224 | $CPAN::Frontend->myprint("\nWrote bundle file |
1225 | $to\n\n"); |
1226 | } |
1227 | |
1228 | #-> sub CPAN::Shell::expandany ; |
1229 | sub expandany { |
1230 | my($self,$s) = @_; |
1231 | CPAN->debug("s[$s]") if $CPAN::DEBUG; |
1232 | if ($s =~ m|/| or substr($s,-1,1) eq ".") { # looks like a file or a directory |
1233 | $s = CPAN::Distribution->normalize($s); |
1234 | return $CPAN::META->instance('CPAN::Distribution',$s); |
1235 | # Distributions spring into existence, not expand |
1236 | } elsif ($s =~ m|^Bundle::|) { |
1237 | $self->local_bundles; # scanning so late for bundles seems |
1238 | # both attractive and crumpy: always |
1239 | # current state but easy to forget |
1240 | # somewhere |
1241 | return $self->expand('Bundle',$s); |
1242 | } else { |
1243 | return $self->expand('Module',$s) |
1244 | if $CPAN::META->exists('CPAN::Module',$s); |
1245 | } |
1246 | return; |
1247 | } |
1248 | |
1249 | #-> sub CPAN::Shell::expand ; |
1250 | sub expand { |
1251 | my $self = shift; |
1252 | my($type,@args) = @_; |
1253 | CPAN->debug("type[$type]args[@args]") if $CPAN::DEBUG; |
1254 | my $class = "CPAN::$type"; |
1255 | my $methods = ['id']; |
1256 | for my $meth (qw(name)) { |
1257 | next unless $class->can($meth); |
1258 | push @$methods, $meth; |
1259 | } |
1260 | $self->expand_by_method($class,$methods,@args); |
1261 | } |
1262 | |
1263 | #-> sub CPAN::Shell::expand_by_method ; |
1264 | sub expand_by_method { |
1265 | my $self = shift; |
1266 | my($class,$methods,@args) = @_; |
1267 | my($arg,@m); |
1268 | for $arg (@args) { |
1269 | my($regex,$command); |
1270 | if ($arg =~ m|^/(.*)/$|) { |
1271 | $regex = $1; |
1272 | # FIXME: there seem to be some ='s in the author data, which trigger |
1273 | # a failure here. This needs to be contemplated. |
1274 | # } elsif ($arg =~ m/=/) { |
1275 | # $command = 1; |
1276 | } |
1277 | my $obj; |
1278 | CPAN->debug(sprintf "class[%s]regex[%s]command[%s]", |
1279 | $class, |
1280 | defined $regex ? $regex : "UNDEFINED", |
1281 | defined $command ? $command : "UNDEFINED", |
1282 | ) if $CPAN::DEBUG; |
1283 | if (defined $regex) { |
1284 | if (CPAN::_sqlite_running()) { |
1285 | CPAN::Index->reload; |
1286 | $CPAN::SQLite->search($class, $regex); |
1287 | } |
1288 | for $obj ( |
1289 | $CPAN::META->all_objects($class) |
1290 | ) { |
1291 | unless ($obj && UNIVERSAL::can($obj,"id") && $obj->id) { |
1292 | # BUG, we got an empty object somewhere |
1293 | require Data::Dumper; |
1294 | CPAN->debug(sprintf( |
1295 | "Bug in CPAN: Empty id on obj[%s][%s]", |
1296 | $obj, |
1297 | Data::Dumper::Dumper($obj) |
1298 | )) if $CPAN::DEBUG; |
1299 | next; |
1300 | } |
1301 | for my $method (@$methods) { |
1302 | my $match = eval {$obj->$method() =~ /$regex/i}; |
1303 | if ($@) { |
1304 | my($err) = $@ =~ /^(.+) at .+? line \d+\.$/; |
1305 | $err ||= $@; # if we were too restrictive above |
1306 | $CPAN::Frontend->mydie("$err\n"); |
1307 | } elsif ($match) { |
1308 | push @m, $obj; |
1309 | last; |
1310 | } |
1311 | } |
1312 | } |
1313 | } elsif ($command) { |
1314 | die "equal sign in command disabled (immature interface), ". |
1315 | "you can set |
1316 | ! \$CPAN::Shell::ADVANCED_QUERY=1 |
1317 | to enable it. But please note, this is HIGHLY EXPERIMENTAL code |
1318 | that may go away anytime.\n" |
1319 | unless $ADVANCED_QUERY; |
1320 | my($method,$criterion) = $arg =~ /(.+?)=(.+)/; |
1321 | my($matchcrit) = $criterion =~ m/^~(.+)/; |
1322 | for my $self ( |
1323 | sort |
1324 | {$a->id cmp $b->id} |
1325 | $CPAN::META->all_objects($class) |
1326 | ) { |
1327 | my $lhs = $self->$method() or next; # () for 5.00503 |
1328 | if ($matchcrit) { |
1329 | push @m, $self if $lhs =~ m/$matchcrit/; |
1330 | } else { |
1331 | push @m, $self if $lhs eq $criterion; |
1332 | } |
1333 | } |
1334 | } else { |
1335 | my($xarg) = $arg; |
1336 | if ( $class eq 'CPAN::Bundle' ) { |
1337 | $xarg =~ s/^(Bundle::)?(.*)/Bundle::$2/; |
1338 | } elsif ($class eq "CPAN::Distribution") { |
1339 | $xarg = CPAN::Distribution->normalize($arg); |
1340 | } else { |
1341 | $xarg =~ s/:+/::/g; |
1342 | } |
1343 | if ($CPAN::META->exists($class,$xarg)) { |
1344 | $obj = $CPAN::META->instance($class,$xarg); |
1345 | } elsif ($CPAN::META->exists($class,$arg)) { |
1346 | $obj = $CPAN::META->instance($class,$arg); |
1347 | } else { |
1348 | next; |
1349 | } |
1350 | push @m, $obj; |
1351 | } |
1352 | } |
1353 | @m = sort {$a->id cmp $b->id} @m; |
1354 | if ( $CPAN::DEBUG ) { |
1355 | my $wantarray = wantarray; |
1356 | my $join_m = join ",", map {$_->id} @m; |
1357 | # $self->debug("wantarray[$wantarray]join_m[$join_m]"); |
1358 | my $count = scalar @m; |
1359 | $self->debug("class[$class]wantarray[$wantarray]count m[$count]"); |
1360 | } |
1361 | return wantarray ? @m : $m[0]; |
1362 | } |
1363 | |
1364 | #-> sub CPAN::Shell::format_result ; |
1365 | sub format_result { |
1366 | my($self) = shift; |
1367 | my($type,@args) = @_; |
1368 | @args = '/./' unless @args; |
1369 | my(@result) = $self->expand($type,@args); |
1370 | my $result = @result == 1 ? |
1371 | $result[0]->as_string : |
1372 | @result == 0 ? |
1373 | "No objects of type $type found for argument @args\n" : |
1374 | join("", |
1375 | (map {$_->as_glimpse} @result), |
1376 | scalar @result, " items found\n", |
1377 | ); |
1378 | $result; |
1379 | } |
1380 | |
1381 | #-> sub CPAN::Shell::report_fh ; |
1382 | { |
1383 | my $installation_report_fh; |
1384 | my $previously_noticed = 0; |
1385 | |
1386 | sub report_fh { |
1387 | return $installation_report_fh if $installation_report_fh; |
1388 | if ($CPAN::META->has_usable("File::Temp")) { |
1389 | $installation_report_fh |
1390 | = File::Temp->new( |
1391 | dir => File::Spec->tmpdir, |
1392 | template => 'cpan_install_XXXX', |
1393 | suffix => '.txt', |
1394 | unlink => 0, |
1395 | ); |
1396 | } |
1397 | unless ( $installation_report_fh ) { |
1398 | warn("Couldn't open installation report file; " . |
1399 | "no report file will be generated." |
1400 | ) unless $previously_noticed++; |
1401 | } |
1402 | } |
1403 | } |
1404 | |
1405 | |
1406 | # The only reason for this method is currently to have a reliable |
1407 | # debugging utility that reveals which output is going through which |
1408 | # channel. No, I don't like the colors ;-) |
1409 | |
1410 | # to turn colordebugging on, write |
1411 | # cpan> o conf colorize_output 1 |
1412 | |
1413 | #-> sub CPAN::Shell::colorize_output ; |
1414 | { |
1415 | my $print_ornamented_have_warned = 0; |
1416 | sub colorize_output { |
1417 | my $colorize_output = $CPAN::Config->{colorize_output}; |
1418 | if ($colorize_output && !$CPAN::META->has_inst("Term::ANSIColor")) { |
1419 | unless ($print_ornamented_have_warned++) { |
1420 | # no myprint/mywarn within myprint/mywarn! |
1421 | warn "Colorize_output is set to true but Term::ANSIColor is not |
1422 | installed. To activate colorized output, please install Term::ANSIColor.\n\n"; |
1423 | } |
1424 | $colorize_output = 0; |
1425 | } |
1426 | return $colorize_output; |
1427 | } |
1428 | } |
1429 | |
1430 | |
1431 | #-> sub CPAN::Shell::print_ornamented ; |
1432 | sub print_ornamented { |
1433 | my($self,$what,$ornament) = @_; |
1434 | return unless defined $what; |
1435 | |
1436 | local $| = 1; # Flush immediately |
1437 | if ( $CPAN::Be_Silent ) { |
1438 | print {report_fh()} $what; |
1439 | return; |
1440 | } |
1441 | my $swhat = "$what"; # stringify if it is an object |
1442 | if ($CPAN::Config->{term_is_latin}) { |
1443 | # note: deprecated, need to switch to $LANG and $LC_* |
1444 | # courtesy jhi: |
1445 | $swhat |
1446 | =~ s{([\xC0-\xDF])([\x80-\xBF])}{chr(ord($1)<<6&0xC0|ord($2)&0x3F)}eg; #}; |
1447 | } |
1448 | if ($self->colorize_output) { |
1449 | if ( $CPAN::DEBUG && $swhat =~ /^Debug\(/ ) { |
1450 | # if you want to have this configurable, please file a bugreport |
1451 | $ornament = $CPAN::Config->{colorize_debug} || "black on_cyan"; |
1452 | } |
1453 | my $color_on = eval { Term::ANSIColor::color($ornament) } || ""; |
1454 | if ($@) { |
1455 | print "Term::ANSIColor rejects color[$ornament]: $@\n |
1456 | Please choose a different color (Hint: try 'o conf init /color/')\n"; |
1457 | } |
1458 | # GGOLDBACH/Test-GreaterVersion-0.008 broke without this |
1459 | # $trailer construct. We want the newline be the last thing if |
1460 | # there is a newline at the end ensuring that the next line is |
1461 | # empty for other players |
1462 | my $trailer = ""; |
1463 | $trailer = $1 if $swhat =~ s/([\r\n]+)\z//; |
1464 | print $color_on, |
1465 | $swhat, |
1466 | Term::ANSIColor::color("reset"), |
1467 | $trailer; |
1468 | } else { |
1469 | print $swhat; |
1470 | } |
1471 | } |
1472 | |
1473 | #-> sub CPAN::Shell::myprint ; |
1474 | |
1475 | # where is myprint/mywarn/Frontend/etc. documented? Where to use what? |
1476 | # I think, we send everything to STDOUT and use print for normal/good |
1477 | # news and warn for news that need more attention. Yes, this is our |
1478 | # working contract for now. |
1479 | sub myprint { |
1480 | my($self,$what) = @_; |
1481 | $self->print_ornamented($what, |
1482 | $CPAN::Config->{colorize_print}||'bold blue on_white', |
1483 | ); |
1484 | } |
1485 | |
1486 | sub optprint { |
1487 | my($self,$category,$what) = @_; |
1488 | my $vname = $category . "_verbosity"; |
1489 | CPAN::HandleConfig->load unless $CPAN::Config_loaded++; |
1490 | if (!$CPAN::Config->{$vname} |
1491 | || $CPAN::Config->{$vname} =~ /^v/ |
1492 | ) { |
1493 | $CPAN::Frontend->myprint($what); |
1494 | } |
1495 | } |
1496 | |
1497 | #-> sub CPAN::Shell::myexit ; |
1498 | sub myexit { |
1499 | my($self,$what) = @_; |
1500 | $self->myprint($what); |
1501 | exit; |
1502 | } |
1503 | |
1504 | #-> sub CPAN::Shell::mywarn ; |
1505 | sub mywarn { |
1506 | my($self,$what) = @_; |
1507 | $self->print_ornamented($what, $CPAN::Config->{colorize_warn}||'bold red on_white'); |
1508 | } |
1509 | |
1510 | # only to be used for shell commands |
1511 | #-> sub CPAN::Shell::mydie ; |
1512 | sub mydie { |
1513 | my($self,$what) = @_; |
1514 | $self->mywarn($what); |
1515 | |
1516 | # If it is the shell, we want the following die to be silent, |
1517 | # but if it is not the shell, we would need a 'die $what'. We need |
1518 | # to take care that only shell commands use mydie. Is this |
1519 | # possible? |
1520 | |
1521 | die "\n"; |
1522 | } |
1523 | |
1524 | # sub CPAN::Shell::colorable_makemaker_prompt ; |
1525 | sub colorable_makemaker_prompt { |
1526 | my($foo,$bar) = @_; |
1527 | if (CPAN::Shell->colorize_output) { |
1528 | my $ornament = $CPAN::Config->{colorize_print}||'bold blue on_white'; |
1529 | my $color_on = eval { Term::ANSIColor::color($ornament); } || ""; |
1530 | print $color_on; |
1531 | } |
1532 | my $ans = ExtUtils::MakeMaker::prompt($foo,$bar); |
1533 | if (CPAN::Shell->colorize_output) { |
1534 | print Term::ANSIColor::color('reset'); |
1535 | } |
1536 | return $ans; |
1537 | } |
1538 | |
1539 | # use this only for unrecoverable errors! |
1540 | #-> sub CPAN::Shell::unrecoverable_error ; |
1541 | sub unrecoverable_error { |
1542 | my($self,$what) = @_; |
1543 | my @lines = split /\n/, $what; |
1544 | my $longest = 0; |
1545 | for my $l (@lines) { |
1546 | $longest = length $l if length $l > $longest; |
1547 | } |
1548 | $longest = 62 if $longest > 62; |
1549 | for my $l (@lines) { |
1550 | if ($l =~ /^\s*$/) { |
1551 | $l = "\n"; |
1552 | next; |
1553 | } |
1554 | $l = "==> $l"; |
1555 | if (length $l < 66) { |
1556 | $l = pack "A66 A*", $l, "<=="; |
1557 | } |
1558 | $l .= "\n"; |
1559 | } |
1560 | unshift @lines, "\n"; |
1561 | $self->mydie(join "", @lines); |
1562 | } |
1563 | |
1564 | #-> sub CPAN::Shell::mysleep ; |
1565 | sub mysleep { |
1566 | my($self, $sleep) = @_; |
1567 | if (CPAN->has_inst("Time::HiRes")) { |
1568 | Time::HiRes::sleep($sleep); |
1569 | } else { |
1570 | sleep($sleep < 1 ? 1 : int($sleep + 0.5)); |
1571 | } |
1572 | } |
1573 | |
1574 | #-> sub CPAN::Shell::setup_output ; |
1575 | sub setup_output { |
1576 | return if -t STDOUT; |
1577 | my $odef = select STDERR; |
1578 | $| = 1; |
1579 | select STDOUT; |
1580 | $| = 1; |
1581 | select $odef; |
1582 | } |
1583 | |
1584 | #-> sub CPAN::Shell::rematein ; |
1585 | # RE-adme||MA-ke||TE-st||IN-stall : nearly everything runs through here |
1586 | sub rematein { |
1587 | my $self = shift; |
1588 | my($meth,@some) = @_; |
1589 | my @pragma; |
1590 | while($meth =~ /^(ff?orce|notest)$/) { |
1591 | push @pragma, $meth; |
1592 | $meth = shift @some or |
1593 | $CPAN::Frontend->mydie("Pragma $pragma[-1] used without method: ". |
1594 | "cannot continue"); |
1595 | } |
1596 | setup_output(); |
1597 | CPAN->debug("pragma[@pragma]meth[$meth]some[@some]") if $CPAN::DEBUG; |
1598 | |
1599 | # Here is the place to set "test_count" on all involved parties to |
1600 | # 0. We then can pass this counter on to the involved |
1601 | # distributions and those can refuse to test if test_count > X. In |
1602 | # the first stab at it we could use a 1 for "X". |
1603 | |
1604 | # But when do I reset the distributions to start with 0 again? |
1605 | # Jost suggested to have a random or cycling interaction ID that |
1606 | # we pass through. But the ID is something that is just left lying |
1607 | # around in addition to the counter, so I'd prefer to set the |
1608 | # counter to 0 now, and repeat at the end of the loop. But what |
1609 | # about dependencies? They appear later and are not reset, they |
1610 | # enter the queue but not its copy. How do they get a sensible |
1611 | # test_count? |
1612 | |
1613 | # With configure_requires, "get" is vulnerable in recursion. |
1614 | |
1615 | my $needs_recursion_protection = "get|make|test|install"; |
1616 | |
1617 | # construct the queue |
1618 | my($s,@s,@qcopy); |
1619 | STHING: foreach $s (@some) { |
1620 | my $obj; |
1621 | if (ref $s) { |
1622 | CPAN->debug("s is an object[$s]") if $CPAN::DEBUG; |
1623 | $obj = $s; |
1624 | } elsif ($s =~ m|[\$\@\%]|) { # looks like a perl variable |
1625 | } elsif ($s =~ m|^/|) { # looks like a regexp |
1626 | if (substr($s,-1,1) eq ".") { |
1627 | $obj = CPAN::Shell->expandany($s); |
1628 | } else { |
1629 | $CPAN::Frontend->mywarn("Sorry, $meth with a regular expression is ". |
1630 | "not supported.\nRejecting argument '$s'\n"); |
1631 | $CPAN::Frontend->mysleep(2); |
1632 | next; |
1633 | } |
1634 | } elsif ($meth eq "ls") { |
1635 | $self->globls($s,\@pragma); |
1636 | next STHING; |
1637 | } else { |
1638 | CPAN->debug("calling expandany [$s]") if $CPAN::DEBUG; |
1639 | $obj = CPAN::Shell->expandany($s); |
1640 | } |
1641 | if (0) { |
1642 | } elsif (ref $obj) { |
1643 | if ($meth =~ /^($needs_recursion_protection)$/) { |
1644 | # it would be silly to check for recursion for look or dump |
1645 | # (we are in CPAN::Shell::rematein) |
1646 | CPAN->debug("Going to test against recursion") if $CPAN::DEBUG; |
1647 | eval { $obj->color_cmd_tmps(0,1); }; |
1648 | if ($@) { |
1649 | if (ref $@ |
1650 | and $@->isa("CPAN::Exception::RecursiveDependency")) { |
1651 | $CPAN::Frontend->mywarn($@); |
1652 | } else { |
1653 | if (0) { |
1654 | require Carp; |
1655 | Carp::confess(sprintf "DEBUG: \$\@[%s]ref[%s]", $@, ref $@); |
1656 | } |
1657 | die; |
1658 | } |
1659 | } |
1660 | } |
1661 | CPAN::Queue->queue_item(qmod => $obj->id, reqtype => "c"); |
1662 | push @qcopy, $obj; |
1663 | } elsif ($CPAN::META->exists('CPAN::Author',uc($s))) { |
1664 | $obj = $CPAN::META->instance('CPAN::Author',uc($s)); |
1665 | if ($meth =~ /^(dump|ls|reports)$/) { |
1666 | $obj->$meth(); |
1667 | } else { |
1668 | $CPAN::Frontend->mywarn( |
1669 | join "", |
1670 | "Don't be silly, you can't $meth ", |
1671 | $obj->fullname, |
1672 | " ;-)\n" |
1673 | ); |
1674 | $CPAN::Frontend->mysleep(2); |
1675 | } |
1676 | } elsif ($s =~ m|[\$\@\%]| && $meth eq "dump") { |
1677 | CPAN::InfoObj->dump($s); |
1678 | } else { |
1679 | $CPAN::Frontend |
1680 | ->mywarn(qq{Warning: Cannot $meth $s, }. |
1681 | qq{don't know what it is. |
1682 | Try the command |
1683 | |
1684 | i /$s/ |
1685 | |
1686 | to find objects with matching identifiers. |
1687 | }); |
1688 | $CPAN::Frontend->mysleep(2); |
1689 | } |
1690 | } |
1691 | |
1692 | # queuerunner (please be warned: when I started to change the |
1693 | # queue to hold objects instead of names, I made one or two |
1694 | # mistakes and never found which. I reverted back instead) |
1695 | QITEM: while (my $q = CPAN::Queue->first) { |
1696 | my $obj; |
1697 | my $s = $q->as_string; |
1698 | my $reqtype = $q->reqtype || ""; |
1699 | $obj = CPAN::Shell->expandany($s); |
1700 | unless ($obj) { |
1701 | # don't know how this can happen, maybe we should panic, |
1702 | # but maybe we get a solution from the first user who hits |
1703 | # this unfortunate exception? |
1704 | $CPAN::Frontend->mywarn("Warning: Could not expand string '$s' ". |
1705 | "to an object. Skipping.\n"); |
1706 | $CPAN::Frontend->mysleep(5); |
1707 | CPAN::Queue->delete_first($s); |
1708 | next QITEM; |
1709 | } |
1710 | $obj->{reqtype} ||= ""; |
1711 | { |
1712 | # force debugging because CPAN::SQLite somehow delivers us |
1713 | # an empty object; |
1714 | |
1715 | # local $CPAN::DEBUG = 1024; # Shell; probably fixed now |
1716 | |
1717 | CPAN->debug("s[$s]obj-reqtype[$obj->{reqtype}]". |
1718 | "q-reqtype[$reqtype]") if $CPAN::DEBUG; |
1719 | } |
1720 | if ($obj->{reqtype}) { |
1721 | if ($obj->{reqtype} eq "b" && $reqtype =~ /^[rc]$/) { |
1722 | $obj->{reqtype} = $reqtype; |
1723 | if ( |
1724 | exists $obj->{install} |
1725 | && |
1726 | ( |
1727 | UNIVERSAL::can($obj->{install},"failed") ? |
1728 | $obj->{install}->failed : |
1729 | $obj->{install} =~ /^NO/ |
1730 | ) |
1731 | ) { |
1732 | delete $obj->{install}; |
1733 | $CPAN::Frontend->mywarn |
1734 | ("Promoting $obj->{ID} from 'build_requires' to 'requires'"); |
1735 | } |
1736 | } |
1737 | } else { |
1738 | $obj->{reqtype} = $reqtype; |
1739 | } |
1740 | |
1741 | for my $pragma (@pragma) { |
1742 | if ($pragma |
1743 | && |
1744 | $obj->can($pragma)) { |
1745 | $obj->$pragma($meth); |
1746 | } |
1747 | } |
1748 | if (UNIVERSAL::can($obj, 'called_for')) { |
1749 | $obj->called_for($s); |
1750 | } |
1751 | CPAN->debug(qq{pragma[@pragma]meth[$meth]}. |
1752 | qq{ID[$obj->{ID}]}) if $CPAN::DEBUG; |
1753 | |
1754 | push @qcopy, $obj; |
1755 | if ($meth =~ /^(report)$/) { # they came here with a pragma? |
1756 | $self->$meth($obj); |
1757 | } elsif (! UNIVERSAL::can($obj,$meth)) { |
1758 | # Must never happen |
1759 | my $serialized = ""; |
1760 | if (0) { |
1761 | } elsif ($CPAN::META->has_inst("YAML::Syck")) { |
1762 | $serialized = YAML::Syck::Dump($obj); |
1763 | } elsif ($CPAN::META->has_inst("YAML")) { |
1764 | $serialized = YAML::Dump($obj); |
1765 | } elsif ($CPAN::META->has_inst("Data::Dumper")) { |
1766 | $serialized = Data::Dumper::Dumper($obj); |
1767 | } else { |
1768 | require overload; |
1769 | $serialized = overload::StrVal($obj); |
1770 | } |
1771 | CPAN->debug("Going to panic. meth[$meth]s[$s]") if $CPAN::DEBUG; |
1772 | $CPAN::Frontend->mydie("Panic: obj[$serialized] cannot meth[$meth]"); |
1773 | } elsif ($obj->$meth()) { |
1774 | CPAN::Queue->delete($s); |
1775 | CPAN->debug("From queue deleted. meth[$meth]s[$s]") if $CPAN::DEBUG; |
1776 | } else { |
1777 | CPAN->debug("Failed. pragma[@pragma]meth[$meth]") if $CPAN::DEBUG; |
1778 | } |
1779 | |
1780 | $obj->undelay; |
1781 | for my $pragma (@pragma) { |
1782 | my $unpragma = "un$pragma"; |
1783 | if ($obj->can($unpragma)) { |
1784 | $obj->$unpragma(); |
1785 | } |
1786 | } |
1787 | if ($CPAN::Config->{halt_on_failure} |
1788 | && |
1789 | CPAN::Distrostatus::something_has_just_failed() |
1790 | ) { |
1791 | $CPAN::Frontend->mywarn("Stopping: '$meth' failed for '$s'.\n"); |
1792 | CPAN::Queue->nullify_queue; |
1793 | last QITEM; |
1794 | } |
1795 | CPAN::Queue->delete_first($s); |
1796 | } |
1797 | if ($meth =~ /^($needs_recursion_protection)$/) { |
1798 | for my $obj (@qcopy) { |
1799 | $obj->color_cmd_tmps(0,0); |
1800 | } |
1801 | } |
1802 | } |
1803 | |
1804 | #-> sub CPAN::Shell::recent ; |
1805 | sub recent { |
1806 | my($self) = @_; |
1807 | if ($CPAN::META->has_inst("XML::LibXML")) { |
1808 | my $url = $CPAN::Defaultrecent; |
1809 | $CPAN::Frontend->myprint("Going to fetch '$url'\n"); |
1810 | unless ($CPAN::META->has_usable("LWP")) { |
1811 | $CPAN::Frontend->mydie("LWP not installed; cannot continue"); |
1812 | } |
1813 | CPAN::LWP::UserAgent->config; |
1814 | my $Ua; |
1815 | eval { $Ua = CPAN::LWP::UserAgent->new; }; |
1816 | if ($@) { |
1817 | $CPAN::Frontend->mydie("CPAN::LWP::UserAgent->new dies with $@\n"); |
1818 | } |
1819 | my $resp = $Ua->get($url); |
1820 | unless ($resp->is_success) { |
1821 | $CPAN::Frontend->mydie(sprintf "Could not download '%s': %s\n", $url, $resp->code); |
1822 | } |
1823 | $CPAN::Frontend->myprint("DONE\n\n"); |
1824 | my $xml = XML::LibXML->new->parse_string($resp->content); |
1825 | if (0) { |
1826 | my $s = $xml->serialize(2); |
1827 | $s =~ s/\n\s*\n/\n/g; |
1828 | $CPAN::Frontend->myprint($s); |
1829 | return; |
1830 | } |
1831 | my @distros; |
1832 | if ($url =~ /winnipeg/) { |
1833 | my $pubdate = $xml->findvalue("/rss/channel/pubDate"); |
1834 | $CPAN::Frontend->myprint(" pubDate: $pubdate\n\n"); |
1835 | for my $eitem ($xml->findnodes("/rss/channel/item")) { |
1836 | my $distro = $eitem->findvalue("enclosure/\@url"); |
1837 | $distro =~ s|.*?/authors/id/./../||; |
1838 | my $size = $eitem->findvalue("enclosure/\@length"); |
1839 | my $desc = $eitem->findvalue("description"); |
1840 | $desc =~ s/.+? - //; |
1841 | $CPAN::Frontend->myprint("$distro [$size b]\n $desc\n"); |
1842 | push @distros, $distro; |
1843 | } |
1844 | } elsif ($url =~ /search.*uploads.rdf/) { |
1845 | # xmlns:rdf="http://www.w3.org/1999/02/22-rdf-syntax-ns#" |
1846 | # xmlns="http://purl.org/rss/1.0/" |
1847 | # xmlns:taxo="http://purl.org/rss/1.0/modules/taxonomy/" |
1848 | # xmlns:dc="http://purl.org/dc/elements/1.1/" |
1849 | # xmlns:syn="http://purl.org/rss/1.0/modules/syndication/" |
1850 | # xmlns:admin="http://webns.net/mvcb/" |
1851 | |
1852 | |
1853 | my $dc_date = $xml->findvalue("//*[local-name(.) = 'RDF']/*[local-name(.) = 'channel']/*[local-name(.) = 'date']"); |
1854 | $CPAN::Frontend->myprint(" dc:date: $dc_date\n\n"); |
1855 | my $finish_eitem = 0; |
1856 | local $SIG{INT} = sub { $finish_eitem = 1 }; |
1857 | EITEM: for my $eitem ($xml->findnodes("//*[local-name(.) = 'RDF']/*[local-name(.) = 'item']")) { |
1858 | my $distro = $eitem->findvalue("\@rdf:about"); |
1859 | $distro =~ s|.*~||; # remove up to the tilde before the name |
1860 | $distro =~ s|/$||; # remove trailing slash |
1861 | $distro =~ s|([^/]+)|\U$1\E|; # upcase the name |
1862 | my $author = uc $1 or die "distro[$distro] without author, cannot continue"; |
1863 | my $desc = $eitem->findvalue("*[local-name(.) = 'description']"); |
1864 | my $i = 0; |
1865 | SUBDIRTEST: while () { |
1866 | last SUBDIRTEST if ++$i >= 6; # half a dozen must do! |
1867 | if (my @ret = $self->globls("$distro*")) { |
1868 | @ret = grep {$_->[2] !~ /meta/} @ret; |
1869 | @ret = grep {length $_->[2]} @ret; |
1870 | if (@ret) { |
1871 | $distro = "$author/$ret[0][2]"; |
1872 | last SUBDIRTEST; |
1873 | } |
1874 | } |
1875 | $distro =~ s|/|/*/|; # allow it to reside in a subdirectory |
1876 | } |
1877 | |
1878 | next EITEM if $distro =~ m|\*|; # did not find the thing |
1879 | $CPAN::Frontend->myprint("____$desc\n"); |
1880 | push @distros, $distro; |
1881 | last EITEM if $finish_eitem; |
1882 | } |
1883 | } |
1884 | return \@distros; |
1885 | } else { |
1886 | # deprecated old version |
1887 | $CPAN::Frontend->mydie("no XML::LibXML installed, cannot continue\n"); |
1888 | } |
1889 | } |
1890 | |
1891 | #-> sub CPAN::Shell::smoke ; |
1892 | sub smoke { |
1893 | my($self) = @_; |
1894 | my $distros = $self->recent; |
1895 | DISTRO: for my $distro (@$distros) { |
1896 | next if $distro =~ m|/Bundle-|; # XXX crude heuristic to skip bundles |
1897 | $CPAN::Frontend->myprint(sprintf "Going to download and test '$distro'\n"); |
1898 | { |
1899 | my $skip = 0; |
1900 | local $SIG{INT} = sub { $skip = 1 }; |
1901 | for (0..9) { |
1902 | $CPAN::Frontend->myprint(sprintf "\r%2d (Hit ^C to skip)", 10-$_); |
1903 | sleep 1; |
1904 | if ($skip) { |
1905 | $CPAN::Frontend->myprint(" skipped\n"); |
1906 | next DISTRO; |
1907 | } |
1908 | } |
1909 | } |
1910 | $CPAN::Frontend->myprint("\r \n"); # leave the dirty line with a newline |
1911 | $self->test($distro); |
1912 | } |
1913 | } |
1914 | |
1915 | { |
1916 | # set up the dispatching methods |
1917 | no strict "refs"; |
1918 | for my $command (qw( |
1919 | clean |
1920 | cvs_import |
1921 | dump |
1922 | force |
1923 | fforce |
1924 | get |
1925 | install |
1926 | look |
1927 | ls |
1928 | make |
1929 | notest |
1930 | perldoc |
1931 | readme |
1932 | reports |
1933 | test |
1934 | )) { |
1935 | *$command = sub { shift->rematein($command, @_); }; |
1936 | } |
1937 | } |
1938 | |
1939 | 1; |