File Coverage

blib/lib/CPAN/Shell.pm
Criterion Covered Total %
statement 80 1035 7.7
branch 31 616 5.0
condition 8 165 4.8
subroutine 14 63 22.2
pod 0 47 0.0
total 133 1926 6.9


line stmt bran cond sub pod time code
1             package CPAN::Shell;
2 13     13   98 use strict;
  13         25  
  13         585  
3              
4             # -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*-
5             # vim: ts=4 sts=4 sw=4:
6              
7 13         2976 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 13     13   75 );
  13         26  
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.5009";
51             # record the initial timestamp for reload.
52             $reload = { map {$INC{$_} ? ($_,(stat $INC{$_})[9]) : ()} @relo };
53             @CPAN::Shell::ISA = qw(CPAN::Debug);
54 13     13   113 use Cwd qw(chdir);
  13         26  
  13         759  
55 13     13   88 use Carp ();
  13         33  
  13         203308  
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   5137 $autoload_recursion++;
109 10         24 my($l) = $AUTOLOAD;
110 10         21 my $class = shift(@_);
111             # warn "autoload[$l] class[$class]";
112 10         81 $l =~ s/.*:://;
113 10 50       83 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       30 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       38 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         59 $CPAN::Frontend->mywarn(qq{Unknown shell command '$l'. }.
138             qq{Type ? for help.
139             });
140             }
141 10         46 $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     0 if (!@expand || $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 17 my($self,$s) = @_;
1282 7 50       15 CPAN->debug("s[$s]") if $CPAN::DEBUG;
1283 7         16 my $module_as_path = "";
1284 7 50       16 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     58 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       20 return $self->expand('Module',$s)
1309             if $CPAN::META->exists('CPAN::Module',$s);
1310             }
1311 7         30 return;
1312             }
1313              
1314             #-> sub CPAN::Shell::expand ;
1315             sub expand {
1316 4     4 0 1029 my $self = shift;
1317 4         16 my($type,@args) = @_;
1318 4 50       12 CPAN->debug("type[$type]args[@args]") if $CPAN::DEBUG;
1319 4         10 my $class = "CPAN::$type";
1320 4         9 my $methods = ['id'];
1321 4         14 for my $meth (qw(name)) {
1322 4 100       65 next unless $class->can($meth);
1323 1         5 push @$methods, $meth;
1324             }
1325 4         15 $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 7 my $self = shift;
1331 4         10 my($class,$methods,@args) = @_;
1332 4         6 my($arg,@m);
1333 4         8 for $arg (@args) {
1334 4         7 my($regex,$command);
1335 4 50       14 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         6 my $obj;
1343 4 0       8 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       12 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         13 my($xarg) = $arg;
1401 4 50       15 if ( $class eq 'CPAN::Bundle' ) {
    100          
1402 0         0 $xarg =~ s/^(Bundle::)?(.*)/Bundle::$2/;
1403             } elsif ($class eq "CPAN::Distribution") {
1404 1         43 $xarg = CPAN::Distribution->normalize($arg);
1405             } else {
1406 3         14 $xarg =~ s/:+/::/g;
1407             }
1408 4 50       22 if ($CPAN::META->exists($class,$xarg)) {
    0          
1409 4         13 $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         12 push @m, $obj;
1416             }
1417             }
1418 4         12 @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       29 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 241     241 0 325 my $colorize_output = $CPAN::Config->{colorize_output};
1483 241 0 33     493 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 241 50 33     472 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 241         516 return $colorize_output;
1500             }
1501             }
1502              
1503              
1504             #-> sub CPAN::Shell::print_ornamented ;
1505             sub print_ornamented {
1506 241     241 0 1056 my($self,$what,$ornament) = @_;
1507 241 50       417 return unless defined $what;
1508              
1509 241         682 local $| = 1; # Flush immediately
1510 241 50       464 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 241         350 my $swhat = "$what"; # stringify if it is an object
1516 241 50       483 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 241 50       449 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 241         7530 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 239     239 0 460 my($self,$what) = @_;
1555             $self->print_ornamented($what,
1556 239   50     1004 $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 7     7 0 39 my($self,$category,$what) = @_;
1569 7         23 my $vname = $category . "_verbosity";
1570 7 100       101 CPAN::HandleConfig->load unless $CPAN::Config_loaded++;
1571 7 100 66     164 if (!$CPAN::Config->{$vname}
1572             || $CPAN::Config->{$vname} =~ /^v/
1573             ) {
1574 5         53 $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 15 my($self,$what) = @_;
1588 2   50     22 $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,$ornament) = @_;
1615 0   0       $ornament ||= "colorize_print";
1616 0 0         if (CPAN::Shell->colorize_output) {
1617 0   0       my $ornament = $CPAN::Config->{$ornament}||'bold blue on_white';
1618 0   0       my $color_on = eval { Term::ANSIColor::color($ornament); } || "";
1619 0           print $color_on;
1620             }
1621 0           my $ans = ExtUtils::MakeMaker::prompt($foo,$bar);
1622 0 0         if (CPAN::Shell->colorize_output) {
1623 0           print Term::ANSIColor::color('reset');
1624             }
1625 0           return $ans;
1626             }
1627              
1628             # use this only for unrecoverable errors!
1629             #-> sub CPAN::Shell::unrecoverable_error ;
1630             sub unrecoverable_error {
1631 0     0 0   my($self,$what) = @_;
1632 0           my @lines = split /\n/, $what;
1633 0           my $longest = 0;
1634 0           for my $l (@lines) {
1635 0 0         $longest = length $l if length $l > $longest;
1636             }
1637 0 0         $longest = 62 if $longest > 62;
1638 0           for my $l (@lines) {
1639 0 0         if ($l =~ /^\s*$/) {
1640 0           $l = "\n";
1641 0           next;
1642             }
1643 0           $l = "==> $l";
1644 0 0         if (length $l < 66) {
1645 0           $l = pack "A66 A*", $l, "<==";
1646             }
1647 0           $l .= "\n";
1648             }
1649 0           unshift @lines, "\n";
1650 0           $self->mydie(join "", @lines);
1651             }
1652              
1653             #-> sub CPAN::Shell::mysleep ;
1654             sub mysleep {
1655 0 0 0 0 0   return if $ENV{AUTOMATED_TESTING} || ! -t STDOUT;
1656 0           my($self, $sleep) = @_;
1657 0 0         if (CPAN->has_inst("Time::HiRes")) {
1658 0           Time::HiRes::sleep($sleep);
1659             } else {
1660 0 0         sleep($sleep < 1 ? 1 : int($sleep + 0.5));
1661             }
1662             }
1663              
1664             #-> sub CPAN::Shell::setup_output ;
1665             sub setup_output {
1666 0 0   0 0   return if -t STDOUT;
1667 0           my $odef = select STDERR;
1668 0           $| = 1;
1669 0           select STDOUT;
1670 0           $| = 1;
1671 0           select $odef;
1672             }
1673              
1674             #-> sub CPAN::Shell::rematein ;
1675             # RE-adme||MA-ke||TE-st||IN-stall : nearly everything runs through here
1676             sub rematein {
1677 0     0 0   my $self = shift;
1678             # this variable was global and disturbed programmers, so localize:
1679 0           local $CPAN::Distrostatus::something_has_failed_at;
1680 0           my($meth,@some) = @_;
1681 0           my @pragma;
1682 0           while($meth =~ /^(ff?orce|notest)$/) {
1683 0           push @pragma, $meth;
1684 0 0         $meth = shift @some or
1685             $CPAN::Frontend->mydie("Pragma $pragma[-1] used without method: ".
1686             "cannot continue");
1687             }
1688 0           setup_output();
1689 0 0         CPAN->debug("pragma[@pragma]meth[$meth]some[@some]") if $CPAN::DEBUG;
1690              
1691             # Here is the place to set "test_count" on all involved parties to
1692             # 0. We then can pass this counter on to the involved
1693             # distributions and those can refuse to test if test_count > X. In
1694             # the first stab at it we could use a 1 for "X".
1695              
1696             # But when do I reset the distributions to start with 0 again?
1697             # Jost suggested to have a random or cycling interaction ID that
1698             # we pass through. But the ID is something that is just left lying
1699             # around in addition to the counter, so I'd prefer to set the
1700             # counter to 0 now, and repeat at the end of the loop. But what
1701             # about dependencies? They appear later and are not reset, they
1702             # enter the queue but not its copy. How do they get a sensible
1703             # test_count?
1704              
1705             # With configure_requires, "get" is vulnerable in recursion.
1706              
1707 0           my $needs_recursion_protection = "get|make|test|install";
1708              
1709             # construct the queue
1710 0           my($s,@s,@qcopy);
1711 0           STHING: foreach $s (@some) {
1712 0           my $obj;
1713 0 0         if (ref $s) {
    0          
    0          
    0          
1714 0 0         CPAN->debug("s is an object[$s]") if $CPAN::DEBUG;
1715 0           $obj = $s;
1716             } elsif ($s =~ m|[\$\@\%]|) { # looks like a perl variable
1717             } elsif ($s =~ m|^/|) { # looks like a regexp
1718 0 0         if (substr($s,-1,1) eq ".") {
1719 0           $obj = CPAN::Shell->expandany($s);
1720             } else {
1721 0           my @obj;
1722 0           CLASS: for my $class (qw(Distribution Bundle Module)) {
1723 0 0         if (@obj = $self->expand($class,$s)) {
1724 0           last CLASS;
1725             }
1726             }
1727 0 0         if (@obj) {
1728 0 0         if (1==@obj) {
1729 0           $obj = $obj[0];
1730             } else {
1731 0           $CPAN::Frontend->mywarn("Sorry, $meth with a regular expression is ".
1732             "only supported when unambiguous.\nRejecting argument '$s'\n");
1733 0           $CPAN::Frontend->mysleep(2);
1734 0           next STHING;
1735             }
1736             }
1737             }
1738             } elsif ($meth eq "ls") {
1739 0           $self->globls($s,\@pragma);
1740 0           next STHING;
1741             } else {
1742 0 0         CPAN->debug("calling expandany [$s]") if $CPAN::DEBUG;
1743 0           $obj = CPAN::Shell->expandany($s);
1744             }
1745 0 0 0       if (0) {
    0          
    0          
1746 0           } elsif (ref $obj) {
1747 0 0         if ($meth =~ /^($needs_recursion_protection)$/) {
1748             # it would be silly to check for recursion for look or dump
1749             # (we are in CPAN::Shell::rematein)
1750 0 0         CPAN->debug("Testing against recursion") if $CPAN::DEBUG;
1751 0           eval { $obj->color_cmd_tmps(0,1); };
  0            
1752 0 0         if ($@) {
1753 0 0 0       if (ref $@
1754             and $@->isa("CPAN::Exception::RecursiveDependency")) {
1755 0           $CPAN::Frontend->mywarn($@);
1756             } else {
1757 0           if (0) {
1758             require Carp;
1759             Carp::confess(sprintf "DEBUG: \$\@[%s]ref[%s]", $@, ref $@);
1760             }
1761 0           die;
1762             }
1763             }
1764             }
1765 0           CPAN::Queue->queue_item(qmod => $obj->id, reqtype => "c", optional => '');
1766 0           push @qcopy, $obj;
1767             } elsif ($CPAN::META->exists('CPAN::Author',uc($s))) {
1768 0           $obj = $CPAN::META->instance('CPAN::Author',uc($s));
1769 0 0         if ($meth =~ /^(dump|ls|reports)$/) {
1770 0           $obj->$meth();
1771             } else {
1772 0           $CPAN::Frontend->mywarn(
1773             join "",
1774             "Don't be silly, you can't $meth ",
1775             $obj->fullname,
1776             " ;-)\n"
1777             );
1778 0           $CPAN::Frontend->mysleep(2);
1779             }
1780             } elsif ($s =~ m|[\$\@\%]| && $meth eq "dump") {
1781 0           CPAN::InfoObj->dump($s);
1782             } else {
1783 0           $CPAN::Frontend
1784             ->mywarn(qq{Warning: Cannot $meth $s, }.
1785             qq{don't know what it is.
1786             Try the command
1787              
1788             i /$s/
1789              
1790             to find objects with matching identifiers.
1791             });
1792 0           $CPAN::Frontend->mysleep(2);
1793             }
1794             }
1795              
1796             # queuerunner (please be warned: when I started to change the
1797             # queue to hold objects instead of names, I made one or two
1798             # mistakes and never found which. I reverted back instead)
1799 0           QITEM: while (my $q = CPAN::Queue->first) {
1800 0           my $obj;
1801 0           my $s = $q->as_string;
1802 0   0       my $reqtype = $q->reqtype || "";
1803 0   0       my $optional = $q->optional || "";
1804 0           $obj = CPAN::Shell->expandany($s);
1805 0 0         unless ($obj) {
1806             # don't know how this can happen, maybe we should panic,
1807             # but maybe we get a solution from the first user who hits
1808             # this unfortunate exception?
1809 0           $CPAN::Frontend->mywarn("Warning: Could not expand string '$s' ".
1810             "to an object. Skipping.\n");
1811 0           $CPAN::Frontend->mysleep(5);
1812 0           CPAN::Queue->delete_first($s);
1813 0           next QITEM;
1814             }
1815 0   0       $obj->{reqtype} ||= "";
1816 0           my $type = ref $obj;
1817 0 0 0       if ( $type eq 'CPAN::Distribution' || $type eq 'CPAN::Bundle' ) {
    0          
1818 0   0       $obj->{mandatory} ||= ! $optional; # once mandatory, always mandatory
1819             }
1820             elsif ( $type eq 'CPAN::Module' ) {
1821 0   0       $obj->{mandatory} ||= ! $optional; # once mandatory, always mandatory
1822 0 0         if (my $d = $obj->distribution) {
    0          
1823 0   0       $d->{mandatory} ||= ! $optional; # once mandatory, always mandatory
1824             } elsif ($optional) {
1825             # the queue object does not know who was recommending/suggesting us:(
1826             # So we only vaguely write "optional".
1827 0           $CPAN::Frontend->mywarn("Warning: optional module '$s' ".
1828             "not known. Skipping.\n");
1829 0           CPAN::Queue->delete_first($s);
1830 0           next QITEM;
1831             }
1832             }
1833             {
1834             # force debugging because CPAN::SQLite somehow delivers us
1835             # an empty object;
1836              
1837             # local $CPAN::DEBUG = 1024; # Shell; probably fixed now
1838              
1839 0 0         CPAN->debug("s[$s]obj-reqtype[$obj->{reqtype}]".
  0            
1840             "q-reqtype[$reqtype]") if $CPAN::DEBUG;
1841             }
1842 0 0         if ($obj->{reqtype}) {
1843 0 0 0       if ($obj->{reqtype} eq "b" && $reqtype =~ /^[rc]$/) {
1844 0           $obj->{reqtype} = $reqtype;
1845 0 0 0       if (
    0          
1846             exists $obj->{install}
1847             &&
1848             (
1849             UNIVERSAL::can($obj->{install},"failed") ?
1850             $obj->{install}->failed :
1851             $obj->{install} =~ /^NO/
1852             )
1853             ) {
1854 0           delete $obj->{install};
1855 0           $CPAN::Frontend->mywarn
1856             ("Promoting $obj->{ID} from 'build_requires' to 'requires'");
1857             }
1858             }
1859             } else {
1860 0           $obj->{reqtype} = $reqtype;
1861             }
1862              
1863 0           for my $pragma (@pragma) {
1864 0 0 0       if ($pragma
1865             &&
1866             $obj->can($pragma)) {
1867 0           $obj->$pragma($meth);
1868             }
1869             }
1870 0 0         if (UNIVERSAL::can($obj, 'called_for')) {
1871 0 0         $obj->called_for($s) unless $obj->called_for;
1872             }
1873 0 0         CPAN->debug(qq{pragma[@pragma]meth[$meth]}.
1874             qq{ID[$obj->{ID}]}) if $CPAN::DEBUG;
1875              
1876 0           push @qcopy, $obj;
1877 0 0         if ($meth =~ /^(report)$/) { # they came here with a pragma?
    0          
1878 0           $self->$meth($obj);
1879             } elsif (! UNIVERSAL::can($obj,$meth)) {
1880             # Must never happen
1881 0           my $serialized = "";
1882 0 0         if (0) {
    0          
    0          
1883 0           } elsif ($CPAN::META->has_inst("YAML::Syck")) {
1884 0           $serialized = YAML::Syck::Dump($obj);
1885             } elsif ($CPAN::META->has_inst("YAML")) {
1886 0           $serialized = YAML::Dump($obj);
1887             } elsif ($CPAN::META->has_inst("Data::Dumper")) {
1888 0           $serialized = Data::Dumper::Dumper($obj);
1889             } else {
1890 0           require overload;
1891 0           $serialized = overload::StrVal($obj);
1892             }
1893 0 0         CPAN->debug("Going to panic. meth[$meth]s[$s]") if $CPAN::DEBUG;
1894 0           $CPAN::Frontend->mydie("Panic: obj[$serialized] cannot meth[$meth]");
1895             } else {
1896 0           my $upgraded_meth = $meth;
1897 0 0 0       if ( $meth eq "make" and $obj->{reqtype} eq "b" ) {
1898             # rt 86915
1899 0           $upgraded_meth = "test";
1900             }
1901 0 0         if ($obj->$upgraded_meth()) {
1902 0           CPAN::Queue->delete($s);
1903 0 0         CPAN->debug("Succeeded and deleted from queue. pragma[@pragma]meth[$meth][s][$s]") if $CPAN::DEBUG;
1904             } else {
1905 0 0         CPAN->debug("Failed. pragma[@pragma]meth[$meth]s[$s]") if $CPAN::DEBUG;
1906             }
1907             }
1908              
1909 0           $obj->undelay;
1910 0           for my $pragma (@pragma) {
1911 0           my $unpragma = "un$pragma";
1912 0 0         if ($obj->can($unpragma)) {
1913 0           $obj->$unpragma();
1914             }
1915             }
1916             # if any failures occurred and the current object is mandatory, we
1917             # still don't know if *it* failed or if it was another (optional)
1918             # module, so we have to check that explicitly (and expensively)
1919 0 0 0       if ( $CPAN::Config->{halt_on_failure}
      0        
      0        
1920             && $obj->{mandatory}
1921             && CPAN::Distrostatus::something_has_just_failed()
1922             && $self->mandatory_dist_failed()
1923             ) {
1924 0           $CPAN::Frontend->mywarn("Stopping: '$meth' failed for '$s'.\n");
1925 0           CPAN::Queue->nullify_queue;
1926 0           last QITEM;
1927             }
1928 0           CPAN::Queue->delete_first($s);
1929             }
1930 0 0         if ($meth =~ /^($needs_recursion_protection)$/) {
1931 0           for my $obj (@qcopy) {
1932 0           $obj->color_cmd_tmps(0,0);
1933             }
1934             }
1935             }
1936              
1937             #-> sub CPAN::Shell::recent ;
1938             sub recent {
1939 0     0 0   my($self) = @_;
1940 0 0         if ($CPAN::META->has_inst("XML::LibXML")) {
1941 0           my $url = $CPAN::Defaultrecent;
1942 0           $CPAN::Frontend->myprint("Fetching '$url'\n");
1943 0 0         unless ($CPAN::META->has_usable("LWP")) {
1944 0           $CPAN::Frontend->mydie("LWP not installed; cannot continue");
1945             }
1946 0           CPAN::LWP::UserAgent->config;
1947 0           my $Ua;
1948 0           eval { $Ua = CPAN::LWP::UserAgent->new; };
  0            
1949 0 0         if ($@) {
1950 0           $CPAN::Frontend->mydie("CPAN::LWP::UserAgent->new dies with $@\n");
1951             }
1952 0           my $resp = $Ua->get($url);
1953 0 0         unless ($resp->is_success) {
1954 0           $CPAN::Frontend->mydie(sprintf "Could not download '%s': %s\n", $url, $resp->code);
1955             }
1956 0           $CPAN::Frontend->myprint("DONE\n\n");
1957 0           my $xml = XML::LibXML->new->parse_string($resp->content);
1958 0           if (0) {
1959             my $s = $xml->serialize(2);
1960             $s =~ s/\n\s*\n/\n/g;
1961             $CPAN::Frontend->myprint($s);
1962             return;
1963             }
1964 0           my @distros;
1965 0 0         if ($url =~ /winnipeg/) {
    0          
1966 0           my $pubdate = $xml->findvalue("/rss/channel/pubDate");
1967 0           $CPAN::Frontend->myprint(" pubDate: $pubdate\n\n");
1968 0           for my $eitem ($xml->findnodes("/rss/channel/item")) {
1969 0           my $distro = $eitem->findvalue("enclosure/\@url");
1970 0           $distro =~ s|.*?/authors/id/./../||;
1971 0           my $size = $eitem->findvalue("enclosure/\@length");
1972 0           my $desc = $eitem->findvalue("description");
1973 0           $desc =~ s/.+? - //;
1974 0           $CPAN::Frontend->myprint("$distro [$size b]\n $desc\n");
1975 0           push @distros, $distro;
1976             }
1977             } elsif ($url =~ /search.*uploads.rdf/) {
1978             # xmlns:rdf="http://www.w3.org/1999/02/22-rdf-syntax-ns#"
1979             # xmlns="http://purl.org/rss/1.0/"
1980             # xmlns:taxo="http://purl.org/rss/1.0/modules/taxonomy/"
1981             # xmlns:dc="http://purl.org/dc/elements/1.1/"
1982             # xmlns:syn="http://purl.org/rss/1.0/modules/syndication/"
1983             # xmlns:admin="http://webns.net/mvcb/"
1984              
1985              
1986 0           my $dc_date = $xml->findvalue("//*[local-name(.) = 'RDF']/*[local-name(.) = 'channel']/*[local-name(.) = 'date']");
1987 0           $CPAN::Frontend->myprint(" dc:date: $dc_date\n\n");
1988 0           my $finish_eitem = 0;
1989 0     0     local $SIG{INT} = sub { $finish_eitem = 1 };
  0            
1990 0           EITEM: for my $eitem ($xml->findnodes("//*[local-name(.) = 'RDF']/*[local-name(.) = 'item']")) {
1991 0           my $distro = $eitem->findvalue("\@rdf:about");
1992 0           $distro =~ s|.*~||; # remove up to the tilde before the name
1993 0           $distro =~ s|/$||; # remove trailing slash
1994 0           $distro =~ s|([^/]+)|\U$1\E|; # upcase the name
1995 0 0         my $author = uc $1 or die "distro[$distro] without author, cannot continue";
1996 0           my $desc = $eitem->findvalue("*[local-name(.) = 'description']");
1997 0           my $i = 0;
1998 0           SUBDIRTEST: while () {
1999 0 0         last SUBDIRTEST if ++$i >= 6; # half a dozen must do!
2000 0 0         if (my @ret = $self->globls("$distro*")) {
2001 0           @ret = grep {$_->[2] !~ /meta/} @ret;
  0            
2002 0           @ret = grep {length $_->[2]} @ret;
  0            
2003 0 0         if (@ret) {
2004 0           $distro = "$author/$ret[0][2]";
2005 0           last SUBDIRTEST;
2006             }
2007             }
2008 0           $distro =~ s|/|/*/|; # allow it to reside in a subdirectory
2009             }
2010              
2011 0 0         next EITEM if $distro =~ m|\*|; # did not find the thing
2012 0           $CPAN::Frontend->myprint("____$desc\n");
2013 0           push @distros, $distro;
2014 0 0         last EITEM if $finish_eitem;
2015             }
2016             }
2017 0           return \@distros;
2018             } else {
2019             # deprecated old version
2020 0           $CPAN::Frontend->mydie("no XML::LibXML installed, cannot continue\n");
2021             }
2022             }
2023              
2024             #-> sub CPAN::Shell::smoke ;
2025             sub smoke {
2026 0     0 0   my($self) = @_;
2027 0           my $distros = $self->recent;
2028 0           DISTRO: for my $distro (@$distros) {
2029 0 0         next if $distro =~ m|/Bundle-|; # XXX crude heuristic to skip bundles
2030 0           $CPAN::Frontend->myprint(sprintf "Downloading and testing '$distro'\n");
2031             {
2032 0           my $skip = 0;
  0            
2033 0     0     local $SIG{INT} = sub { $skip = 1 };
  0            
2034 0           for (0..9) {
2035 0           $CPAN::Frontend->myprint(sprintf "\r%2d (Hit ^C to skip)", 10-$_);
2036 0           sleep 1;
2037 0 0         if ($skip) {
2038 0           $CPAN::Frontend->myprint(" skipped\n");
2039 0           next DISTRO;
2040             }
2041             }
2042             }
2043 0           $CPAN::Frontend->myprint("\r \n"); # leave the dirty line with a newline
2044 0           $self->test($distro);
2045             }
2046             }
2047              
2048             {
2049             # set up the dispatching methods
2050 13     13   210 no strict "refs";
  13         37  
  13         2028  
2051             for my $command (qw(
2052             clean
2053             cvs_import
2054             dump
2055             force
2056             fforce
2057             get
2058             install
2059             look
2060             ls
2061             make
2062             notest
2063             perldoc
2064             readme
2065             reports
2066             test
2067             )) {
2068 0     0     *$command = sub { shift->rematein($command, @_); };
2069             }
2070             }
2071              
2072             1;