File Coverage

blib/lib/CPAN/Shell.pm
Criterion Covered Total %
statement 71 1109 6.4
branch 28 648 4.3
condition 8 163 4.9
subroutine 13 64 20.3
pod 0 47 0.0
total 120 2031 5.9


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