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