lib/CPAN/Shell.pm

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