cpan/CPAN/lib/CPAN/Shell.pm

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