File Coverage

blib/lib/CPAN/Shell.pm
Criterion Covered Total %
statement 80 1030 7.7
branch 31 612 5.0
condition 8 157 5.1
subroutine 14 63 22.2
pod 0 47 0.0
total 133 1909 6.9


line stmt bran cond sub pod time code
1             package CPAN::Shell;
2 12     12   59 use strict;
  12         17  
  12         543  
3              
4             # -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*-
5             # vim: ts=4 sts=4 sw=4:
6              
7 12         2094 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   53 );
  12         21  
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.5005";
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   60 use Cwd qw(chdir);
  12         23  
  12         707  
55 12     12   65 use Carp ();
  12         27  
  12         155973  
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   3145 $autoload_recursion++;
109 10         12 my($l) = $AUTOLOAD;
110 10         15 my $class = shift(@_);
111             # warn "autoload[$l] class[$class]";
112 10         55 $l =~ s/.*:://;
113 10 50       29 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       21 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         47 $CPAN::Frontend->mywarn(qq{Unknown shell command '$l'. }.
138             qq{Type ? for help.
139             });
140             }
141 10         34 $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
178             r WORDs or /REGEXP/ or NONE report updates for some/matching/all modules
179             upgrade WORDs or /REGEXP/ or NONE upgrade some/matching/all modules
180              
181             Pragmas
182             force CMD try hard to do command fforce CMD try harder
183             notest CMD skip testing
184              
185             Other
186             h,? display this menu ! perl-code eval a perl command
187             o conf [opt] set and query options q quit the cpan shell
188             reload cpan load CPAN.pm again reload index load newer indices
189             autobundle Snapshot recent latest CPAN uploads});
190             }
191             }
192              
193             *help = \&h;
194              
195             #-> sub CPAN::Shell::a ;
196             sub a {
197 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 0         0 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          
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 (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  
  0         0  
523             $S{ok}{$url}{dlsize}/$S{ok}{$url}{dltime},
524             $url,
525             ];
526             }
527 0         0 for my $url (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 delete $INC{$f};
641 0         0 local @INC = @inc;
642 0         0 eval "require '$f'";
643 0 0       0 if ($@) {
644 0         0 warn $@;
645 0         0 return;
646             }
647 0         0 $reload->{$f} = $mtime;
648             } else {
649 0         0 $CPAN::Frontend->myprint("__unchanged__");
650             }
651 0         0 return 1;
652             }
653              
654             #-> sub CPAN::Shell::mkmyconfig ;
655             sub mkmyconfig {
656 0     0 0 0 my($self) = @_;
657 0 0       0 if ( my $configpm = $INC{'CPAN/MyConfig.pm'} ) {
658 0         0 $CPAN::Frontend->myprint(
659             "CPAN::MyConfig already exists as $configpm.\n" .
660             "Running configuration again...\n"
661             );
662 0         0 require CPAN::FirstTime;
663 0         0 CPAN::FirstTime::init($configpm);
664             }
665             else {
666             # force some missing values to be filled in with defaults
667             delete $CPAN::Config->{$_}
668 0         0 for qw/build_dir cpan_home keep_source_where histfile/;
669 0         0 CPAN::HandleConfig->load( make_myconfig => 1 );
670             }
671             }
672              
673             #-> sub CPAN::Shell::_binary_extensions ;
674             sub _binary_extensions {
675 0     0   0 my($self) = shift @_;
676 0         0 my(@result,$module,%seen,%need,$headerdone);
677 0         0 for $module ($self->expand('Module','/./')) {
678 0         0 my $file = $module->cpan_file;
679 0 0       0 next if $file eq "N/A";
680 0 0       0 next if $file =~ /^Contact Author/;
681 0         0 my $dist = $CPAN::META->instance('CPAN::Distribution',$file);
682 0 0       0 next if $dist->isa_perl;
683 0 0       0 next unless $module->xs_file;
684 0         0 local($|) = 1;
685 0         0 $CPAN::Frontend->myprint(".");
686 0         0 push @result, $module;
687             }
688             # print join " | ", @result;
689 0         0 $CPAN::Frontend->myprint("\n");
690 0         0 return @result;
691             }
692              
693             #-> sub CPAN::Shell::recompile ;
694             sub recompile {
695 0     0 0 0 my($self) = shift @_;
696 0         0 my($module,@module,$cpan_file,%dist);
697 0         0 @module = $self->_binary_extensions();
698 0         0 for $module (@module) { # we force now and compile later, so we
699             # don't do it twice
700 0         0 $cpan_file = $module->cpan_file;
701 0         0 my $pack = $CPAN::META->instance('CPAN::Distribution',$cpan_file);
702 0         0 $pack->force;
703 0         0 $dist{$cpan_file}++;
704             }
705 0         0 for $cpan_file (sort keys %dist) {
706 0         0 $CPAN::Frontend->myprint(" CPAN: Recompiling $cpan_file\n\n");
707 0         0 my $pack = $CPAN::META->instance('CPAN::Distribution',$cpan_file);
708 0         0 $pack->install;
709 0         0 $CPAN::Signal = 0; # it's tempting to reset Signal, so we can
710             # stop a package from recompiling,
711             # e.g. IO-1.12 when we have perl5.003_10
712             }
713             }
714              
715             #-> sub CPAN::Shell::scripts ;
716             sub scripts {
717 0     0 0 0 my($self, $arg) = @_;
718 0         0 $CPAN::Frontend->mywarn(">>>> experimental command, currently unsupported <<<<\n\n");
719              
720 0         0 for my $req (qw( HTML::LinkExtor Sort::Versions List::Util )) {
721 0 0       0 unless ($CPAN::META->has_inst($req)) {
722 0         0 $CPAN::Frontend->mywarn(" $req not available\n");
723             }
724             }
725 0         0 my $p = HTML::LinkExtor->new();
726 0         0 my $indexfile = "/home/ftp/pub/PAUSE/scripts/new/index.html";
727 0 0       0 unless (-f $indexfile) {
728 0         0 $CPAN::Frontend->mydie("found no indexfile[$indexfile]\n");
729             }
730 0         0 $p->parse_file($indexfile);
731 0         0 my @hrefs;
732             my $qrarg;
733 0 0       0 if ($arg =~ s|^/(.+)/$|$1|) {
734 0         0 $qrarg = eval 'qr/$arg/'; # hide construct from 5.004
735             }
736 0         0 for my $l ($p->links) {
737 0         0 my $tag = shift @$l;
738 0 0       0 next unless $tag eq "a";
739 0         0 my %att = @$l;
740 0         0 my $href = $att{href};
741 0 0       0 next unless $href =~ s|^\.\./authors/id/./../||;
742 0 0       0 if ($arg) {
743 0 0       0 if ($qrarg) {
744 0 0       0 if ($href =~ $qrarg) {
745 0         0 push @hrefs, $href;
746             }
747             } else {
748 0 0       0 if ($href =~ /\Q$arg\E/) {
749 0         0 push @hrefs, $href;
750             }
751             }
752             } else {
753 0         0 push @hrefs, $href;
754             }
755             }
756             # now filter for the latest version if there is more than one of a name
757 0         0 my %stems;
758 0         0 for (sort @hrefs) {
759 0         0 my $href = $_;
760 0         0 s/-v?\d.*//;
761 0         0 my $stem = $_;
762 0   0     0 $stems{$stem} ||= [];
763 0         0 push @{$stems{$stem}}, $href;
  0         0  
764             }
765 0         0 for (sort keys %stems) {
766 0         0 my $highest;
767 0 0       0 if (@{$stems{$_}} > 1) {
  0         0  
768             $highest = List::Util::reduce {
769 0 0   0   0 Sort::Versions::versioncmp($a,$b) > 0 ? $a : $b
770 0         0 } @{$stems{$_}};
  0         0  
771             } else {
772 0         0 $highest = $stems{$_}[0];
773             }
774 0         0 $CPAN::Frontend->myprint("$highest\n");
775             }
776             }
777              
778             sub _guess_manpage {
779 0     0   0 my($self,$d,$contains,$dist) = @_;
780 0         0 $dist =~ s/-/::/g;
781 0         0 my $module;
782 0 0       0 if (exists $contains->{$dist}) {
    0          
783 0         0 $module = $dist;
784             } elsif (1 == keys %$contains) {
785 0         0 ($module) = keys %$contains;
786             }
787 0         0 my $manpage;
788 0 0       0 if ($module) {
789 0         0 my $m = $self->expand("Module",$module);
790 0         0 $m->as_string; # called for side-effects, shame
791 0         0 $manpage = $m->{MANPAGE};
792             } else {
793 0         0 $manpage = "unknown";
794             }
795 0         0 return $manpage;
796             }
797              
798             #-> sub CPAN::Shell::_specfile ;
799             sub _specfile {
800 0     0   0 die "CPAN::Shell::_specfile() has been moved to CPAN::Plugin::Specfile::post_test()";
801             }
802              
803             #-> sub CPAN::Shell::report ;
804             sub report {
805 0     0 0 0 my($self,@args) = @_;
806 0 0       0 unless ($CPAN::META->has_inst("CPAN::Reporter")) {
807 0         0 $CPAN::Frontend->mydie("CPAN::Reporter not installed; cannot continue");
808             }
809 0         0 local $CPAN::Config->{test_report} = 1;
810 0         0 $self->force("test",@args); # force is there so that the test be
811             # re-run (as documented)
812             }
813              
814             # compare with is_tested
815             #-> sub CPAN::Shell::install_tested
816             sub install_tested {
817 0     0 0 0 my($self,@some) = @_;
818 0 0       0 $CPAN::Frontend->mywarn("install_tested() must not be called with arguments.\n"),
819             return if @some;
820 0         0 CPAN::Index->reload;
821              
822 0         0 for my $b (reverse $CPAN::META->_list_sorted_descending_is_tested) {
823 0         0 my $yaml = "$b.yml";
824 0 0       0 unless (-f $yaml) {
825 0         0 $CPAN::Frontend->mywarn("No YAML file for $b available, skipping\n");
826 0         0 next;
827             }
828 0         0 my $yaml_content = CPAN->_yaml_loadfile($yaml);
829 0         0 my $id = $yaml_content->[0]{distribution}{ID};
830 0 0       0 unless ($id) {
831 0         0 $CPAN::Frontend->mywarn("No ID found in '$yaml', skipping\n");
832 0         0 next;
833             }
834 0         0 my $do = CPAN::Shell->expandany($id);
835 0 0       0 unless ($do) {
836 0         0 $CPAN::Frontend->mywarn("Could not expand ID '$id', skipping\n");
837 0         0 next;
838             }
839 0 0       0 unless ($do->{build_dir}) {
840 0         0 $CPAN::Frontend->mywarn("Distro '$id' has no build_dir, skipping\n");
841 0         0 next;
842             }
843 0 0       0 unless ($do->{build_dir} eq $b) {
844 0         0 $CPAN::Frontend->mywarn("Distro '$id' has build_dir '$do->{build_dir}' but expected '$b', skipping\n");
845 0         0 next;
846             }
847 0         0 push @some, $do;
848             }
849              
850 0 0       0 $CPAN::Frontend->mywarn("No tested distributions found.\n"),
851             return unless @some;
852              
853 0 0       0 @some = grep { $_->{make_test} && ! $_->{make_test}->failed } @some;
  0         0  
854 0 0       0 $CPAN::Frontend->mywarn("No distributions tested with this build of perl found.\n"),
855             return unless @some;
856              
857             # @some = grep { not $_->uptodate } @some;
858             # $CPAN::Frontend->mywarn("No non-uptodate distributions tested with this build of perl found.\n"),
859             # return unless @some;
860              
861 0         0 CPAN->debug("some[@some]");
862 0         0 for my $d (@some) {
863 0 0       0 my $id = $d->can("pretty_id") ? $d->pretty_id : $d->id;
864 0         0 $CPAN::Frontend->myprint("install_tested: Running for $id\n");
865 0         0 $CPAN::Frontend->mysleep(1);
866 0         0 $self->install($d);
867             }
868             }
869              
870             #-> sub CPAN::Shell::upgrade ;
871             sub upgrade {
872 0     0 0 0 my($self,@args) = @_;
873 0         0 $self->install($self->r(@args));
874             }
875              
876             #-> sub CPAN::Shell::_u_r_common ;
877             sub _u_r_common {
878 0     0   0 my($self) = shift @_;
879 0         0 my($what) = shift @_;
880 0 0       0 CPAN->debug("self[$self] what[$what] args[@_]") if $CPAN::DEBUG;
881 0 0 0     0 Carp::croak "Usage: \$obj->_u_r_common(a|r|u)" unless
882             $what && $what =~ /^[aru]$/;
883 0         0 my(@args) = @_;
884 0 0       0 @args = '/./' unless @args;
885 0         0 my(@result,$module,%seen,%need,$headerdone,
886             $version_undefs,$version_zeroes,
887             @version_undefs,@version_zeroes);
888 0         0 $version_undefs = $version_zeroes = 0;
889 0         0 my $sprintf = "%s%-25s%s %9s %9s %s\n";
890 0         0 my @expand = $self->expand('Module',@args);
891 0 0       0 if ($CPAN::DEBUG) { # Looks like noise to me, was very useful for debugging
892             # for metadata cache
893 0         0 my $expand = scalar @expand;
894 0         0 $CPAN::Frontend->myprint(sprintf "%d matches in the database, time[%d]\n", $expand, time);
895             }
896 0         0 my @sexpand;
897 0 0       0 if ($] < 5.008) {
898             # hard to believe that the more complex sorting can lead to
899             # stack curruptions on older perl
900 0         0 @sexpand = sort {$a->id cmp $b->id} @expand;
  0         0  
901             } else {
902 0         0 @sexpand = map {
903 0 0       0 $_->[1]
904             } sort {
905 0         0 $b->[0] <=> $a->[0]
906             ||
907             $a->[1]{ID} cmp $b->[1]{ID},
908             } map {
909 0         0 [$_->_is_representative_module,
910             $_
911             ]
912             } @expand;
913             }
914 0 0       0 if ($CPAN::DEBUG) {
915 0         0 $CPAN::Frontend->myprint(sprintf "sorted at time[%d]\n", time);
916 0         0 sleep 1;
917             }
918 0         0 MODULE: for $module (@sexpand) {
919 0         0 my $file = $module->cpan_file;
920 0 0       0 next MODULE unless defined $file; # ??
921 0         0 $file =~ s!^./../!!;
922 0         0 my($latest) = $module->cpan_version;
923 0         0 my($inst_file) = $module->inst_file;
924 0 0       0 CPAN->debug("file[$file]latest[$latest]") if $CPAN::DEBUG;
925 0         0 my($have);
926 0 0       0 return if $CPAN::Signal;
927 0         0 my($next_MODULE);
928 0         0 eval { # version.pm involved!
929 0 0       0 if ($inst_file) {
930 0 0       0 if ($what eq "a") {
    0          
    0          
931 0         0 $have = $module->inst_version;
932             } elsif ($what eq "r") {
933 0         0 $have = $module->inst_version;
934 0         0 local($^W) = 0;
935 0 0       0 if ($have eq "undef") {
    0          
936 0         0 $version_undefs++;
937 0         0 push @version_undefs, $module->as_glimpse;
938             } elsif (CPAN::Version->vcmp($have,0)==0) {
939 0         0 $version_zeroes++;
940 0         0 push @version_zeroes, $module->as_glimpse;
941             }
942 0 0       0 ++$next_MODULE unless CPAN::Version->vgt($latest, $have);
943             # to be pedantic we should probably say:
944             # && !($have eq "undef" && $latest ne "undef" && $latest gt "");
945             # to catch the case where CPAN has a version 0 and we have a version undef
946             } elsif ($what eq "u") {
947 0         0 ++$next_MODULE;
948             }
949             } else {
950 0 0       0 if ($what eq "a") {
    0          
    0          
951 0         0 ++$next_MODULE;
952             } elsif ($what eq "r") {
953 0         0 ++$next_MODULE;
954             } elsif ($what eq "u") {
955 0         0 $have = "-";
956             }
957             }
958             };
959 0 0       0 next MODULE if $next_MODULE;
960 0 0       0 if ($@) {
961 0 0 0     0 $CPAN::Frontend->mywarn
    0          
    0          
962             (sprintf("Error while comparing cpan/installed versions of '%s':
963             INST_FILE: %s
964             INST_VERSION: %s %s
965             CPAN_VERSION: %s %s
966             ",
967             $module->id,
968             $inst_file || "",
969             (defined $have ? $have : "[UNDEFINED]"),
970             (ref $have ? ref $have : ""),
971             $latest,
972             (ref $latest ? ref $latest : ""),
973             ));
974 0         0 next MODULE;
975             }
976 0 0       0 return if $CPAN::Signal; # this is sometimes lengthy
977 0   0     0 $seen{$file} ||= 0;
978 0 0       0 if ($what eq "a") {
    0          
    0          
979 0         0 push @result, sprintf "%s %s\n", $module->id, $have;
980             } elsif ($what eq "r") {
981 0         0 push @result, $module->id;
982 0 0       0 next MODULE if $seen{$file}++;
983             } elsif ($what eq "u") {
984 0         0 push @result, $module->id;
985 0 0       0 next MODULE if $seen{$file}++;
986 0 0       0 next MODULE if $file =~ /^Contact/;
987             }
988 0 0       0 unless ($headerdone++) {
989 0         0 $CPAN::Frontend->myprint("\n");
990 0         0 $CPAN::Frontend->myprint(sprintf(
991             $sprintf,
992             "",
993             "Package namespace",
994             "",
995             "installed",
996             "latest",
997             "in CPAN file"
998             ));
999             }
1000 0         0 my $color_on = "";
1001 0         0 my $color_off = "";
1002 0 0 0     0 if (
      0        
1003             $COLOR_REGISTERED
1004             &&
1005             $CPAN::META->has_inst("Term::ANSIColor")
1006             &&
1007             $module->description
1008             ) {
1009 0         0 $color_on = Term::ANSIColor::color("green");
1010 0         0 $color_off = Term::ANSIColor::color("reset");
1011             }
1012 0         0 $CPAN::Frontend->myprint(sprintf $sprintf,
1013             $color_on,
1014             $module->id,
1015             $color_off,
1016             $have,
1017             $latest,
1018             $file);
1019 0         0 $need{$module->id}++;
1020             }
1021 0 0       0 unless (%need) {
1022 0 0       0 if ($what eq "u") {
    0          
1023 0         0 $CPAN::Frontend->myprint("No modules found for @args\n");
1024             } elsif ($what eq "r") {
1025 0         0 $CPAN::Frontend->myprint("All modules are up to date for @args\n");
1026             }
1027             }
1028 0 0       0 if ($what eq "r") {
1029 0 0       0 if ($version_zeroes) {
1030 0 0       0 my $s_has = $version_zeroes > 1 ? "s have" : " has";
1031 0         0 $CPAN::Frontend->myprint(qq{$version_zeroes installed module$s_has }.
1032             qq{a version number of 0\n});
1033 0 0       0 if ($CPAN::Config->{show_zero_versions}) {
1034 0         0 local $" = "\t";
1035 0         0 $CPAN::Frontend->myprint(qq{ they are\n\t@version_zeroes\n});
1036 0         0 $CPAN::Frontend->myprint(qq{(use 'o conf show_zero_versions 0' }.
1037             qq{to hide them)\n});
1038             } else {
1039 0         0 $CPAN::Frontend->myprint(qq{(use 'o conf show_zero_versions 1' }.
1040             qq{to show them)\n});
1041             }
1042             }
1043 0 0       0 if ($version_undefs) {
1044 0 0       0 my $s_has = $version_undefs > 1 ? "s have" : " has";
1045 0         0 $CPAN::Frontend->myprint(qq{$version_undefs installed module$s_has no }.
1046             qq{parsable version number\n});
1047 0 0       0 if ($CPAN::Config->{show_unparsable_versions}) {
1048 0         0 local $" = "\t";
1049 0         0 $CPAN::Frontend->myprint(qq{ they are\n\t@version_undefs\n});
1050 0         0 $CPAN::Frontend->myprint(qq{(use 'o conf show_unparsable_versions 0' }.
1051             qq{to hide them)\n});
1052             } else {
1053 0         0 $CPAN::Frontend->myprint(qq{(use 'o conf show_unparsable_versions 1' }.
1054             qq{to show them)\n});
1055             }
1056             }
1057             }
1058 0         0 @result;
1059             }
1060              
1061             #-> sub CPAN::Shell::r ;
1062             sub r {
1063 0     0 0 0 shift->_u_r_common("r",@_);
1064             }
1065              
1066             #-> sub CPAN::Shell::u ;
1067             sub u {
1068 0     0 0 0 shift->_u_r_common("u",@_);
1069             }
1070              
1071             #-> sub CPAN::Shell::failed ;
1072             sub failed {
1073 0     0 0 0 my($self,$only_id,$silent) = @_;
1074 0         0 my @failed = $self->find_failed($only_id);
1075 0         0 my $scope;
1076 0 0       0 if ($only_id) {
    0          
1077 0         0 $scope = "this command";
1078             } elsif ($CPAN::Index::HAVE_REANIMATED) {
1079 0         0 $scope = "this or a previous session";
1080             # it might be nice to have a section for previous session and
1081             # a second for this
1082             } else {
1083 0         0 $scope = "this session";
1084             }
1085 0 0 0     0 if (@failed) {
    0          
1086 0         0 my $print;
1087 0         0 my $debug = 0;
1088 0 0       0 if ($debug) {
1089 0         0 $print = join "",
1090 0         0 map { sprintf "%5d %-45s: %s %s\n", @$_ }
1091 0         0 sort { $a->[0] <=> $b->[0] } @failed;
1092             } else {
1093 0         0 $print = join "",
1094 0 0       0 map { sprintf " %-45s: %s %s\n", @$_[1..3] }
1095             sort {
1096 0         0 $a->[0] <=> $b->[0]
1097             ||
1098             $a->[4] <=> $b->[4]
1099             } @failed;
1100             }
1101 0         0 $CPAN::Frontend->myprint("Failed during $scope:\n$print");
1102             } elsif (!$only_id || !$silent) {
1103 0         0 $CPAN::Frontend->myprint("Nothing failed in $scope\n");
1104             }
1105             }
1106              
1107             sub find_failed {
1108 0     0 0 0 my($self,$only_id) = @_;
1109 0         0 my @failed;
1110 0         0 DIST: for my $d ($CPAN::META->all_objects("CPAN::Distribution")) {
1111 0         0 my $failed = "";
1112 0         0 NAY: for my $nosayer ( # order matters!
1113             "unwrapped",
1114             "writemakefile",
1115             "signature_verify",
1116             "make",
1117             "make_test",
1118             "install",
1119             "make_clean",
1120             ) {
1121 0 0       0 next unless exists $d->{$nosayer};
1122 0 0       0 next unless defined $d->{$nosayer};
1123             next unless (
1124 0 0       0 UNIVERSAL::can($d->{$nosayer},"failed") ?
    0          
1125             $d->{$nosayer}->failed :
1126             $d->{$nosayer} =~ /^NO/
1127             );
1128 0 0 0     0 next NAY if $only_id && $only_id != (
    0          
1129             UNIVERSAL::can($d->{$nosayer},"commandid")
1130             ?
1131             $d->{$nosayer}->commandid
1132             :
1133             $CPAN::CurrentCommandId
1134             );
1135 0         0 $failed = $nosayer;
1136 0         0 last;
1137             }
1138 0 0       0 next DIST unless $failed;
1139 0         0 my $id = $d->id;
1140 0         0 $id =~ s|^./../||;
1141             ### XXX need to flag optional modules as '(optional)' if they are
1142             # from recommends/suggests -- i.e. *show* failure, but make it clear
1143             # it was failure of optional module -- xdg, 2012-04-01
1144 0 0       0 $id = "(optional) $id" if ! $d->{mandatory};
1145             #$print .= sprintf(
1146             # " %-45s: %s %s\n",
1147 0 0 0     0 push @failed,
1148             (
1149             UNIVERSAL::can($d->{$failed},"failed") ?
1150             [
1151             $d->{$failed}->commandid,
1152             $id,
1153             $failed,
1154             $d->{$failed}->text,
1155             $d->{$failed}{TIME}||0,
1156             !! $d->{mandatory},
1157             ] :
1158             [
1159             1,
1160             $id,
1161             $failed,
1162             $d->{$failed},
1163             0,
1164             !! $d->{mandatory},
1165             ]
1166             );
1167             }
1168 0         0 return @failed;
1169             }
1170              
1171             sub mandatory_dist_failed {
1172 0     0 0 0 my ($self) = @_;
1173 0         0 return grep { $_->[5] } $self->find_failed($CPAN::CurrentCommandID);
  0         0  
1174             }
1175              
1176             # XXX intentionally undocumented because completely bogus, unportable,
1177             # useless, etc.
1178              
1179             #-> sub CPAN::Shell::status ;
1180             sub status {
1181 0     0 0 0 my($self) = @_;
1182 0         0 require Devel::Size;
1183 0         0 my $ps = FileHandle->new;
1184 0         0 open $ps, "/proc/$$/status";
1185 0         0 my $vm = 0;
1186 0         0 while (<$ps>) {
1187 0 0       0 next unless /VmSize:\s+(\d+)/;
1188 0         0 $vm = $1;
1189 0         0 last;
1190             }
1191 0         0 $CPAN::Frontend->mywarn(sprintf(
1192             "%-27s %6d\n%-27s %6d\n",
1193             "vm",
1194             $vm,
1195             "CPAN::META",
1196             Devel::Size::total_size($CPAN::META)/1024,
1197             ));
1198 0         0 for my $k (sort keys %$CPAN::META) {
1199 0 0       0 next unless substr($k,0,4) eq "read";
1200 0         0 warn sprintf " %-26s %6d\n", $k, Devel::Size::total_size($CPAN::META->{$k})/1024;
1201 0         0 for my $k2 (sort keys %{$CPAN::META->{$k}}) {
  0         0  
1202 0         0 warn sprintf " %-25s %6d (keys: %6d)\n",
1203             $k2,
1204             Devel::Size::total_size($CPAN::META->{$k}{$k2})/1024,
1205 0         0 scalar keys %{$CPAN::META->{$k}{$k2}};
1206             }
1207             }
1208             }
1209              
1210             # compare with install_tested
1211             #-> sub CPAN::Shell::is_tested
1212             sub is_tested {
1213 0     0 0 0 my($self) = @_;
1214 0         0 CPAN::Index->reload;
1215 0         0 for my $b (reverse $CPAN::META->_list_sorted_descending_is_tested) {
1216 0         0 my $time;
1217 0 0       0 if ($CPAN::META->{is_tested}{$b}) {
1218 0         0 $time = scalar(localtime $CPAN::META->{is_tested}{$b});
1219             } else {
1220 0         0 $time = scalar localtime;
1221 0         0 $time =~ s/\S/?/g;
1222             }
1223 0         0 $CPAN::Frontend->myprint(sprintf "%s %s\n", $time, $b);
1224             }
1225             }
1226              
1227             #-> sub CPAN::Shell::autobundle ;
1228             sub autobundle {
1229 0     0 0 0 my($self) = shift;
1230 0 0       0 CPAN::HandleConfig->load unless $CPAN::Config_loaded++;
1231 0         0 my(@bundle) = $self->_u_r_common("a",@_);
1232 0         0 my($todir) = File::Spec->catdir($CPAN::Config->{'cpan_home'},"Bundle");
1233 0         0 File::Path::mkpath($todir);
1234 0 0       0 unless (-d $todir) {
1235 0         0 $CPAN::Frontend->myprint("Couldn't mkdir $todir for some reason\n");
1236 0         0 return;
1237             }
1238 0         0 my($y,$m,$d) = (localtime)[5,4,3];
1239 0         0 $y+=1900;
1240 0         0 $m++;
1241 0         0 my($c) = 0;
1242 0         0 my($me) = sprintf "Snapshot_%04d_%02d_%02d_%02d", $y, $m, $d, $c;
1243 0         0 my($to) = File::Spec->catfile($todir,"$me.pm");
1244 0         0 while (-f $to) {
1245 0         0 $me = sprintf "Snapshot_%04d_%02d_%02d_%02d", $y, $m, $d, ++$c;
1246 0         0 $to = File::Spec->catfile($todir,"$me.pm");
1247             }
1248 0 0       0 my($fh) = FileHandle->new(">$to") or Carp::croak "Can't open >$to: $!";
1249 0         0 $fh->print(
1250             "package Bundle::$me;\n\n",
1251             "\$","VERSION = '0.01';\n\n", # hide from perl-reversion
1252             "1;\n\n",
1253             "__END__\n\n",
1254             "=head1 NAME\n\n",
1255             "Bundle::$me - Snapshot of installation on ",
1256             $Config::Config{'myhostname'},
1257             " on ",
1258             scalar(localtime),
1259             "\n\n=head1 SYNOPSIS\n\n",
1260             "perl -MCPAN -e 'install Bundle::$me'\n\n",
1261             "=head1 CONTENTS\n\n",
1262             join("\n", @bundle),
1263             "\n\n=head1 CONFIGURATION\n\n",
1264             Config->myconfig,
1265             "\n\n=head1 AUTHOR\n\n",
1266             "This Bundle has been generated automatically ",
1267             "by the autobundle routine in CPAN.pm.\n",
1268             );
1269 0         0 $fh->close;
1270 0         0 $CPAN::Frontend->myprint("\nWrote bundle file
1271             $to\n\n");
1272 0         0 return $to;
1273             }
1274              
1275             #-> sub CPAN::Shell::expandany ;
1276             sub expandany {
1277 7     7 0 10 my($self,$s) = @_;
1278 7 50       16 CPAN->debug("s[$s]") if $CPAN::DEBUG;
1279 7         7 my $module_as_path = "";
1280 7 50       20 if ($s =~ m|(?:\w+/)*\w+\.pm$|) { # same regexp in sub m
1281 0         0 $module_as_path = $s;
1282 0         0 $module_as_path =~ s/.pm$//;
1283 0         0 $module_as_path =~ s|/|::|g;
1284             }
1285 7 50 33     57 if ($module_as_path) {
    50          
    50          
1286 0 0       0 if ($module_as_path =~ m|^Bundle::|) {
1287 0         0 $self->local_bundles;
1288 0         0 return $self->expand('Bundle',$module_as_path);
1289             } else {
1290 0 0       0 return $self->expand('Module',$module_as_path)
1291             if $CPAN::META->exists('CPAN::Module',$module_as_path);
1292             }
1293             } elsif ($s =~ m|/| or substr($s,-1,1) eq ".") { # looks like a file or a directory
1294 0         0 $s = CPAN::Distribution->normalize($s);
1295 0         0 return $CPAN::META->instance('CPAN::Distribution',$s);
1296             # Distributions spring into existence, not expand
1297             } elsif ($s =~ m|^Bundle::|) {
1298 0         0 $self->local_bundles; # scanning so late for bundles seems
1299             # both attractive and crumpy: always
1300             # current state but easy to forget
1301             # somewhere
1302 0         0 return $self->expand('Bundle',$s);
1303             } else {
1304 7 50       22 return $self->expand('Module',$s)
1305             if $CPAN::META->exists('CPAN::Module',$s);
1306             }
1307 7         31 return;
1308             }
1309              
1310             #-> sub CPAN::Shell::expand ;
1311             sub expand {
1312 4     4 0 854 my $self = shift;
1313 4         9 my($type,@args) = @_;
1314 4 50       9 CPAN->debug("type[$type]args[@args]") if $CPAN::DEBUG;
1315 4         7 my $class = "CPAN::$type";
1316 4         9 my $methods = ['id'];
1317 4         7 for my $meth (qw(name)) {
1318 4 100       50 next unless $class->can($meth);
1319 1         6 push @$methods, $meth;
1320             }
1321 4         13 $self->expand_by_method($class,$methods,@args);
1322             }
1323              
1324             #-> sub CPAN::Shell::expand_by_method ;
1325             sub expand_by_method {
1326 4     4 0 5 my $self = shift;
1327 4         6 my($class,$methods,@args) = @_;
1328 4         5 my($arg,@m);
1329 4         5 for $arg (@args) {
1330 4         3 my($regex,$command);
1331 4 50       15 if ($arg =~ m|^/(.*)/$|) {
1332 0         0 $regex = $1;
1333             # FIXME: there seem to be some ='s in the author data, which trigger
1334             # a failure here. This needs to be contemplated.
1335             # } elsif ($arg =~ m/=/) {
1336             # $command = 1;
1337             }
1338 4         5 my $obj;
1339 4 0       6 CPAN->debug(sprintf "class[%s]regex[%s]command[%s]",
    0          
    50          
1340             $class,
1341             defined $regex ? $regex : "UNDEFINED",
1342             defined $command ? $command : "UNDEFINED",
1343             ) if $CPAN::DEBUG;
1344 4 50       10 if (defined $regex) {
    50          
1345 0 0       0 if (CPAN::_sqlite_running()) {
1346 0         0 CPAN::Index->reload;
1347 0         0 $CPAN::SQLite->search($class, $regex);
1348             }
1349 0         0 for $obj (
1350             $CPAN::META->all_objects($class)
1351             ) {
1352 0 0 0     0 unless ($obj && UNIVERSAL::can($obj,"id") && $obj->id) {
      0        
1353             # BUG, we got an empty object somewhere
1354 0         0 require Data::Dumper;
1355 0 0       0 CPAN->debug(sprintf(
1356             "Bug in CPAN: Empty id on obj[%s][%s]",
1357             $obj,
1358             Data::Dumper::Dumper($obj)
1359             )) if $CPAN::DEBUG;
1360 0         0 next;
1361             }
1362 0         0 for my $method (@$methods) {
1363 0         0 my $match = eval {$obj->$method() =~ /$regex/i};
  0         0  
1364 0 0       0 if ($@) {
    0          
1365 0         0 my($err) = $@ =~ /^(.+) at .+? line \d+\.$/;
1366 0   0     0 $err ||= $@; # if we were too restrictive above
1367 0         0 $CPAN::Frontend->mydie("$err\n");
1368             } elsif ($match) {
1369 0         0 push @m, $obj;
1370 0         0 last;
1371             }
1372             }
1373             }
1374             } elsif ($command) {
1375 0 0       0 die "equal sign in command disabled (immature interface), ".
1376             "you can set
1377             ! \$CPAN::Shell::ADVANCED_QUERY=1
1378             to enable it. But please note, this is HIGHLY EXPERIMENTAL code
1379             that may go away anytime.\n"
1380             unless $ADVANCED_QUERY;
1381 0         0 my($method,$criterion) = $arg =~ /(.+?)=(.+)/;
1382 0         0 my($matchcrit) = $criterion =~ m/^~(.+)/;
1383 0         0 for my $self (
  0         0  
1384             sort
1385             {$a->id cmp $b->id}
1386             $CPAN::META->all_objects($class)
1387             ) {
1388 0 0       0 my $lhs = $self->$method() or next; # () for 5.00503
1389 0 0       0 if ($matchcrit) {
1390 0 0       0 push @m, $self if $lhs =~ m/$matchcrit/;
1391             } else {
1392 0 0       0 push @m, $self if $lhs eq $criterion;
1393             }
1394             }
1395             } else {
1396 4         5 my($xarg) = $arg;
1397 4 50       10 if ( $class eq 'CPAN::Bundle' ) {
    100          
1398 0         0 $xarg =~ s/^(Bundle::)?(.*)/Bundle::$2/;
1399             } elsif ($class eq "CPAN::Distribution") {
1400 1         8 $xarg = CPAN::Distribution->normalize($arg);
1401             } else {
1402 3         13 $xarg =~ s/:+/::/g;
1403             }
1404 4 50       10 if ($CPAN::META->exists($class,$xarg)) {
    0          
1405 4         10 $obj = $CPAN::META->instance($class,$xarg);
1406             } elsif ($CPAN::META->exists($class,$arg)) {
1407 0         0 $obj = $CPAN::META->instance($class,$arg);
1408             } else {
1409 0         0 next;
1410             }
1411 4         14 push @m, $obj;
1412             }
1413             }
1414 4         9 @m = sort {$a->id cmp $b->id} @m;
  0         0  
1415 4 50       8 if ( $CPAN::DEBUG ) {
1416 0         0 my $wantarray = wantarray;
1417 0         0 my $join_m = join ",", map {$_->id} @m;
  0         0  
1418             # $self->debug("wantarray[$wantarray]join_m[$join_m]");
1419 0         0 my $count = scalar @m;
1420 0         0 $self->debug("class[$class]wantarray[$wantarray]count m[$count]");
1421             }
1422 4 50       35 return wantarray ? @m : $m[0];
1423             }
1424              
1425             #-> sub CPAN::Shell::format_result ;
1426             sub format_result {
1427 0     0 0 0 my($self) = shift;
1428 0         0 my($type,@args) = @_;
1429 0 0       0 @args = '/./' unless @args;
1430 0         0 my(@result) = $self->expand($type,@args);
1431 0         0 my $result = @result == 1 ?
1432             $result[0]->as_string :
1433             @result == 0 ?
1434             "No objects of type $type found for argument @args\n" :
1435             join("",
1436 0 0       0 (map {$_->as_glimpse} @result),
    0          
1437             scalar @result, " items found\n",
1438             );
1439 0         0 $result;
1440             }
1441              
1442             #-> sub CPAN::Shell::report_fh ;
1443             {
1444             my $installation_report_fh;
1445             my $previously_noticed = 0;
1446              
1447             sub report_fh {
1448 0 0   0 0 0 return $installation_report_fh if $installation_report_fh;
1449 0 0       0 if ($CPAN::META->has_usable("File::Temp")) {
1450 0         0 $installation_report_fh
1451             = File::Temp->new(
1452             dir => File::Spec->tmpdir,
1453             template => 'cpan_install_XXXX',
1454             suffix => '.txt',
1455             unlink => 0,
1456             );
1457             }
1458 0 0       0 unless ( $installation_report_fh ) {
1459 0 0       0 warn("Couldn't open installation report file; " .
1460             "no report file will be generated."
1461             ) unless $previously_noticed++;
1462             }
1463             }
1464             }
1465              
1466              
1467             # The only reason for this method is currently to have a reliable
1468             # debugging utility that reveals which output is going through which
1469             # channel. No, I don't like the colors ;-)
1470              
1471             # to turn colordebugging on, write
1472             # cpan> o conf colorize_output 1
1473              
1474             #-> sub CPAN::Shell::colorize_output ;
1475             {
1476             my $print_ornamented_have_warned = 0;
1477             sub colorize_output {
1478 165     165 0 174 my $colorize_output = $CPAN::Config->{colorize_output};
1479 165 0 33     270 if ($colorize_output && $^O eq 'MSWin32' && !$CPAN::META->has_inst("Win32::Console::ANSI")) {
      33        
1480 0 0       0 unless ($print_ornamented_have_warned++) {
1481             # no myprint/mywarn within myprint/mywarn!
1482 0         0 warn "Colorize_output is set to true but Win32::Console::ANSI is not
1483             installed. To activate colorized output, please install Win32::Console::ANSI.\n\n";
1484             }
1485 0         0 $colorize_output = 0;
1486             }
1487 165 50 33     269 if ($colorize_output && !$CPAN::META->has_inst("Term::ANSIColor")) {
1488 0 0       0 unless ($print_ornamented_have_warned++) {
1489             # no myprint/mywarn within myprint/mywarn!
1490 0         0 warn "Colorize_output is set to true but Term::ANSIColor is not
1491             installed. To activate colorized output, please install Term::ANSIColor.\n\n";
1492             }
1493 0         0 $colorize_output = 0;
1494             }
1495 165         275 return $colorize_output;
1496             }
1497             }
1498              
1499              
1500             #-> sub CPAN::Shell::print_ornamented ;
1501             sub print_ornamented {
1502 165     165 0 162 my($self,$what,$ornament) = @_;
1503 165 50       259 return unless defined $what;
1504              
1505 165         401 local $| = 1; # Flush immediately
1506 165 50       248 if ( $CPAN::Be_Silent ) {
1507             # WARNING: variable Be_Silent is poisoned and must be eliminated.
1508 0         0 print {report_fh()} $what;
  0         0  
1509 0         0 return;
1510             }
1511 165         168 my $swhat = "$what"; # stringify if it is an object
1512 165 50       276 if ($CPAN::Config->{term_is_latin}) {
1513             # note: deprecated, need to switch to $LANG and $LC_*
1514             # courtesy jhi:
1515 0         0 $swhat
1516 0         0 =~ s{([\xC0-\xDF])([\x80-\xBF])}{chr(ord($1)<<6&0xC0|ord($2)&0x3F)}eg; #};
1517             }
1518 165 50       245 if ($self->colorize_output) {
1519 0 0 0     0 if ( $CPAN::DEBUG && $swhat =~ /^Debug\(/ ) {
1520             # if you want to have this configurable, please file a bug report
1521 0   0     0 $ornament = $CPAN::Config->{colorize_debug} || "black on_cyan";
1522             }
1523 0   0     0 my $color_on = eval { Term::ANSIColor::color($ornament) } || "";
1524 0 0       0 if ($@) {
1525 0         0 print "Term::ANSIColor rejects color[$ornament]: $@\n
1526             Please choose a different color (Hint: try 'o conf init /color/')\n";
1527             }
1528             # GGOLDBACH/Test-GreaterVersion-0.008 broke without this
1529             # $trailer construct. We want the newline be the last thing if
1530             # there is a newline at the end ensuring that the next line is
1531             # empty for other players
1532 0         0 my $trailer = "";
1533 0 0       0 $trailer = $1 if $swhat =~ s/([\r\n]+)\z//;
1534 0         0 print $color_on,
1535             $swhat,
1536             Term::ANSIColor::color("reset"),
1537             $trailer;
1538             } else {
1539 165         5546 print $swhat;
1540             }
1541             }
1542              
1543             #-> sub CPAN::Shell::myprint ;
1544              
1545             # where is myprint/mywarn/Frontend/etc. documented? Where to use what?
1546             # I think, we send everything to STDOUT and use print for normal/good
1547             # news and warn for news that need more attention. Yes, this is our
1548             # working contract for now.
1549             sub myprint {
1550 164     164 0 256 my($self,$what) = @_;
1551 164   50     630 $self->print_ornamented($what,
1552             $CPAN::Config->{colorize_print}||'bold blue on_white',
1553             );
1554             }
1555              
1556             my %already_printed;
1557             #-> sub CPAN::Shell::mywarnonce ;
1558             sub myprintonce {
1559 0     0 0 0 my($self,$what) = @_;
1560 0 0       0 $self->myprint($what) unless $already_printed{$what}++;
1561             }
1562              
1563             sub optprint {
1564 7     7 0 20 my($self,$category,$what) = @_;
1565 7         18 my $vname = $category . "_verbosity";
1566 7 100       60 CPAN::HandleConfig->load unless $CPAN::Config_loaded++;
1567 7 100 66     106 if (!$CPAN::Config->{$vname}
1568             || $CPAN::Config->{$vname} =~ /^v/
1569             ) {
1570 6         33 $CPAN::Frontend->myprint($what);
1571             }
1572             }
1573              
1574             #-> sub CPAN::Shell::myexit ;
1575             sub myexit {
1576 0     0 0 0 my($self,$what) = @_;
1577 0         0 $self->myprint($what);
1578 0         0 exit;
1579             }
1580              
1581             #-> sub CPAN::Shell::mywarn ;
1582             sub mywarn {
1583 1     1 0 2 my($self,$what) = @_;
1584 1   50     10 $self->print_ornamented($what, $CPAN::Config->{colorize_warn}||'bold red on_white');
1585             }
1586              
1587             my %already_warned;
1588             #-> sub CPAN::Shell::mywarnonce ;
1589             sub mywarnonce {
1590 0     0 0   my($self,$what) = @_;
1591 0 0         $self->mywarn($what) unless $already_warned{$what}++;
1592             }
1593              
1594             # only to be used for shell commands
1595             #-> sub CPAN::Shell::mydie ;
1596             sub mydie {
1597 0     0 0   my($self,$what) = @_;
1598 0           $self->mywarn($what);
1599              
1600             # If it is the shell, we want the following die to be silent,
1601             # but if it is not the shell, we would need a 'die $what'. We need
1602             # to take care that only shell commands use mydie. Is this
1603             # possible?
1604              
1605 0           die "\n";
1606             }
1607              
1608             # sub CPAN::Shell::colorable_makemaker_prompt ;
1609             sub colorable_makemaker_prompt {
1610 0     0 0   my($foo,$bar) = @_;
1611 0 0         if (CPAN::Shell->colorize_output) {
1612 0   0       my $ornament = $CPAN::Config->{colorize_print}||'bold blue on_white';
1613 0   0       my $color_on = eval { Term::ANSIColor::color($ornament); } || "";
1614 0           print $color_on;
1615             }
1616 0           my $ans = ExtUtils::MakeMaker::prompt($foo,$bar);
1617 0 0         if (CPAN::Shell->colorize_output) {
1618 0           print Term::ANSIColor::color('reset');
1619             }
1620 0           return $ans;
1621             }
1622              
1623             # use this only for unrecoverable errors!
1624             #-> sub CPAN::Shell::unrecoverable_error ;
1625             sub unrecoverable_error {
1626 0     0 0   my($self,$what) = @_;
1627 0           my @lines = split /\n/, $what;
1628 0           my $longest = 0;
1629 0           for my $l (@lines) {
1630 0 0         $longest = length $l if length $l > $longest;
1631             }
1632 0 0         $longest = 62 if $longest > 62;
1633 0           for my $l (@lines) {
1634 0 0         if ($l =~ /^\s*$/) {
1635 0           $l = "\n";
1636 0           next;
1637             }
1638 0           $l = "==> $l";
1639 0 0         if (length $l < 66) {
1640 0           $l = pack "A66 A*", $l, "<==";
1641             }
1642 0           $l .= "\n";
1643             }
1644 0           unshift @lines, "\n";
1645 0           $self->mydie(join "", @lines);
1646             }
1647              
1648             #-> sub CPAN::Shell::mysleep ;
1649             sub mysleep {
1650 0 0 0 0 0   return if $ENV{AUTOMATED_TESTING} || ! -t STDOUT;
1651 0           my($self, $sleep) = @_;
1652 0 0         if (CPAN->has_inst("Time::HiRes")) {
1653 0           Time::HiRes::sleep($sleep);
1654             } else {
1655 0 0         sleep($sleep < 1 ? 1 : int($sleep + 0.5));
1656             }
1657             }
1658              
1659             #-> sub CPAN::Shell::setup_output ;
1660             sub setup_output {
1661 0 0   0 0   return if -t STDOUT;
1662 0           my $odef = select STDERR;
1663 0           $| = 1;
1664 0           select STDOUT;
1665 0           $| = 1;
1666 0           select $odef;
1667             }
1668              
1669             #-> sub CPAN::Shell::rematein ;
1670             # RE-adme||MA-ke||TE-st||IN-stall : nearly everything runs through here
1671             sub rematein {
1672 0     0 0   my $self = shift;
1673             # this variable was global and disturbed programmers, so localize:
1674 0           local $CPAN::Distrostatus::something_has_failed_at;
1675 0           my($meth,@some) = @_;
1676 0           my @pragma;
1677 0           while($meth =~ /^(ff?orce|notest)$/) {
1678 0           push @pragma, $meth;
1679 0 0         $meth = shift @some or
1680             $CPAN::Frontend->mydie("Pragma $pragma[-1] used without method: ".
1681             "cannot continue");
1682             }
1683 0           setup_output();
1684 0 0         CPAN->debug("pragma[@pragma]meth[$meth]some[@some]") if $CPAN::DEBUG;
1685              
1686             # Here is the place to set "test_count" on all involved parties to
1687             # 0. We then can pass this counter on to the involved
1688             # distributions and those can refuse to test if test_count > X. In
1689             # the first stab at it we could use a 1 for "X".
1690              
1691             # But when do I reset the distributions to start with 0 again?
1692             # Jost suggested to have a random or cycling interaction ID that
1693             # we pass through. But the ID is something that is just left lying
1694             # around in addition to the counter, so I'd prefer to set the
1695             # counter to 0 now, and repeat at the end of the loop. But what
1696             # about dependencies? They appear later and are not reset, they
1697             # enter the queue but not its copy. How do they get a sensible
1698             # test_count?
1699              
1700             # With configure_requires, "get" is vulnerable in recursion.
1701              
1702 0           my $needs_recursion_protection = "get|make|test|install";
1703              
1704             # construct the queue
1705 0           my($s,@s,@qcopy);
1706 0           STHING: foreach $s (@some) {
1707 0           my $obj;
1708 0 0         if (ref $s) {
    0          
    0          
    0          
1709 0 0         CPAN->debug("s is an object[$s]") if $CPAN::DEBUG;
1710 0           $obj = $s;
1711             } elsif ($s =~ m|[\$\@\%]|) { # looks like a perl variable
1712             } elsif ($s =~ m|^/|) { # looks like a regexp
1713 0 0         if (substr($s,-1,1) eq ".") {
1714 0           $obj = CPAN::Shell->expandany($s);
1715             } else {
1716 0           my @obj;
1717 0           CLASS: for my $class (qw(Distribution Bundle Module)) {
1718 0 0         if (@obj = $self->expand($class,$s)) {
1719 0           last CLASS;
1720             }
1721             }
1722 0 0         if (@obj) {
1723 0 0         if (1==@obj) {
1724 0           $obj = $obj[0];
1725             } else {
1726 0           $CPAN::Frontend->mywarn("Sorry, $meth with a regular expression is ".
1727             "only supported when unambiguous.\nRejecting argument '$s'\n");
1728 0           $CPAN::Frontend->mysleep(2);
1729 0           next STHING;
1730             }
1731             }
1732             }
1733             } elsif ($meth eq "ls") {
1734 0           $self->globls($s,\@pragma);
1735 0           next STHING;
1736             } else {
1737 0 0         CPAN->debug("calling expandany [$s]") if $CPAN::DEBUG;
1738 0           $obj = CPAN::Shell->expandany($s);
1739             }
1740 0 0 0       if (0) {
    0          
    0          
1741 0           } elsif (ref $obj) {
1742 0 0         if ($meth =~ /^($needs_recursion_protection)$/) {
1743             # it would be silly to check for recursion for look or dump
1744             # (we are in CPAN::Shell::rematein)
1745 0 0         CPAN->debug("Testing against recursion") if $CPAN::DEBUG;
1746 0           eval { $obj->color_cmd_tmps(0,1); };
  0            
1747 0 0         if ($@) {
1748 0 0 0       if (ref $@
1749             and $@->isa("CPAN::Exception::RecursiveDependency")) {
1750 0           $CPAN::Frontend->mywarn($@);
1751             } else {
1752 0           if (0) {
1753             require Carp;
1754             Carp::confess(sprintf "DEBUG: \$\@[%s]ref[%s]", $@, ref $@);
1755             }
1756 0           die;
1757             }
1758             }
1759             }
1760 0           CPAN::Queue->queue_item(qmod => $obj->id, reqtype => "c", optional => '');
1761 0           push @qcopy, $obj;
1762             } elsif ($CPAN::META->exists('CPAN::Author',uc($s))) {
1763 0           $obj = $CPAN::META->instance('CPAN::Author',uc($s));
1764 0 0         if ($meth =~ /^(dump|ls|reports)$/) {
1765 0           $obj->$meth();
1766             } else {
1767 0           $CPAN::Frontend->mywarn(
1768             join "",
1769             "Don't be silly, you can't $meth ",
1770             $obj->fullname,
1771             " ;-)\n"
1772             );
1773 0           $CPAN::Frontend->mysleep(2);
1774             }
1775             } elsif ($s =~ m|[\$\@\%]| && $meth eq "dump") {
1776 0           CPAN::InfoObj->dump($s);
1777             } else {
1778 0           $CPAN::Frontend
1779             ->mywarn(qq{Warning: Cannot $meth $s, }.
1780             qq{don't know what it is.
1781             Try the command
1782              
1783             i /$s/
1784              
1785             to find objects with matching identifiers.
1786             });
1787 0           $CPAN::Frontend->mysleep(2);
1788             }
1789             }
1790              
1791             # queuerunner (please be warned: when I started to change the
1792             # queue to hold objects instead of names, I made one or two
1793             # mistakes and never found which. I reverted back instead)
1794 0           QITEM: while (my $q = CPAN::Queue->first) {
1795 0           my $obj;
1796 0           my $s = $q->as_string;
1797 0   0       my $reqtype = $q->reqtype || "";
1798 0   0       my $optional = $q->optional || "";
1799 0           $obj = CPAN::Shell->expandany($s);
1800 0 0         unless ($obj) {
1801             # don't know how this can happen, maybe we should panic,
1802             # but maybe we get a solution from the first user who hits
1803             # this unfortunate exception?
1804 0           $CPAN::Frontend->mywarn("Warning: Could not expand string '$s' ".
1805             "to an object. Skipping.\n");
1806 0           $CPAN::Frontend->mysleep(5);
1807 0           CPAN::Queue->delete_first($s);
1808 0           next QITEM;
1809             }
1810 0   0       $obj->{reqtype} ||= "";
1811 0           my $type = ref $obj;
1812 0 0 0       if ( $type eq 'CPAN::Distribution' || $type eq 'CPAN::Bundle' ) {
    0          
1813 0   0       $obj->{mandatory} ||= ! $optional; # once mandatory, always mandatory
1814             }
1815             elsif ( $type eq 'CPAN::Module' ) {
1816 0   0       $obj->{mandatory} ||= ! $optional; # once mandatory, always mandatory
1817 0 0         if (my $d = $obj->distribution) {
    0          
1818 0   0       $d->{mandatory} ||= ! $optional; # once mandatory, always mandatory
1819             } elsif ($optional) {
1820             # the queue object does not know who was recommending/suggesting us:(
1821             # So we only vaguely write "optional".
1822 0           $CPAN::Frontend->mywarn("Warning: optional module '$s' ".
1823             "not known. Skipping.\n");
1824 0           CPAN::Queue->delete_first($s);
1825 0           next QITEM;
1826             }
1827             }
1828             {
1829             # force debugging because CPAN::SQLite somehow delivers us
1830             # an empty object;
1831              
1832             # local $CPAN::DEBUG = 1024; # Shell; probably fixed now
1833              
1834 0 0         CPAN->debug("s[$s]obj-reqtype[$obj->{reqtype}]".
  0            
1835             "q-reqtype[$reqtype]") if $CPAN::DEBUG;
1836             }
1837 0 0         if ($obj->{reqtype}) {
1838 0 0 0       if ($obj->{reqtype} eq "b" && $reqtype =~ /^[rc]$/) {
1839 0           $obj->{reqtype} = $reqtype;
1840 0 0 0       if (
    0          
1841             exists $obj->{install}
1842             &&
1843             (
1844             UNIVERSAL::can($obj->{install},"failed") ?
1845             $obj->{install}->failed :
1846             $obj->{install} =~ /^NO/
1847             )
1848             ) {
1849 0           delete $obj->{install};
1850 0           $CPAN::Frontend->mywarn
1851             ("Promoting $obj->{ID} from 'build_requires' to 'requires'");
1852             }
1853             }
1854             } else {
1855 0           $obj->{reqtype} = $reqtype;
1856             }
1857              
1858 0           for my $pragma (@pragma) {
1859 0 0 0       if ($pragma
1860             &&
1861             $obj->can($pragma)) {
1862 0           $obj->$pragma($meth);
1863             }
1864             }
1865 0 0         if (UNIVERSAL::can($obj, 'called_for')) {
1866 0           $obj->called_for($s);
1867             }
1868 0 0         CPAN->debug(qq{pragma[@pragma]meth[$meth]}.
1869             qq{ID[$obj->{ID}]}) if $CPAN::DEBUG;
1870              
1871 0           push @qcopy, $obj;
1872 0 0         if ($meth =~ /^(report)$/) { # they came here with a pragma?
    0          
1873 0           $self->$meth($obj);
1874             } elsif (! UNIVERSAL::can($obj,$meth)) {
1875             # Must never happen
1876 0           my $serialized = "";
1877 0 0         if (0) {
    0          
    0          
1878 0           } elsif ($CPAN::META->has_inst("YAML::Syck")) {
1879 0           $serialized = YAML::Syck::Dump($obj);
1880             } elsif ($CPAN::META->has_inst("YAML")) {
1881 0           $serialized = YAML::Dump($obj);
1882             } elsif ($CPAN::META->has_inst("Data::Dumper")) {
1883 0           $serialized = Data::Dumper::Dumper($obj);
1884             } else {
1885 0           require overload;
1886 0           $serialized = overload::StrVal($obj);
1887             }
1888 0 0         CPAN->debug("Going to panic. meth[$meth]s[$s]") if $CPAN::DEBUG;
1889 0           $CPAN::Frontend->mydie("Panic: obj[$serialized] cannot meth[$meth]");
1890             } else {
1891 0           my $upgraded_meth = $meth;
1892 0 0 0       if ( $meth eq "make" and $obj->{reqtype} eq "b" ) {
1893             # rt 86915
1894 0           $upgraded_meth = "test";
1895             }
1896 0 0         if ($obj->$upgraded_meth()) {
1897 0           CPAN::Queue->delete($s);
1898 0 0         CPAN->debug("Succeeded and deleted from queue. pragma[@pragma]meth[$meth][s][$s]") if $CPAN::DEBUG;
1899             } else {
1900 0 0         CPAN->debug("Failed. pragma[@pragma]meth[$meth]s[$s]") if $CPAN::DEBUG;
1901             }
1902             }
1903              
1904 0           $obj->undelay;
1905 0           for my $pragma (@pragma) {
1906 0           my $unpragma = "un$pragma";
1907 0 0         if ($obj->can($unpragma)) {
1908 0           $obj->$unpragma();
1909             }
1910             }
1911             # if any failures occurred and the current object is mandatory, we
1912             # still don't know if *it* failed or if it was another (optional)
1913             # module, so we have to check that explicitly (and expensively)
1914 0 0 0       if ( $CPAN::Config->{halt_on_failure}
      0        
      0        
1915             && $obj->{mandatory}
1916             && CPAN::Distrostatus::something_has_just_failed()
1917             && $self->mandatory_dist_failed()
1918             ) {
1919 0           $CPAN::Frontend->mywarn("Stopping: '$meth' failed for '$s'.\n");
1920 0           CPAN::Queue->nullify_queue;
1921 0           last QITEM;
1922             }
1923 0           CPAN::Queue->delete_first($s);
1924             }
1925 0 0         if ($meth =~ /^($needs_recursion_protection)$/) {
1926 0           for my $obj (@qcopy) {
1927 0           $obj->color_cmd_tmps(0,0);
1928             }
1929             }
1930             }
1931              
1932             #-> sub CPAN::Shell::recent ;
1933             sub recent {
1934 0     0 0   my($self) = @_;
1935 0 0         if ($CPAN::META->has_inst("XML::LibXML")) {
1936 0           my $url = $CPAN::Defaultrecent;
1937 0           $CPAN::Frontend->myprint("Fetching '$url'\n");
1938 0 0         unless ($CPAN::META->has_usable("LWP")) {
1939 0           $CPAN::Frontend->mydie("LWP not installed; cannot continue");
1940             }
1941 0           CPAN::LWP::UserAgent->config;
1942 0           my $Ua;
1943 0           eval { $Ua = CPAN::LWP::UserAgent->new; };
  0            
1944 0 0         if ($@) {
1945 0           $CPAN::Frontend->mydie("CPAN::LWP::UserAgent->new dies with $@\n");
1946             }
1947 0           my $resp = $Ua->get($url);
1948 0 0         unless ($resp->is_success) {
1949 0           $CPAN::Frontend->mydie(sprintf "Could not download '%s': %s\n", $url, $resp->code);
1950             }
1951 0           $CPAN::Frontend->myprint("DONE\n\n");
1952 0           my $xml = XML::LibXML->new->parse_string($resp->content);
1953 0           if (0) {
1954             my $s = $xml->serialize(2);
1955             $s =~ s/\n\s*\n/\n/g;
1956             $CPAN::Frontend->myprint($s);
1957             return;
1958             }
1959 0           my @distros;
1960 0 0         if ($url =~ /winnipeg/) {
    0          
1961 0           my $pubdate = $xml->findvalue("/rss/channel/pubDate");
1962 0           $CPAN::Frontend->myprint(" pubDate: $pubdate\n\n");
1963 0           for my $eitem ($xml->findnodes("/rss/channel/item")) {
1964 0           my $distro = $eitem->findvalue("enclosure/\@url");
1965 0           $distro =~ s|.*?/authors/id/./../||;
1966 0           my $size = $eitem->findvalue("enclosure/\@length");
1967 0           my $desc = $eitem->findvalue("description");
1968 0           $desc =~ s/.+? - //;
1969 0           $CPAN::Frontend->myprint("$distro [$size b]\n $desc\n");
1970 0           push @distros, $distro;
1971             }
1972             } elsif ($url =~ /search.*uploads.rdf/) {
1973             # xmlns:rdf="http://www.w3.org/1999/02/22-rdf-syntax-ns#"
1974             # xmlns="http://purl.org/rss/1.0/"
1975             # xmlns:taxo="http://purl.org/rss/1.0/modules/taxonomy/"
1976             # xmlns:dc="http://purl.org/dc/elements/1.1/"
1977             # xmlns:syn="http://purl.org/rss/1.0/modules/syndication/"
1978             # xmlns:admin="http://webns.net/mvcb/"
1979              
1980              
1981 0           my $dc_date = $xml->findvalue("//*[local-name(.) = 'RDF']/*[local-name(.) = 'channel']/*[local-name(.) = 'date']");
1982 0           $CPAN::Frontend->myprint(" dc:date: $dc_date\n\n");
1983 0           my $finish_eitem = 0;
1984 0     0     local $SIG{INT} = sub { $finish_eitem = 1 };
  0            
1985 0           EITEM: for my $eitem ($xml->findnodes("//*[local-name(.) = 'RDF']/*[local-name(.) = 'item']")) {
1986 0           my $distro = $eitem->findvalue("\@rdf:about");
1987 0           $distro =~ s|.*~||; # remove up to the tilde before the name
1988 0           $distro =~ s|/$||; # remove trailing slash
1989 0           $distro =~ s|([^/]+)|\U$1\E|; # upcase the name
1990 0 0         my $author = uc $1 or die "distro[$distro] without author, cannot continue";
1991 0           my $desc = $eitem->findvalue("*[local-name(.) = 'description']");
1992 0           my $i = 0;
1993 0           SUBDIRTEST: while () {
1994 0 0         last SUBDIRTEST if ++$i >= 6; # half a dozen must do!
1995 0 0         if (my @ret = $self->globls("$distro*")) {
1996 0           @ret = grep {$_->[2] !~ /meta/} @ret;
  0            
1997 0           @ret = grep {length $_->[2]} @ret;
  0            
1998 0 0         if (@ret) {
1999 0           $distro = "$author/$ret[0][2]";
2000 0           last SUBDIRTEST;
2001             }
2002             }
2003 0           $distro =~ s|/|/*/|; # allow it to reside in a subdirectory
2004             }
2005              
2006 0 0         next EITEM if $distro =~ m|\*|; # did not find the thing
2007 0           $CPAN::Frontend->myprint("____$desc\n");
2008 0           push @distros, $distro;
2009 0 0         last EITEM if $finish_eitem;
2010             }
2011             }
2012 0           return \@distros;
2013             } else {
2014             # deprecated old version
2015 0           $CPAN::Frontend->mydie("no XML::LibXML installed, cannot continue\n");
2016             }
2017             }
2018              
2019             #-> sub CPAN::Shell::smoke ;
2020             sub smoke {
2021 0     0 0   my($self) = @_;
2022 0           my $distros = $self->recent;
2023 0           DISTRO: for my $distro (@$distros) {
2024 0 0         next if $distro =~ m|/Bundle-|; # XXX crude heuristic to skip bundles
2025 0           $CPAN::Frontend->myprint(sprintf "Downloading and testing '$distro'\n");
2026             {
2027 0           my $skip = 0;
  0            
2028 0     0     local $SIG{INT} = sub { $skip = 1 };
  0            
2029 0           for (0..9) {
2030 0           $CPAN::Frontend->myprint(sprintf "\r%2d (Hit ^C to skip)", 10-$_);
2031 0           sleep 1;
2032 0 0         if ($skip) {
2033 0           $CPAN::Frontend->myprint(" skipped\n");
2034 0           next DISTRO;
2035             }
2036             }
2037             }
2038 0           $CPAN::Frontend->myprint("\r \n"); # leave the dirty line with a newline
2039 0           $self->test($distro);
2040             }
2041             }
2042              
2043             {
2044             # set up the dispatching methods
2045 12     12   145 no strict "refs";
  12         30  
  12         1954  
2046             for my $command (qw(
2047             clean
2048             cvs_import
2049             dump
2050             force
2051             fforce
2052             get
2053             install
2054             look
2055             ls
2056             make
2057             notest
2058             perldoc
2059             readme
2060             reports
2061             test
2062             )) {
2063 0     0     *$command = sub { shift->rematein($command, @_); };
2064             }
2065             }
2066              
2067             1;