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