File Coverage

blib/lib/CPAN/Shell.pm
Criterion Covered Total %
statement 80 1034 7.7
branch 31 614 5.0
condition 8 160 5.0
subroutine 14 63 22.2
pod 0 47 0.0
total 133 1918 6.9


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