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.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", # hide from perl-reversion
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     my $module_as_path = "";
1233     if ($s =~ m|(?:\w+/)*\w+\.pm$|) {
1234         $module_as_path = $s;
1235         $module_as_path =~ s/.pm$//;
1236         $module_as_path =~ s|/|::|g;
1237     }
1238     if ($module_as_path) {
1239         if ($module_as_path =~ m|^Bundle::|) {
1240             $self->local_bundles;
1241             return $self->expand('Bundle',$module_as_path);
1242         } else {
1243             return $self->expand('Module',$module_as_path)
1244                 if $CPAN::META->exists('CPAN::Module',$module_as_path);
1245         }
1246     } elsif ($s =~ m|/| or substr($s,-1,1) eq ".") { # looks like a file or a directory
1247         $s = CPAN::Distribution->normalize($s);
1248         return $CPAN::META->instance('CPAN::Distribution',$s);
1249         # Distributions spring into existence, not expand
1250     } elsif ($s =~ m|^Bundle::|) {
1251         $self->local_bundles; # scanning so late for bundles seems
1252                               # both attractive and crumpy: always
1253                               # current state but easy to forget
1254                               # somewhere
1255         return $self->expand('Bundle',$s);
1256     } else {
1257         return $self->expand('Module',$s)
1258             if $CPAN::META->exists('CPAN::Module',$s);
1259     }
1260     return;
1261 }
1262
1263 #-> sub CPAN::Shell::expand ;
1264 sub expand {
1265     my $self = shift;
1266     my($type,@args) = @_;
1267     CPAN->debug("type[$type]args[@args]") if $CPAN::DEBUG;
1268     my $class = "CPAN::$type";
1269     my $methods = ['id'];
1270     for my $meth (qw(name)) {
1271         next unless $class->can($meth);
1272         push @$methods, $meth;
1273     }
1274     $self->expand_by_method($class,$methods,@args);
1275 }
1276
1277 #-> sub CPAN::Shell::expand_by_method ;
1278 sub expand_by_method {
1279     my $self = shift;
1280     my($class,$methods,@args) = @_;
1281     my($arg,@m);
1282     for $arg (@args) {
1283         my($regex,$command);
1284         if ($arg =~ m|^/(.*)/$|) {
1285             $regex = $1;
1286 # FIXME:  there seem to be some ='s in the author data, which trigger
1287 #         a failure here.  This needs to be contemplated.
1288 #            } elsif ($arg =~ m/=/) {
1289 #                $command = 1;
1290         }
1291         my $obj;
1292         CPAN->debug(sprintf "class[%s]regex[%s]command[%s]",
1293                     $class,
1294                     defined $regex ? $regex : "UNDEFINED",
1295                     defined $command ? $command : "UNDEFINED",
1296                    ) if $CPAN::DEBUG;
1297         if (defined $regex) {
1298             if (CPAN::_sqlite_running()) {
1299                 CPAN::Index->reload;
1300                 $CPAN::SQLite->search($class, $regex);
1301             }
1302             for $obj (
1303                       $CPAN::META->all_objects($class)
1304                      ) {
1305                 unless ($obj && UNIVERSAL::can($obj,"id") && $obj->id) {
1306                     # BUG, we got an empty object somewhere
1307                     require Data::Dumper;
1308                     CPAN->debug(sprintf(
1309                                         "Bug in CPAN: Empty id on obj[%s][%s]",
1310                                         $obj,
1311                                         Data::Dumper::Dumper($obj)
1312                                        )) if $CPAN::DEBUG;
1313                     next;
1314                 }
1315                 for my $method (@$methods) {
1316                     my $match = eval {$obj->$method() =~ /$regex/i};
1317                     if ($@) {
1318                         my($err) = $@ =~ /^(.+) at .+? line \d+\.$/;
1319                         $err ||= $@; # if we were too restrictive above
1320                         $CPAN::Frontend->mydie("$err\n");
1321                     } elsif ($match) {
1322                         push @m, $obj;
1323                         last;
1324                     }
1325                 }
1326             }
1327         } elsif ($command) {
1328             die "equal sign in command disabled (immature interface), ".
1329                 "you can set
1330  ! \$CPAN::Shell::ADVANCED_QUERY=1
1331 to enable it. But please note, this is HIGHLY EXPERIMENTAL code
1332 that may go away anytime.\n"
1333                     unless $ADVANCED_QUERY;
1334             my($method,$criterion) = $arg =~ /(.+?)=(.+)/;
1335             my($matchcrit) = $criterion =~ m/^~(.+)/;
1336             for my $self (
1337                           sort
1338                           {$a->id cmp $b->id}
1339                           $CPAN::META->all_objects($class)
1340                          ) {
1341                 my $lhs = $self->$method() or next; # () for 5.00503
1342                 if ($matchcrit) {
1343                     push @m, $self if $lhs =~ m/$matchcrit/;
1344                 } else {
1345                     push @m, $self if $lhs eq $criterion;
1346                 }
1347             }
1348         } else {
1349             my($xarg) = $arg;
1350             if ( $class eq 'CPAN::Bundle' ) {
1351                 $xarg =~ s/^(Bundle::)?(.*)/Bundle::$2/;
1352             } elsif ($class eq "CPAN::Distribution") {
1353                 $xarg = CPAN::Distribution->normalize($arg);
1354             } else {
1355                 $xarg =~ s/:+/::/g;
1356             }
1357             if ($CPAN::META->exists($class,$xarg)) {
1358                 $obj = $CPAN::META->instance($class,$xarg);
1359             } elsif ($CPAN::META->exists($class,$arg)) {
1360                 $obj = $CPAN::META->instance($class,$arg);
1361             } else {
1362                 next;
1363             }
1364             push @m, $obj;
1365         }
1366     }
1367     @m = sort {$a->id cmp $b->id} @m;
1368     if ( $CPAN::DEBUG ) {
1369         my $wantarray = wantarray;
1370         my $join_m = join ",", map {$_->id} @m;
1371         # $self->debug("wantarray[$wantarray]join_m[$join_m]");
1372         my $count = scalar @m;
1373         $self->debug("class[$class]wantarray[$wantarray]count m[$count]");
1374     }
1375     return wantarray ? @m : $m[0];
1376 }
1377
1378 #-> sub CPAN::Shell::format_result ;
1379 sub format_result {
1380     my($self) = shift;
1381     my($type,@args) = @_;
1382     @args = '/./' unless @args;
1383     my(@result) = $self->expand($type,@args);
1384     my $result = @result == 1 ?
1385         $result[0]->as_string :
1386             @result == 0 ?
1387                 "No objects of type $type found for argument @args\n" :
1388                     join("",
1389                          (map {$_->as_glimpse} @result),
1390                          scalar @result, " items found\n",
1391                         );
1392     $result;
1393 }
1394
1395 #-> sub CPAN::Shell::report_fh ;
1396 {
1397     my $installation_report_fh;
1398     my $previously_noticed = 0;
1399
1400     sub report_fh {
1401         return $installation_report_fh if $installation_report_fh;
1402         if ($CPAN::META->has_usable("File::Temp")) {
1403             $installation_report_fh
1404                 = File::Temp->new(
1405                                   dir      => File::Spec->tmpdir,
1406                                   template => 'cpan_install_XXXX',
1407                                   suffix   => '.txt',
1408                                   unlink   => 0,
1409                                  );
1410         }
1411         unless ( $installation_report_fh ) {
1412             warn("Couldn't open installation report file; " .
1413                  "no report file will be generated."
1414                 ) unless $previously_noticed++;
1415         }
1416     }
1417 }
1418
1419
1420 # The only reason for this method is currently to have a reliable
1421 # debugging utility that reveals which output is going through which
1422 # channel. No, I don't like the colors ;-)
1423
1424 # to turn colordebugging on, write
1425 # cpan> o conf colorize_output 1
1426
1427 #-> sub CPAN::Shell::colorize_output ;
1428 {
1429     my $print_ornamented_have_warned = 0;
1430     sub colorize_output {
1431         my $colorize_output = $CPAN::Config->{colorize_output};
1432         if ($colorize_output && !$CPAN::META->has_inst("Term::ANSIColor")) {
1433             unless ($print_ornamented_have_warned++) {
1434                 # no myprint/mywarn within myprint/mywarn!
1435                 warn "Colorize_output is set to true but Term::ANSIColor is not
1436 installed. To activate colorized output, please install Term::ANSIColor.\n\n";
1437             }
1438             $colorize_output = 0;
1439         }
1440         return $colorize_output;
1441     }
1442 }
1443
1444
1445 #-> sub CPAN::Shell::print_ornamented ;
1446 sub print_ornamented {
1447     my($self,$what,$ornament) = @_;
1448     return unless defined $what;
1449
1450     local $| = 1; # Flush immediately
1451     if ( $CPAN::Be_Silent ) {
1452         print {report_fh()} $what;
1453         return;
1454     }
1455     my $swhat = "$what"; # stringify if it is an object
1456     if ($CPAN::Config->{term_is_latin}) {
1457         # note: deprecated, need to switch to $LANG and $LC_*
1458         # courtesy jhi:
1459         $swhat
1460             =~ s{([\xC0-\xDF])([\x80-\xBF])}{chr(ord($1)<<6&0xC0|ord($2)&0x3F)}eg; #};
1461     }
1462     if ($self->colorize_output) {
1463         if ( $CPAN::DEBUG && $swhat =~ /^Debug\(/ ) {
1464             # if you want to have this configurable, please file a bugreport
1465             $ornament = $CPAN::Config->{colorize_debug} || "black on_cyan";
1466         }
1467         my $color_on = eval { Term::ANSIColor::color($ornament) } || "";
1468         if ($@) {
1469             print "Term::ANSIColor rejects color[$ornament]: $@\n
1470 Please choose a different color (Hint: try 'o conf init /color/')\n";
1471         }
1472         # GGOLDBACH/Test-GreaterVersion-0.008 broke without this
1473         # $trailer construct. We want the newline be the last thing if
1474         # there is a newline at the end ensuring that the next line is
1475         # empty for other players
1476         my $trailer = "";
1477         $trailer = $1 if $swhat =~ s/([\r\n]+)\z//;
1478         print $color_on,
1479             $swhat,
1480                 Term::ANSIColor::color("reset"),
1481                       $trailer;
1482     } else {
1483         print $swhat;
1484     }
1485 }
1486
1487 #-> sub CPAN::Shell::myprint ;
1488
1489 # where is myprint/mywarn/Frontend/etc. documented? Where to use what?
1490 # I think, we send everything to STDOUT and use print for normal/good
1491 # news and warn for news that need more attention. Yes, this is our
1492 # working contract for now.
1493 sub myprint {
1494     my($self,$what) = @_;
1495     $self->print_ornamented($what,
1496                             $CPAN::Config->{colorize_print}||'bold blue on_white',
1497                            );
1498 }
1499
1500 sub optprint {
1501     my($self,$category,$what) = @_;
1502     my $vname = $category . "_verbosity";
1503     CPAN::HandleConfig->load unless $CPAN::Config_loaded++;
1504     if (!$CPAN::Config->{$vname}
1505         || $CPAN::Config->{$vname} =~ /^v/
1506        ) {
1507         $CPAN::Frontend->myprint($what);
1508     }
1509 }
1510
1511 #-> sub CPAN::Shell::myexit ;
1512 sub myexit {
1513     my($self,$what) = @_;
1514     $self->myprint($what);
1515     exit;
1516 }
1517
1518 #-> sub CPAN::Shell::mywarn ;
1519 sub mywarn {
1520     my($self,$what) = @_;
1521     $self->print_ornamented($what, $CPAN::Config->{colorize_warn}||'bold red on_white');
1522 }
1523
1524 # only to be used for shell commands
1525 #-> sub CPAN::Shell::mydie ;
1526 sub mydie {
1527     my($self,$what) = @_;
1528     $self->mywarn($what);
1529
1530     # If it is the shell, we want the following die to be silent,
1531     # but if it is not the shell, we would need a 'die $what'. We need
1532     # to take care that only shell commands use mydie. Is this
1533     # possible?
1534
1535     die "\n";
1536 }
1537
1538 # sub CPAN::Shell::colorable_makemaker_prompt ;
1539 sub colorable_makemaker_prompt {
1540     my($foo,$bar) = @_;
1541     if (CPAN::Shell->colorize_output) {
1542         my $ornament = $CPAN::Config->{colorize_print}||'bold blue on_white';
1543         my $color_on = eval { Term::ANSIColor::color($ornament); } || "";
1544         print $color_on;
1545     }
1546     my $ans = ExtUtils::MakeMaker::prompt($foo,$bar);
1547     if (CPAN::Shell->colorize_output) {
1548         print Term::ANSIColor::color('reset');
1549     }
1550     return $ans;
1551 }
1552
1553 # use this only for unrecoverable errors!
1554 #-> sub CPAN::Shell::unrecoverable_error ;
1555 sub unrecoverable_error {
1556     my($self,$what) = @_;
1557     my @lines = split /\n/, $what;
1558     my $longest = 0;
1559     for my $l (@lines) {
1560         $longest = length $l if length $l > $longest;
1561     }
1562     $longest = 62 if $longest > 62;
1563     for my $l (@lines) {
1564         if ($l =~ /^\s*$/) {
1565             $l = "\n";
1566             next;
1567         }
1568         $l = "==> $l";
1569         if (length $l < 66) {
1570             $l = pack "A66 A*", $l, "<==";
1571         }
1572         $l .= "\n";
1573     }
1574     unshift @lines, "\n";
1575     $self->mydie(join "", @lines);
1576 }
1577
1578 #-> sub CPAN::Shell::mysleep ;
1579 sub mysleep {
1580     my($self, $sleep) = @_;
1581     if (CPAN->has_inst("Time::HiRes")) {
1582         Time::HiRes::sleep($sleep);
1583     } else {
1584         sleep($sleep < 1 ? 1 : int($sleep + 0.5));
1585     }
1586 }
1587
1588 #-> sub CPAN::Shell::setup_output ;
1589 sub setup_output {
1590     return if -t STDOUT;
1591     my $odef = select STDERR;
1592     $| = 1;
1593     select STDOUT;
1594     $| = 1;
1595     select $odef;
1596 }
1597
1598 #-> sub CPAN::Shell::rematein ;
1599 # RE-adme||MA-ke||TE-st||IN-stall : nearly everything runs through here
1600 sub rematein {
1601     my $self = shift;
1602     # this variable was global and disturbed programmers, so localize:
1603     local $CPAN::Distrostatus::something_has_failed_at;
1604     my($meth,@some) = @_;
1605     my @pragma;
1606     while($meth =~ /^(ff?orce|notest)$/) {
1607         push @pragma, $meth;
1608         $meth = shift @some or
1609             $CPAN::Frontend->mydie("Pragma $pragma[-1] used without method: ".
1610                                    "cannot continue");
1611     }
1612     setup_output();
1613     CPAN->debug("pragma[@pragma]meth[$meth]some[@some]") if $CPAN::DEBUG;
1614
1615     # Here is the place to set "test_count" on all involved parties to
1616     # 0. We then can pass this counter on to the involved
1617     # distributions and those can refuse to test if test_count > X. In
1618     # the first stab at it we could use a 1 for "X".
1619
1620     # But when do I reset the distributions to start with 0 again?
1621     # Jost suggested to have a random or cycling interaction ID that
1622     # we pass through. But the ID is something that is just left lying
1623     # around in addition to the counter, so I'd prefer to set the
1624     # counter to 0 now, and repeat at the end of the loop. But what
1625     # about dependencies? They appear later and are not reset, they
1626     # enter the queue but not its copy. How do they get a sensible
1627     # test_count?
1628
1629     # With configure_requires, "get" is vulnerable in recursion.
1630
1631     my $needs_recursion_protection = "get|make|test|install";
1632
1633     # construct the queue
1634     my($s,@s,@qcopy);
1635   STHING: foreach $s (@some) {
1636         my $obj;
1637         if (ref $s) {
1638             CPAN->debug("s is an object[$s]") if $CPAN::DEBUG;
1639             $obj = $s;
1640         } elsif ($s =~ m|[\$\@\%]|) { # looks like a perl variable
1641         } elsif ($s =~ m|^/|) { # looks like a regexp
1642             if (substr($s,-1,1) eq ".") {
1643                 $obj = CPAN::Shell->expandany($s);
1644             } else {
1645                 my @obj;
1646             CLASS: for my $class (qw(Distribution Bundle Module)) {
1647                     if (@obj = $self->expand($class,$s)) {
1648                         last CLASS;
1649                     }
1650                 }
1651                 if (@obj) {
1652                     if (1==@obj) {
1653                         $obj = $obj[0];
1654                     } else {
1655                         $CPAN::Frontend->mywarn("Sorry, $meth with a regular expression is ".
1656                                                 "only supported when unambiguous.\nRejecting argument '$s'\n");
1657                         $CPAN::Frontend->mysleep(2);
1658                         next STHING;
1659                     }
1660                 }
1661             }
1662         } elsif ($meth eq "ls") {
1663             $self->globls($s,\@pragma);
1664             next STHING;
1665         } else {
1666             CPAN->debug("calling expandany [$s]") if $CPAN::DEBUG;
1667             $obj = CPAN::Shell->expandany($s);
1668         }
1669         if (0) {
1670         } elsif (ref $obj) {
1671             if ($meth =~ /^($needs_recursion_protection)$/) {
1672                 # it would be silly to check for recursion for look or dump
1673                 # (we are in CPAN::Shell::rematein)
1674                 CPAN->debug("Going to test against recursion") if $CPAN::DEBUG;
1675                 eval {  $obj->color_cmd_tmps(0,1); };
1676                 if ($@) {
1677                     if (ref $@
1678                         and $@->isa("CPAN::Exception::RecursiveDependency")) {
1679                         $CPAN::Frontend->mywarn($@);
1680                     } else {
1681                         if (0) {
1682                             require Carp;
1683                             Carp::confess(sprintf "DEBUG: \$\@[%s]ref[%s]", $@, ref $@);
1684                         }
1685                         die;
1686                     }
1687                 }
1688             }
1689             CPAN::Queue->queue_item(qmod => $obj->id, reqtype => "c");
1690             push @qcopy, $obj;
1691         } elsif ($CPAN::META->exists('CPAN::Author',uc($s))) {
1692             $obj = $CPAN::META->instance('CPAN::Author',uc($s));
1693             if ($meth =~ /^(dump|ls|reports)$/) {
1694                 $obj->$meth();
1695             } else {
1696                 $CPAN::Frontend->mywarn(
1697                                         join "",
1698                                         "Don't be silly, you can't $meth ",
1699                                         $obj->fullname,
1700                                         " ;-)\n"
1701                                        );
1702                 $CPAN::Frontend->mysleep(2);
1703             }
1704         } elsif ($s =~ m|[\$\@\%]| && $meth eq "dump") {
1705             CPAN::InfoObj->dump($s);
1706         } else {
1707             $CPAN::Frontend
1708                 ->mywarn(qq{Warning: Cannot $meth $s, }.
1709                          qq{don't know what it is.
1710 Try the command
1711
1712     i /$s/
1713
1714 to find objects with matching identifiers.
1715 });
1716             $CPAN::Frontend->mysleep(2);
1717         }
1718     }
1719
1720     # queuerunner (please be warned: when I started to change the
1721     # queue to hold objects instead of names, I made one or two
1722     # mistakes and never found which. I reverted back instead)
1723   QITEM: while (my $q = CPAN::Queue->first) {
1724         my $obj;
1725         my $s = $q->as_string;
1726         my $reqtype = $q->reqtype || "";
1727         $obj = CPAN::Shell->expandany($s);
1728         unless ($obj) {
1729             # don't know how this can happen, maybe we should panic,
1730             # but maybe we get a solution from the first user who hits
1731             # this unfortunate exception?
1732             $CPAN::Frontend->mywarn("Warning: Could not expand string '$s' ".
1733                                     "to an object. Skipping.\n");
1734             $CPAN::Frontend->mysleep(5);
1735             CPAN::Queue->delete_first($s);
1736             next QITEM;
1737         }
1738         $obj->{reqtype} ||= "";
1739         {
1740             # force debugging because CPAN::SQLite somehow delivers us
1741             # an empty object;
1742
1743             # local $CPAN::DEBUG = 1024; # Shell; probably fixed now
1744
1745             CPAN->debug("s[$s]obj-reqtype[$obj->{reqtype}]".
1746                         "q-reqtype[$reqtype]") if $CPAN::DEBUG;
1747         }
1748         if ($obj->{reqtype}) {
1749             if ($obj->{reqtype} eq "b" && $reqtype =~ /^[rc]$/) {
1750                 $obj->{reqtype} = $reqtype;
1751                 if (
1752                     exists $obj->{install}
1753                     &&
1754                     (
1755                      UNIVERSAL::can($obj->{install},"failed") ?
1756                      $obj->{install}->failed :
1757                      $obj->{install} =~ /^NO/
1758                     )
1759                    ) {
1760                     delete $obj->{install};
1761                     $CPAN::Frontend->mywarn
1762                         ("Promoting $obj->{ID} from 'build_requires' to 'requires'");
1763                 }
1764             }
1765         } else {
1766             $obj->{reqtype} = $reqtype;
1767         }
1768
1769         for my $pragma (@pragma) {
1770             if ($pragma
1771                 &&
1772                 $obj->can($pragma)) {
1773                 $obj->$pragma($meth);
1774             }
1775         }
1776         if (UNIVERSAL::can($obj, 'called_for')) {
1777             $obj->called_for($s);
1778         }
1779         CPAN->debug(qq{pragma[@pragma]meth[$meth]}.
1780                     qq{ID[$obj->{ID}]}) if $CPAN::DEBUG;
1781
1782         push @qcopy, $obj;
1783         if ($meth =~ /^(report)$/) { # they came here with a pragma?
1784             $self->$meth($obj);
1785         } elsif (! UNIVERSAL::can($obj,$meth)) {
1786             # Must never happen
1787             my $serialized = "";
1788             if (0) {
1789             } elsif ($CPAN::META->has_inst("YAML::Syck")) {
1790                 $serialized = YAML::Syck::Dump($obj);
1791             } elsif ($CPAN::META->has_inst("YAML")) {
1792                 $serialized = YAML::Dump($obj);
1793             } elsif ($CPAN::META->has_inst("Data::Dumper")) {
1794                 $serialized = Data::Dumper::Dumper($obj);
1795             } else {
1796                 require overload;
1797                 $serialized = overload::StrVal($obj);
1798             }
1799             CPAN->debug("Going to panic. meth[$meth]s[$s]") if $CPAN::DEBUG;
1800             $CPAN::Frontend->mydie("Panic: obj[$serialized] cannot meth[$meth]");
1801         } elsif ($obj->$meth()) {
1802             CPAN::Queue->delete($s);
1803             CPAN->debug("From queue deleted. meth[$meth]s[$s]") if $CPAN::DEBUG;
1804         } else {
1805             CPAN->debug("Failed. pragma[@pragma]meth[$meth]") if $CPAN::DEBUG;
1806         }
1807
1808         $obj->undelay;
1809         for my $pragma (@pragma) {
1810             my $unpragma = "un$pragma";
1811             if ($obj->can($unpragma)) {
1812                 $obj->$unpragma();
1813             }
1814         }
1815         if ($CPAN::Config->{halt_on_failure}
1816                 &&
1817                     CPAN::Distrostatus::something_has_just_failed()
1818               ) {
1819             $CPAN::Frontend->mywarn("Stopping: '$meth' failed for '$s'.\n");
1820             CPAN::Queue->nullify_queue;
1821             last QITEM;
1822         }
1823         CPAN::Queue->delete_first($s);
1824     }
1825     if ($meth =~ /^($needs_recursion_protection)$/) {
1826         for my $obj (@qcopy) {
1827             $obj->color_cmd_tmps(0,0);
1828         }
1829     }
1830 }
1831
1832 #-> sub CPAN::Shell::recent ;
1833 sub recent {
1834   my($self) = @_;
1835   if ($CPAN::META->has_inst("XML::LibXML")) {
1836       my $url = $CPAN::Defaultrecent;
1837       $CPAN::Frontend->myprint("Going to fetch '$url'\n");
1838       unless ($CPAN::META->has_usable("LWP")) {
1839           $CPAN::Frontend->mydie("LWP not installed; cannot continue");
1840       }
1841       CPAN::LWP::UserAgent->config;
1842       my $Ua;
1843       eval { $Ua = CPAN::LWP::UserAgent->new; };
1844       if ($@) {
1845           $CPAN::Frontend->mydie("CPAN::LWP::UserAgent->new dies with $@\n");
1846       }
1847       my $resp = $Ua->get($url);
1848       unless ($resp->is_success) {
1849           $CPAN::Frontend->mydie(sprintf "Could not download '%s': %s\n", $url, $resp->code);
1850       }
1851       $CPAN::Frontend->myprint("DONE\n\n");
1852       my $xml = XML::LibXML->new->parse_string($resp->content);
1853       if (0) {
1854           my $s = $xml->serialize(2);
1855           $s =~ s/\n\s*\n/\n/g;
1856           $CPAN::Frontend->myprint($s);
1857           return;
1858       }
1859       my @distros;
1860       if ($url =~ /winnipeg/) {
1861           my $pubdate = $xml->findvalue("/rss/channel/pubDate");
1862           $CPAN::Frontend->myprint("    pubDate: $pubdate\n\n");
1863           for my $eitem ($xml->findnodes("/rss/channel/item")) {
1864               my $distro = $eitem->findvalue("enclosure/\@url");
1865               $distro =~ s|.*?/authors/id/./../||;
1866               my $size   = $eitem->findvalue("enclosure/\@length");
1867               my $desc   = $eitem->findvalue("description");
1868               $desc =~ s/.+? - //;
1869               $CPAN::Frontend->myprint("$distro [$size b]\n    $desc\n");
1870               push @distros, $distro;
1871           }
1872       } elsif ($url =~ /search.*uploads.rdf/) {
1873           # xmlns:rdf="http://www.w3.org/1999/02/22-rdf-syntax-ns#"
1874           # xmlns="http://purl.org/rss/1.0/"
1875           # xmlns:taxo="http://purl.org/rss/1.0/modules/taxonomy/"
1876           # xmlns:dc="http://purl.org/dc/elements/1.1/"
1877           # xmlns:syn="http://purl.org/rss/1.0/modules/syndication/"
1878           # xmlns:admin="http://webns.net/mvcb/"
1879
1880
1881           my $dc_date = $xml->findvalue("//*[local-name(.) = 'RDF']/*[local-name(.) = 'channel']/*[local-name(.) = 'date']");
1882           $CPAN::Frontend->myprint("    dc:date: $dc_date\n\n");
1883           my $finish_eitem = 0;
1884           local $SIG{INT} = sub { $finish_eitem = 1 };
1885         EITEM: for my $eitem ($xml->findnodes("//*[local-name(.) = 'RDF']/*[local-name(.) = 'item']")) {
1886               my $distro = $eitem->findvalue("\@rdf:about");
1887               $distro =~ s|.*~||; # remove up to the tilde before the name
1888               $distro =~ s|/$||; # remove trailing slash
1889               $distro =~ s|([^/]+)|\U$1\E|; # upcase the name
1890               my $author = uc $1 or die "distro[$distro] without author, cannot continue";
1891               my $desc   = $eitem->findvalue("*[local-name(.) = 'description']");
1892               my $i = 0;
1893             SUBDIRTEST: while () {
1894                   last SUBDIRTEST if ++$i >= 6; # half a dozen must do!
1895                   if (my @ret = $self->globls("$distro*")) {
1896                       @ret = grep {$_->[2] !~ /meta/} @ret;
1897                       @ret = grep {length $_->[2]} @ret;
1898                       if (@ret) {
1899                           $distro = "$author/$ret[0][2]";
1900                           last SUBDIRTEST;
1901                       }
1902                   }
1903                   $distro =~ s|/|/*/|; # allow it to reside in a subdirectory
1904               }
1905
1906               next EITEM if $distro =~ m|\*|; # did not find the thing
1907               $CPAN::Frontend->myprint("____$desc\n");
1908               push @distros, $distro;
1909               last EITEM if $finish_eitem;
1910           }
1911       }
1912       return \@distros;
1913   } else {
1914       # deprecated old version
1915       $CPAN::Frontend->mydie("no XML::LibXML installed, cannot continue\n");
1916   }
1917 }
1918
1919 #-> sub CPAN::Shell::smoke ;
1920 sub smoke {
1921     my($self) = @_;
1922     my $distros = $self->recent;
1923   DISTRO: for my $distro (@$distros) {
1924         next if $distro =~ m|/Bundle-|; # XXX crude heuristic to skip bundles
1925         $CPAN::Frontend->myprint(sprintf "Going to download and test '$distro'\n");
1926         {
1927             my $skip = 0;
1928             local $SIG{INT} = sub { $skip = 1 };
1929             for (0..9) {
1930                 $CPAN::Frontend->myprint(sprintf "\r%2d (Hit ^C to skip)", 10-$_);
1931                 sleep 1;
1932                 if ($skip) {
1933                     $CPAN::Frontend->myprint(" skipped\n");
1934                     next DISTRO;
1935                 }
1936             }
1937         }
1938         $CPAN::Frontend->myprint("\r  \n"); # leave the dirty line with a newline
1939         $self->test($distro);
1940     }
1941 }
1942
1943 {
1944     # set up the dispatching methods
1945     no strict "refs";
1946     for my $command (qw(
1947                         clean
1948                         cvs_import
1949                         dump
1950                         force
1951                         fforce
1952                         get
1953                         install
1954                         look
1955                         ls
1956                         make
1957                         notest
1958                         perldoc
1959                         readme
1960                         reports
1961                         test
1962                        )) {
1963         *$command = sub { shift->rematein($command, @_); };
1964     }
1965 }
1966
1967 1;