"Fossies" - the Fresh Open Source Software Archive

Member "install-tl-20200916/tlpkg/tlperl/lib/CPAN/Shell.pm" (7 Mar 2020, 73619 Bytes) of package /windows/misc/install-tl.zip:


As a special service "Fossies" has tried to format the requested source page into HTML format using (guessed) Perl source code syntax highlighting (style: standard) with prefixed line numbers and code folding option. Alternatively you can here view or download the uninterpreted source code file.

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