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