File Manager

Editing File: /usr/share/perl5/CPAN/Shell.pm

package CPAN::Shell;
use strict;

# -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*-
# vim: ts=4 sts=4 sw=4:

use vars qw(
            $ADVANCED_QUERY
            $AUTOLOAD
            $COLOR_REGISTERED
            $Help
            $autoload_recursion
            $reload
            @ISA
            @relo
            $VERSION
           );
@relo =     (
             "CPAN.pm",
             "CPAN/Author.pm",
             "CPAN/CacheMgr.pm",
             "CPAN/Complete.pm",
             "CPAN/Debug.pm",
             "CPAN/DeferredCode.pm",
             "CPAN/Distribution.pm",
             "CPAN/Distroprefs.pm",
             "CPAN/Distrostatus.pm",
             "CPAN/Exception/RecursiveDependency.pm",
             "CPAN/Exception/yaml_not_installed.pm",
             "CPAN/FirstTime.pm",
             "CPAN/FTP.pm",
             "CPAN/FTP/netrc.pm",
             "CPAN/HandleConfig.pm",
             "CPAN/Index.pm",
             "CPAN/InfoObj.pm",
             "CPAN/Kwalify.pm",
             "CPAN/LWP/UserAgent.pm",
             "CPAN/Module.pm",
             "CPAN/Prompt.pm",
             "CPAN/Queue.pm",
             "CPAN/Reporter/Config.pm",
             "CPAN/Reporter/History.pm",
             "CPAN/Reporter/PrereqCheck.pm",
             "CPAN/Reporter.pm",
             "CPAN/Shell.pm",
             "CPAN/SQLite.pm",
             "CPAN/Tarzip.pm",
             "CPAN/Version.pm",
            );
$VERSION = "5.5002";
# record the initial timestamp for reload.
$reload = { map {$INC{$_} ? ($_,(stat $INC{$_})[9]) : ()} @relo };
@CPAN::Shell::ISA = qw(CPAN::Debug);
use Cwd qw(chdir);
use Carp ();
$COLOR_REGISTERED ||= 0;
$Help = {
         '?' => \"help",
         '!' => "eval the rest of the line as perl",
         a => "whois author",
         autobundle => "write inventory into a bundle file",
         b => "info about bundle",
         bye => \"quit",
         clean => "clean up a distribution's build directory",
         # cvs_import
         d => "info about a distribution",
         # dump
         exit => \"quit",
         failed => "list all failed actions within current session",
         fforce => "redo a command from scratch",
         force => "redo a command",
         get => "download a distribution",
         h => \"help",
         help => "overview over commands; 'help ...' explains specific commands",
         hosts => "statistics about recently used hosts",
         i => "info about authors/bundles/distributions/modules",
         install => "install a distribution",
         install_tested => "install all distributions tested OK",
         is_tested => "list all distributions tested OK",
         look => "open a subshell in a distribution's directory",
         ls => "list distributions matching a fileglob",
         m => "info about a module",
         make => "make/build a distribution",
         mkmyconfig => "write current config into a CPAN/MyConfig.pm file",
         notest => "run a (usually install) command but leave out the test phase",
         o => "'o conf ...' for config stuff; 'o debug ...' for debugging",
         perldoc => "try to get a manpage for a module",
         q => \"quit",
         quit => "leave the cpan shell",
         r => "review upgradable modules",
         readme => "display the README of a distro with a pager",
         recent => "show recent uploads to the CPAN",
         # recompile
         reload => "'reload cpan' or 'reload index'",
         report => "test a distribution and send a test report to cpantesters",
         reports => "info about reported tests from cpantesters",
         # scripts
         # smoke
         test => "test a distribution",
         u => "display uninstalled modules",
         upgrade => "combine 'r' command with immediate installation",
        };
{
    $autoload_recursion   ||= 0;

#-> sub CPAN::Shell::AUTOLOAD ;
    sub AUTOLOAD { ## no critic
        $autoload_recursion++;
        my($l) = $AUTOLOAD;
        my $class = shift(@_);
        # warn "autoload[$l] class[$class]";
        $l =~ s/.*:://;
        if ($CPAN::Signal) {
            warn "Refusing to autoload '$l' while signal pending";
            $autoload_recursion--;
            return;
        }
        if ($autoload_recursion > 1) {
            my $fullcommand = join " ", map { "'$_'" } $l, @_;
            warn "Refusing to autoload $fullcommand in recursion\n";
            $autoload_recursion--;
            return;
        }
        if ($l =~ /^w/) {
            # XXX needs to be reconsidered
            if ($CPAN::META->has_inst('CPAN::WAIT')) {
                CPAN::WAIT->$l(@_);
            } else {
                $CPAN::Frontend->mywarn(qq{
Commands starting with "w" require CPAN::WAIT to be installed.
Please consider installing CPAN::WAIT to use the fulltext index.
For this you just need to type
    install CPAN::WAIT
});
            }
        } else {
            $CPAN::Frontend->mywarn(qq{Unknown shell command '$l'. }.
                                    qq{Type ? for help.
});
        }
        $autoload_recursion--;
    }
}

#-> sub CPAN::Shell::h ;
sub h {
    my($class,$about) = @_;
    if (defined $about) {
        my $help;
        if (exists $Help->{$about}) {
            if (ref $Help->{$about}) { # aliases
                $about = ${$Help->{$about}};
            }
            $help = $Help->{$about};
        } else {
            $help = "No help available";
        }
        $CPAN::Frontend->myprint("$about\: $help\n");
    } else {
        my $filler = " " x (80 - 28 - length($CPAN::VERSION));
        $CPAN::Frontend->myprint(qq{
Display Information $filler (ver $CPAN::VERSION)
 command  argument          description
 a,b,d,m  WORD or /REGEXP/  about authors, bundles, distributions, modules
 i        WORD or /REGEXP/  about any of the above
 ls       AUTHOR or GLOB    about files in the author's directory
    (with WORD being a module, bundle or author name or a distribution
    name of the form AUTHOR/DISTRIBUTION)

Download, Test, Make, Install...
 get      download                     clean    make clean
 make     make (implies get)           look     open subshell in dist directory
 test     make test (implies make)     readme   display these README files
 install  make install (implies test)  perldoc  display POD documentation

Upgrade
 r        WORDs or /REGEXP/ or NONE    report updates for some/matching/all modules
 upgrade  WORDs or /REGEXP/ or NONE    upgrade some/matching/all modules

Pragmas
 force  CMD    try hard to do command  fforce CMD    try harder
 notest CMD    skip testing

Other
 h,?           display this menu       ! perl-code   eval a perl command
 o conf [opt]  set and query options   q             quit the cpan shell
 reload cpan   load CPAN.pm again      reload index  load newer indices
 autobundle    Snapshot                recent        latest CPAN uploads});
}
}

*help = \&h;

#-> sub CPAN::Shell::a ;
sub a {
  my($self,@arg) = @_;
  # authors are always UPPERCASE
  for (@arg) {
    $_ = uc $_ unless /=/;
  }
  $CPAN::Frontend->myprint($self->format_result('Author',@arg));
}

#-> sub CPAN::Shell::globls ;
sub globls {
    my($self,$s,$pragmas) = @_;
    # ls is really very different, but we had it once as an ordinary
    # command in the Shell (upto rev. 321) and we could not handle
    # force well then
    my(@accept,@preexpand);
    if ($s =~ /[\*\?\/]/) {
        if ($CPAN::META->has_inst("Text::Glob")) {
            if (my($au,$pathglob) = $s =~ m|(.*?)/(.*)|) {
                my $rau = Text::Glob::glob_to_regex(uc $au);
                CPAN::Shell->debug("au[$au]pathglob[$pathglob]rau[$rau]")
                      if $CPAN::DEBUG;
                push @preexpand, map { $_->id . "/" . $pathglob }
                    CPAN::Shell->expand_by_method('CPAN::Author',['id'],"/$rau/");
            } else {
                my $rau = Text::Glob::glob_to_regex(uc $s);
                push @preexpand, map { $_->id }
                    CPAN::Shell->expand_by_method('CPAN::Author',
                                                  ['id'],
                                                  "/$rau/");
            }
        } else {
            $CPAN::Frontend->mydie("Text::Glob not installed, cannot proceed");
        }
    } else {
        push @preexpand, uc $s;
    }
    for (@preexpand) {
        unless (/^[A-Z0-9\-]+(\/|$)/i) {
            $CPAN::Frontend->mywarn("ls command rejects argument $_: not an author\n");
            next;
        }
        push @accept, $_;
    }
    my $silent = @accept>1;
    my $last_alpha = "";
    my @results;
    for my $a (@accept) {
        my($author,$pathglob);
        if ($a =~ m|(.*?)/(.*)|) {
            my $a2 = $1;
            $pathglob = $2;
            $author = CPAN::Shell->expand_by_method('CPAN::Author',
                                                    ['id'],
                                                    $a2)
                or $CPAN::Frontend->mydie("No author found for $a2\n");
        } else {
            $author = CPAN::Shell->expand_by_method('CPAN::Author',
                                                    ['id'],
                                                    $a)
                or $CPAN::Frontend->mydie("No author found for $a\n");
        }
        if ($silent) {
            my $alpha = substr $author->id, 0, 1;
            my $ad;
            if ($alpha eq $last_alpha) {
                $ad = "";
            } else {
                $ad = "[$alpha]";
                $last_alpha = $alpha;
            }
            $CPAN::Frontend->myprint($ad);
        }
        for my $pragma (@$pragmas) {
            if ($author->can($pragma)) {
                $author->$pragma();
            }
        }
        CPAN->debug("author[$author]pathglob[$pathglob]silent[$silent]") if $CPAN::DEBUG;
        push @results, $author->ls($pathglob,$silent); # silent if
                                                       # more than one
                                                       # author
        for my $pragma (@$pragmas) {
            my $unpragma = "un$pragma";
            if ($author->can($unpragma)) {
                $author->$unpragma();
            }
        }
    }
    @results;
}

#-> sub CPAN::Shell::local_bundles ;
sub local_bundles {
    my($self,@which) = @_;
    my($incdir,$bdir,$dh);
    foreach $incdir ($CPAN::Config->{'cpan_home'},@INC) {
        my @bbase = "Bundle";
        while (my $bbase = shift @bbase) {
            $bdir = File::Spec->catdir($incdir,split /::/, $bbase);
            CPAN->debug("bdir[$bdir]\@bbase[@bbase]") if $CPAN::DEBUG;
            if ($dh = DirHandle->new($bdir)) { # may fail
                my($entry);
                for $entry ($dh->read) {
                    next if $entry =~ /^\./;
                    next unless $entry =~ /^\w+(\.pm)?(?!\n)\Z/;
                    if (-d File::Spec->catdir($bdir,$entry)) {
                        push @bbase, "$bbase\::$entry";
                    } else {
                        next unless $entry =~ s/\.pm(?!\n)\Z//;
                        $CPAN::META->instance('CPAN::Bundle',"$bbase\::$entry");
                    }
                }
            }
        }
    }
}

#-> sub CPAN::Shell::b ;
sub b {
    my($self,@which) = @_;
    CPAN->debug("which[@which]") if $CPAN::DEBUG;
    $self->local_bundles;
    $CPAN::Frontend->myprint($self->format_result('Bundle',@which));
}

#-> sub CPAN::Shell::d ;
sub d { $CPAN::Frontend->myprint(shift->format_result('Distribution',@_));}

#-> sub CPAN::Shell::m ;
sub m { # emacs confused here }; sub mimimimimi { # emacs in sync here
    my $self = shift;
    my @m = @_;
    for (@m) {
        if (m|(?:\w+/)*\w+\.pm$|) { # same regexp in expandany
            s/.pm$//;
            s|/|::|g;
        }
    }
    $CPAN::Frontend->myprint($self->format_result('Module',@m));
}

#-> sub CPAN::Shell::i ;
sub i {
    my($self) = shift;
    my(@args) = @_;
    @args = '/./' unless @args;
    my(@result);
    for my $type (qw/Bundle Distribution Module/) {
        push @result, $self->expand($type,@args);
    }
    # Authors are always uppercase.
    push @result, $self->expand("Author", map { uc $_ } @args);

my $result = @result == 1 ?
        $result[0]->as_string :
            @result == 0 ?
                "No objects found of any type for argument @args\n" :
                    join("",
                         (map {$_->as_glimpse} @result),
                         scalar @result, " items found\n",
                        );
    $CPAN::Frontend->myprint($result);
}

#-> sub CPAN::Shell::o ;

# CPAN::Shell::o and CPAN::HandleConfig::edit are closely related. 'o
# conf' calls through to CPAN::HandleConfig::edit. 'o conf' should
# probably have been called 'set' and 'o debug' maybe 'set debug' or
# 'debug'; 'o conf ARGS' calls ->edit in CPAN/HandleConfig.pm
sub o {
    my($self,$o_type,@o_what) = @_;
    $o_type ||= "";
    CPAN->debug("o_type[$o_type] o_what[".join(" | ",@o_what)."]\n");
    if ($o_type eq 'conf') {
        my($cfilter);
        ($cfilter) = $o_what[0] =~ m|^/(.*)/$| if @o_what;
        if (!@o_what or $cfilter) { # print all things, "o conf"
            $cfilter ||= "";
            my $qrfilter = eval 'qr/$cfilter/';
            my($k,$v);
            my $configpm = CPAN::HandleConfig->require_myconfig_or_config;
            $CPAN::Frontend->myprint("\$CPAN::Config options from $configpm\:\n");
            for $k (sort keys %CPAN::HandleConfig::can) {
                next unless $k =~ /$qrfilter/;
                $v = $CPAN::HandleConfig::can{$k};
                $CPAN::Frontend->myprint(sprintf "    %-18s [%s]\n", $k, $v);
            }
            $CPAN::Frontend->myprint("\n");
            for $k (sort keys %CPAN::HandleConfig::keys) {
                next unless $k =~ /$qrfilter/;
                CPAN::HandleConfig->prettyprint($k);
            }
            $CPAN::Frontend->myprint("\n");
        } else {
            if (CPAN::HandleConfig->edit(@o_what)) {
            } else {
                $CPAN::Frontend->myprint(qq{Type 'o conf' to view all configuration }.
                                         qq{items\n\n});
            }
        }
    } elsif ($o_type eq 'debug') {
        my(%valid);
        @o_what = () if defined $o_what[0] && $o_what[0] =~ /help/i;
        if (@o_what) {
            while (@o_what) {
                my($what) = shift @o_what;
                if ($what =~ s/^-// && exists $CPAN::DEBUG{$what}) {
                    $CPAN::DEBUG &= $CPAN::DEBUG ^ $CPAN::DEBUG{$what};
                    next;
                }
                if ( exists $CPAN::DEBUG{$what} ) {
                    $CPAN::DEBUG |= $CPAN::DEBUG{$what};
                } elsif ($what =~ /^\d/) {
                    $CPAN::DEBUG = $what;
                } elsif (lc $what eq 'all') {
                    my($max) = 0;
                    for (values %CPAN::DEBUG) {
                        $max += $_;
                    }
                    $CPAN::DEBUG = $max;
                } else {
                    my($known) = 0;
                    for (keys %CPAN::DEBUG) {
                        next unless lc($_) eq lc($what);
                        $CPAN::DEBUG |= $CPAN::DEBUG{$_};
                        $known = 1;
                    }
                    $CPAN::Frontend->myprint("unknown argument [$what]\n")
                        unless $known;
                }
            }
        } else {
            my $raw = "Valid options for debug are ".
                join(", ",sort(keys %CPAN::DEBUG), 'all').
                     qq{ or a number. Completion works on the options. }.
                     qq{Case is ignored.};
            require Text::Wrap;
            $CPAN::Frontend->myprint(Text::Wrap::fill("","",$raw));
            $CPAN::Frontend->myprint("\n\n");
        }
        if ($CPAN::DEBUG) {
            $CPAN::Frontend->myprint("Options set for debugging ($CPAN::DEBUG):\n");
            my($k,$v);
            for $k (sort {$CPAN::DEBUG{$a} <=> $CPAN::DEBUG{$b}} keys %CPAN::DEBUG) {
                $v = $CPAN::DEBUG{$k};
                $CPAN::Frontend->myprint(sprintf "    %-14s(%s)\n", $k, $v)
                    if $v & $CPAN::DEBUG;
            }
        } else {
            $CPAN::Frontend->myprint("Debugging turned off completely.\n");
        }
    } else {
        $CPAN::Frontend->myprint(qq{
Known options:
  conf    set or get configuration variables
  debug   set or get debugging options
});
    }
}

# CPAN::Shell::paintdots_onreload
sub paintdots_onreload {
    my($ref) = shift;
    sub {
        if ( $_[0] =~ /[Ss]ubroutine ([\w:]+) redefined/ ) {
            my($subr) = $1;
            ++$$ref;
            local($|) = 1;
            # $CPAN::Frontend->myprint(".($subr)");
            $CPAN::Frontend->myprint(".");
            if ($subr =~ /\bshell\b/i) {
                # warn "debug[$_[0]]";

# It would be nice if we could detect that a
                # subroutine has actually changed, but for now we
                # practically always set the GOTOSHELL global

$CPAN::GOTOSHELL=1;
            }
            return;
        }
        warn @_;
    };
}

#-> sub CPAN::Shell::hosts ;
sub hosts {
    my($self) = @_;
    my $fullstats = CPAN::FTP->_ftp_statistics();
    my $history = $fullstats->{history} || [];
    my %S; # statistics
    while (my $last = pop @$history) {
        my $attempts = $last->{attempts} or next;
        my $start;
        if (@$attempts) {
            $start = $attempts->[-1]{start};
            if ($#$attempts > 0) {
                for my $i (0..$#$attempts-1) {
                    my $url = $attempts->[$i]{url} or next;
                    $S{no}{$url}++;
                }
            }
        } else {
            $start = $last->{start};
        }
        next unless $last->{thesiteurl}; # C-C? bad filenames?
        $S{start} = $start;
        $S{end} ||= $last->{end};
        my $dltime = $last->{end} - $start;
        my $dlsize = $last->{filesize} || 0;
        my $url = ref $last->{thesiteurl} ? $last->{thesiteurl}->text : $last->{thesiteurl};
        my $s = $S{ok}{$url} ||= {};
        $s->{n}++;
        $s->{dlsize} ||= 0;
        $s->{dlsize} += $dlsize/1024;
        $s->{dltime} ||= 0;
        $s->{dltime} += $dltime;
    }
    my $res;
    for my $url (keys %{$S{ok}}) {
        next if $S{ok}{$url}{dltime} == 0; # div by zero
        push @{$res->{ok}}, [@{$S{ok}{$url}}{qw(n dlsize dltime)},
                             $S{ok}{$url}{dlsize}/$S{ok}{$url}{dltime},
                             $url,
                            ];
    }
    for my $url (keys %{$S{no}}) {
        push @{$res->{no}}, [$S{no}{$url},
                             $url,
                            ];
    }
    my $R = ""; # report
    if ($S{start} && $S{end}) {
        $R .= sprintf "Log starts: %s\n", $S{start} ? scalar(localtime $S{start}) : "unknown";
        $R .= sprintf "Log ends  : %s\n", $S{end}   ? scalar(localtime $S{end})   : "unknown";
    }
    if ($res->{ok} && @{$res->{ok}}) {
        $R .= sprintf "\nSuccessful downloads:
   N       kB  secs      kB/s url\n";
        my $i = 20;
        for (sort { $b->[3] <=> $a->[3] } @{$res->{ok}}) {
            $R .= sprintf "%4d %8d %5d %9.1f %s\n", @$_;
            last if --$i<=0;
        }
    }
    if ($res->{no} && @{$res->{no}}) {
        $R .= sprintf "\nUnsuccessful downloads:\n";
        my $i = 20;
        for (sort { $b->[0] <=> $a->[0] } @{$res->{no}}) {
            $R .= sprintf "%4d %s\n", @$_;
            last if --$i<=0;
        }
    }
    $CPAN::Frontend->myprint($R);
}

# here is where 'reload cpan' is done
#-> sub CPAN::Shell::reload ;
sub reload {
    my($self,$command,@arg) = @_;
    $command ||= "";
    $self->debug("self[$self]command[$command]arg[@arg]") if $CPAN::DEBUG;
    if ($command =~ /^cpan$/i) {
        my $redef = 0;
        chdir $CPAN::iCwd if $CPAN::iCwd; # may fail
        my $failed;
      MFILE: for my $f (@relo) {
            next unless exists $INC{$f};
            my $p = $f;
            $p =~ s/\.pm$//;
            $p =~ s|/|::|g;
            $CPAN::Frontend->myprint("($p");
            local($SIG{__WARN__}) = paintdots_onreload(\$redef);
            $self->_reload_this($f) or $failed++;
            my $v = eval "$p\::->VERSION";
            $CPAN::Frontend->myprint("v$v)");
        }
        $CPAN::Frontend->myprint("\n$redef subroutines redefined\n");
        if ($failed) {
            my $errors = $failed == 1 ? "error" : "errors";
            $CPAN::Frontend->mywarn("\n$failed $errors during reload. You better quit ".
                                    "this session.\n");
        }
    } elsif ($command =~ /^index$/i) {
      CPAN::Index->force_reload;
    } else {
      $CPAN::Frontend->myprint(qq{cpan     re-evals the CPAN modules
index    re-reads the index files\n});
    }
}

# reload means only load again what we have loaded before
#-> sub CPAN::Shell::_reload_this ;
sub _reload_this {
    my($self,$f,$args) = @_;
    CPAN->debug("f[$f]") if $CPAN::DEBUG;
    return 1 unless $INC{$f}; # we never loaded this, so we do not
                              # reload but say OK
    my $pwd = CPAN::anycwd();
    CPAN->debug("pwd[$pwd]") if $CPAN::DEBUG;
    my($file);
    for my $inc (@INC) {
        $file = File::Spec->catfile($inc,split /\//, $f);
        last if -f $file;
        $file = "";
    }
    CPAN->debug("file[$file]") if $CPAN::DEBUG;
    my @inc = @INC;
    unless ($file && -f $file) {
        # this thingie is not in the INC path, maybe CPAN/MyConfig.pm?
        $file = $INC{$f};
        unless (CPAN->has_inst("File::Basename")) {
            @inc = File::Basename::dirname($file);
        } else {
            # do we ever need this?
            @inc = substr($file,0,-length($f)-1); # bring in back to me!
        }
    }
    CPAN->debug("file[$file]inc[@inc]") if $CPAN::DEBUG;
    unless (-f $file) {
        $CPAN::Frontend->mywarn("Found no file to reload for '$f'\n");
        return;
    }
    my $mtime = (stat $file)[9];
    $reload->{$f} ||= -1;
    my $must_reload = $mtime != $reload->{$f};
    $args ||= {};
    $must_reload ||= $args->{reloforce}; # o conf defaults needs this
    if ($must_reload) {
        my $fh = FileHandle->new($file) or
            $CPAN::Frontend->mydie("Could not open $file: $!");
        local($/);
        local $^W = 1;
        my $content = <$fh>;
        CPAN->debug(sprintf("reload file[%s] content[%s...]",$file,substr($content,0,128)))
            if $CPAN::DEBUG;
        delete $INC{$f};
        local @INC = @inc;
        eval "require '$f'";
        if ($@) {
            warn $@;
            return;
        }
        $reload->{$f} = $mtime;
    } else {
        $CPAN::Frontend->myprint("__unchanged__");
    }
    return 1;
}

#-> sub CPAN::Shell::mkmyconfig ;
sub mkmyconfig {
    my($self) = @_;
    if ( my $configpm = $INC{'CPAN/MyConfig.pm'} ) {
        $CPAN::Frontend->myprint(
            "CPAN::MyConfig already exists as $configpm.\n" .
            "Running configuration again...\n"
        );
        require CPAN::FirstTime;
        CPAN::FirstTime::init($configpm);
    }
    else {
        # force some missing values to be filled in with defaults
        delete $CPAN::Config->{$_}
            for qw/build_dir cpan_home keep_source_where histfile/;
        CPAN::HandleConfig->load( make_myconfig => 1 );
    }
}

#-> sub CPAN::Shell::_binary_extensions ;
sub _binary_extensions {
    my($self) = shift @_;
    my(@result,$module,%seen,%need,$headerdone);
    for $module ($self->expand('Module','/./')) {
        my $file  = $module->cpan_file;
        next if $file eq "N/A";
        next if $file =~ /^Contact Author/;
        my $dist = $CPAN::META->instance('CPAN::Distribution',$file);
        next if $dist->isa_perl;
        next unless $module->xs_file;
        local($|) = 1;
        $CPAN::Frontend->myprint(".");
        push @result, $module;
    }
#    print join " | ", @result;
    $CPAN::Frontend->myprint("\n");
    return @result;
}

#-> sub CPAN::Shell::recompile ;
sub recompile {
    my($self) = shift @_;
    my($module,@module,$cpan_file,%dist);
    @module = $self->_binary_extensions();
    for $module (@module) { # we force now and compile later, so we
                            # don't do it twice
        $cpan_file = $module->cpan_file;
        my $pack = $CPAN::META->instance('CPAN::Distribution',$cpan_file);
        $pack->force;
        $dist{$cpan_file}++;
    }
    for $cpan_file (sort keys %dist) {
        $CPAN::Frontend->myprint("  CPAN: Recompiling $cpan_file\n\n");
        my $pack = $CPAN::META->instance('CPAN::Distribution',$cpan_file);
        $pack->install;
        $CPAN::Signal = 0; # it's tempting to reset Signal, so we can
                           # stop a package from recompiling,
                           # e.g. IO-1.12 when we have perl5.003_10
    }
}

#-> sub CPAN::Shell::scripts ;
sub scripts {
    my($self, $arg) = @_;
    $CPAN::Frontend->mywarn(">>>> experimental command, currently unsupported <<<<\n\n");

for my $req (qw( HTML::LinkExtor Sort::Versions List::Util )) {
        unless ($CPAN::META->has_inst($req)) {
            $CPAN::Frontend->mywarn("  $req not available\n");
        }
    }
    my $p = HTML::LinkExtor->new();
    my $indexfile = "/home/ftp/pub/PAUSE/scripts/new/index.html";
    unless (-f $indexfile) {
        $CPAN::Frontend->mydie("found no indexfile[$indexfile]\n");
    }
    $p->parse_file($indexfile);
    my @hrefs;
    my $qrarg;
    if ($arg =~ s|^/(.+)/$|$1|) {
        $qrarg = eval 'qr/$arg/'; # hide construct from 5.004
    }
    for my $l ($p->links) {
        my $tag = shift @$l;
        next unless $tag eq "a";
        my %att = @$l;
        my $href = $att{href};
        next unless $href =~ s|^\.\./authors/id/./../||;
        if ($arg) {
            if ($qrarg) {
                if ($href =~ $qrarg) {
                    push @hrefs, $href;
                }
            } else {
                if ($href =~ /\Q$arg\E/) {
                    push @hrefs, $href;
                }
            }
        } else {
            push @hrefs, $href;
        }
    }
    # now filter for the latest version if there is more than one of a name
    my %stems;
    for (sort @hrefs) {
        my $href = $_;
        s/-v?\d.*//;
        my $stem = $_;
        $stems{$stem} ||= [];
        push @{$stems{$stem}}, $href;
    }
    for (sort keys %stems) {
        my $highest;
        if (@{$stems{$_}} > 1) {
            $highest = List::Util::reduce {
                Sort::Versions::versioncmp($a,$b) > 0 ? $a : $b
              } @{$stems{$_}};
        } else {
            $highest = $stems{$_}[0];
        }
        $CPAN::Frontend->myprint("$highest\n");
    }
}

#-> sub CPAN::Shell::report ;
sub report {
    my($self,@args) = @_;
    unless ($CPAN::META->has_inst("CPAN::Reporter")) {
        $CPAN::Frontend->mydie("CPAN::Reporter not installed; cannot continue");
    }
    local $CPAN::Config->{test_report} = 1;
    $self->force("test",@args); # force is there so that the test be
                                # re-run (as documented)
}

# compare with is_tested
#-> sub CPAN::Shell::install_tested
sub install_tested {
    my($self,@some) = @_;
    $CPAN::Frontend->mywarn("install_tested() must not be called with arguments.\n"),
        return if @some;
    CPAN::Index->reload;

for my $b (reverse $CPAN::META->_list_sorted_descending_is_tested) {
        my $yaml = "$b.yml";
        unless (-f $yaml) {
            $CPAN::Frontend->mywarn("No YAML file for $b available, skipping\n");
            next;
        }
        my $yaml_content = CPAN->_yaml_loadfile($yaml);
        my $id = $yaml_content->[0]{distribution}{ID};
        unless ($id) {
            $CPAN::Frontend->mywarn("No ID found in '$yaml', skipping\n");
            next;
        }
        my $do = CPAN::Shell->expandany($id);
        unless ($do) {
            $CPAN::Frontend->mywarn("Could not expand ID '$id', skipping\n");
            next;
        }
        unless ($do->{build_dir}) {
            $CPAN::Frontend->mywarn("Distro '$id' has no build_dir, skipping\n");
            next;
        }
        unless ($do->{build_dir} eq $b) {
            $CPAN::Frontend->mywarn("Distro '$id' has build_dir '$do->{build_dir}' but expected '$b', skipping\n");
            next;
        }
        push @some, $do;
    }

$CPAN::Frontend->mywarn("No tested distributions found.\n"),
        return unless @some;

@some = grep { $_->{make_test} && ! $_->{make_test}->failed } @some;
    $CPAN::Frontend->mywarn("No distributions tested with this build of perl found.\n"),
        return unless @some;

# @some = grep { not $_->uptodate } @some;
    # $CPAN::Frontend->mywarn("No non-uptodate distributions tested with this build of perl found.\n"),
    #     return unless @some;

CPAN->debug("some[@some]");
    for my $d (@some) {
        my $id = $d->can("pretty_id") ? $d->pretty_id : $d->id;
        $CPAN::Frontend->myprint("install_tested: Running for $id\n");
        $CPAN::Frontend->mysleep(1);
        $self->install($d);
    }
}

#-> sub CPAN::Shell::upgrade ;
sub upgrade {
    my($self,@args) = @_;
    $self->install($self->r(@args));
}

#-> sub CPAN::Shell::_u_r_common ;
sub _u_r_common {
    my($self) = shift @_;
    my($what) = shift @_;
    CPAN->debug("self[$self] what[$what] args[@_]") if $CPAN::DEBUG;
    Carp::croak "Usage: \$obj->_u_r_common(a|r|u)" unless
          $what && $what =~ /^[aru]$/;
    my(@args) = @_;
    @args = '/./' unless @args;
    my(@result,$module,%seen,%need,$headerdone,
       $version_undefs,$version_zeroes,
       @version_undefs,@version_zeroes);
    $version_undefs = $version_zeroes = 0;
    my $sprintf = "%s%-25s%s %9s %9s  %s\n";
    my @expand = $self->expand('Module',@args);
    if ($CPAN::DEBUG) { # Looks like noise to me, was very useful for debugging
             # for metadata cache
        my $expand = scalar @expand;
        $CPAN::Frontend->myprint(sprintf "%d matches in the database, time[%d]\n", $expand, time);
    }
    my @sexpand;
    if ($] < 5.008) {
        # hard to believe that the more complex sorting can lead to
        # stack curruptions on older perl
        @sexpand = sort {$a->id cmp $b->id} @expand;
    } else {
        @sexpand = map {
            $_->[1]
        } sort {
            $b->[0] <=> $a->[0]
            ||
            $a->[1]{ID} cmp $b->[1]{ID},
        } map {
            [$_->_is_representative_module,
             $_
            ]
        } @expand;
    }
    if ($CPAN::DEBUG) {
        $CPAN::Frontend->myprint(sprintf "sorted at time[%d]\n", time);
        sleep 1;
    }
  MODULE: for $module (@sexpand) {
        my $file  = $module->cpan_file;
        next MODULE unless defined $file; # ??
        $file =~ s!^./../!!;
        my($latest) = $module->cpan_version;
        my($inst_file) = $module->inst_file;
        CPAN->debug("file[$file]latest[$latest]") if $CPAN::DEBUG;
        my($have);
        return if $CPAN::Signal;
        my($next_MODULE);
        eval { # version.pm involved!
            if ($inst_file) {
                if ($what eq "a") {
                    $have = $module->inst_version;
                } elsif ($what eq "r") {
                    $have = $module->inst_version;
                    local($^W) = 0;
                    if ($have eq "undef") {
                        $version_undefs++;
                        push @version_undefs, $module->as_glimpse;
                    } elsif (CPAN::Version->vcmp($have,0)==0) {
                        $version_zeroes++;
                        push @version_zeroes, $module->as_glimpse;
                    }
                    ++$next_MODULE unless CPAN::Version->vgt($latest, $have);
                    # to be pedantic we should probably say:
                    #    && !($have eq "undef" && $latest ne "undef" && $latest gt "");
                    # to catch the case where CPAN has a version 0 and we have a version undef
                } elsif ($what eq "u") {
                    ++$next_MODULE;
                }
            } else {
                if ($what eq "a") {
                    ++$next_MODULE;
                } elsif ($what eq "r") {
                    ++$next_MODULE;
                } elsif ($what eq "u") {
                    $have = "-";
                }
            }
        };
        next MODULE if $next_MODULE;
        if ($@) {
            $CPAN::Frontend->mywarn
                (sprintf("Error while comparing cpan/installed versions of '%s':
INST_FILE: %s
INST_VERSION: %s %s
CPAN_VERSION: %s %s
",
                         $module->id,
                         $inst_file || "",
                         (defined $have ? $have : "[UNDEFINED]"),
                         (ref $have ? ref $have : ""),
                         $latest,
                         (ref $latest ? ref $latest : ""),
                        ));
            next MODULE;
        }
        return if $CPAN::Signal; # this is sometimes lengthy
        $seen{$file} ||= 0;
        if ($what eq "a") {
            push @result, sprintf "%s %s\n", $module->id, $have;
        } elsif ($what eq "r") {
            push @result, $module->id;
            next MODULE if $seen{$file}++;
        } elsif ($what eq "u") {
            push @result, $module->id;
            next MODULE if $seen{$file}++;
            next MODULE if $file =~ /^Contact/;
        }
        unless ($headerdone++) {
            $CPAN::Frontend->myprint("\n");
            $CPAN::Frontend->myprint(sprintf(
                                             $sprintf,
                                             "",
                                             "Package namespace",
                                             "",
                                             "installed",
                                             "latest",
                                             "in CPAN file"
                                            ));
        }
        my $color_on = "";
        my $color_off = "";
        if (
            $COLOR_REGISTERED
            &&
            $CPAN::META->has_inst("Term::ANSIColor")
            &&
            $module->description
           ) {
            $color_on = Term::ANSIColor::color("green");
            $color_off = Term::ANSIColor::color("reset");
        }
        $CPAN::Frontend->myprint(sprintf $sprintf,
                                 $color_on,
                                 $module->id,
                                 $color_off,
                                 $have,
                                 $latest,
                                 $file);
        $need{$module->id}++;
    }
    unless (%need) {
        if ($what eq "u") {
            $CPAN::Frontend->myprint("No modules found for @args\n");
        } elsif ($what eq "r") {
            $CPAN::Frontend->myprint("All modules are up to date for @args\n");
        }
    }
    if ($what eq "r") {
        if ($version_zeroes) {
            my $s_has = $version_zeroes > 1 ? "s have" : " has";
            $CPAN::Frontend->myprint(qq{$version_zeroes installed module$s_has }.
                                     qq{a version number of 0\n});
            if ($CPAN::Config->{show_zero_versions}) {
                local $" = "\t";
                $CPAN::Frontend->myprint(qq{  they are\n\t@version_zeroes\n});
                $CPAN::Frontend->myprint(qq{(use 'o conf show_zero_versions 0' }.
                                         qq{to hide them)\n});
            } else {
                $CPAN::Frontend->myprint(qq{(use 'o conf show_zero_versions 1' }.
                                         qq{to show them)\n});
            }
        }
        if ($version_undefs) {
            my $s_has = $version_undefs > 1 ? "s have" : " has";
            $CPAN::Frontend->myprint(qq{$version_undefs installed module$s_has no }.
                                     qq{parsable version number\n});
            if ($CPAN::Config->{show_unparsable_versions}) {
                local $" = "\t";
                $CPAN::Frontend->myprint(qq{  they are\n\t@version_undefs\n});
                $CPAN::Frontend->myprint(qq{(use 'o conf show_unparsable_versions 0' }.
                                         qq{to hide them)\n});
            } else {
                $CPAN::Frontend->myprint(qq{(use 'o conf show_unparsable_versions 1' }.
                                         qq{to show them)\n});
            }
        }
    }
    @result;
}

#-> sub CPAN::Shell::r ;
sub r {
    shift->_u_r_common("r",@_);
}

#-> sub CPAN::Shell::u ;
sub u {
    shift->_u_r_common("u",@_);
}

#-> sub CPAN::Shell::failed ;
sub failed {
    my($self,$only_id,$silent) = @_;
    my @failed;
  DIST: for my $d ($CPAN::META->all_objects("CPAN::Distribution")) {
        my $failed = "";
      NAY: for my $nosayer ( # order matters!
                            "unwrapped",
                            "writemakefile",
                            "signature_verify",
                            "make",
                            "make_test",
                            "install",
                            "make_clean",
                           ) {
            next unless exists $d->{$nosayer};
            next unless defined $d->{$nosayer};
            next unless (
                         UNIVERSAL::can($d->{$nosayer},"failed") ?
                         $d->{$nosayer}->failed :
                         $d->{$nosayer} =~ /^NO/
                        );
            next NAY if $only_id && $only_id != (
                                                 UNIVERSAL::can($d->{$nosayer},"commandid")
                                                 ?
                                                 $d->{$nosayer}->commandid
                                                 :
                                                 $CPAN::CurrentCommandId
                                                );
            $failed = $nosayer;
            last;
        }
        next DIST unless $failed;
        my $id = $d->id;
        $id =~ s|^./../||;
        #$print .= sprintf(
        #                  "  %-45s: %s %s\n",
        push @failed,
            (
             UNIVERSAL::can($d->{$failed},"failed") ?
             [
              $d->{$failed}->commandid,
              $id,
              $failed,
              $d->{$failed}->text,
              $d->{$failed}{TIME}||0,
             ] :
             [
              1,
              $id,
              $failed,
              $d->{$failed},
              0,
             ]
            );
    }
    my $scope;
    if ($only_id) {
        $scope = "this command";
    } elsif ($CPAN::Index::HAVE_REANIMATED) {
        $scope = "this or a previous session";
        # it might be nice to have a section for previous session and
        # a second for this
    } else {
        $scope = "this session";
    }
    if (@failed) {
        my $print;
        my $debug = 0;
        if ($debug) {
            $print = join "",
                map { sprintf "%5d %-45s: %s %s\n", @$_ }
                    sort { $a->[0] <=> $b->[0] } @failed;
        } else {
            $print = join "",
                map { sprintf " %-45s: %s %s\n", @$_[1..3] }
                    sort {
                        $a->[0] <=> $b->[0]
                            ||
                                $a->[4] <=> $b->[4]
                       } @failed;
        }
        $CPAN::Frontend->myprint("Failed during $scope:\n$print");
    } elsif (!$only_id || !$silent) {
        $CPAN::Frontend->myprint("Nothing failed in $scope\n");
    }
}

# XXX intentionally undocumented because completely bogus, unportable,
# useless, etc.

#-> sub CPAN::Shell::status ;
sub status {
    my($self) = @_;
    require Devel::Size;
    my $ps = FileHandle->new;
    open $ps, "/proc/$$/status";
    my $vm = 0;
    while (<$ps>) {
        next unless /VmSize:\s+(\d+)/;
        $vm = $1;
        last;
    }
    $CPAN::Frontend->mywarn(sprintf(
                                    "%-27s %6d\n%-27s %6d\n",
                                    "vm",
                                    $vm,
                                    "CPAN::META",
                                    Devel::Size::total_size($CPAN::META)/1024,
                                   ));
    for my $k (sort keys %$CPAN::META) {
        next unless substr($k,0,4) eq "read";
        warn sprintf " %-26s %6d\n", $k, Devel::Size::total_size($CPAN::META->{$k})/1024;
        for my $k2 (sort keys %{$CPAN::META->{$k}}) {
            warn sprintf "  %-25s %6d (keys: %6d)\n",
                $k2,
                    Devel::Size::total_size($CPAN::META->{$k}{$k2})/1024,
                          scalar keys %{$CPAN::META->{$k}{$k2}};
        }
    }
}

# compare with install_tested
#-> sub CPAN::Shell::is_tested
sub is_tested {
    my($self) = @_;
    CPAN::Index->reload;
    for my $b (reverse $CPAN::META->_list_sorted_descending_is_tested) {
        my $time;
        if ($CPAN::META->{is_tested}{$b}) {
            $time = scalar(localtime $CPAN::META->{is_tested}{$b});
        } else {
            $time = scalar localtime;
            $time =~ s/\S/?/g;
        }
        $CPAN::Frontend->myprint(sprintf "%s %s\n", $time, $b);
    }
}

#-> sub CPAN::Shell::autobundle ;
sub autobundle {
    my($self) = shift;
    CPAN::HandleConfig->load unless $CPAN::Config_loaded++;
    my(@bundle) = $self->_u_r_common("a",@_);
    my($todir) = File::Spec->catdir($CPAN::Config->{'cpan_home'},"Bundle");
    File::Path::mkpath($todir);
    unless (-d $todir) {
        $CPAN::Frontend->myprint("Couldn't mkdir $todir for some reason\n");
        return;
    }
    my($y,$m,$d) =  (localtime)[5,4,3];
    $y+=1900;
    $m++;
    my($c) = 0;
    my($me) = sprintf "Snapshot_%04d_%02d_%02d_%02d", $y, $m, $d, $c;
    my($to) = File::Spec->catfile($todir,"$me.pm");
    while (-f $to) {
        $me = sprintf "Snapshot_%04d_%02d_%02d_%02d", $y, $m, $d, ++$c;
        $to = File::Spec->catfile($todir,"$me.pm");
    }
    my($fh) = FileHandle->new(">$to") or Carp::croak "Can't open >$to: $!";
    $fh->print(
               "package Bundle::$me;\n\n",
               "\$","VERSION = '0.01';\n\n", # hide from perl-reversion
               "1;\n\n",
               "__END__\n\n",
               "=head1 NAME\n\n",
               "Bundle::$me - Snapshot of installation on ",
               $Config::Config{'myhostname'},
               " on ",
               scalar(localtime),
               "\n\n=head1 SYNOPSIS\n\n",
               "perl -MCPAN -e 'install Bundle::$me'\n\n",
               "=head1 CONTENTS\n\n",
               join("\n", @bundle),
               "\n\n=head1 CONFIGURATION\n\n",
               Config->myconfig,
               "\n\n=head1 AUTHOR\n\n",
               "This Bundle has been generated automatically ",
               "by the autobundle routine in CPAN.pm.\n",
              );
    $fh->close;
    $CPAN::Frontend->myprint("\nWrote bundle file
    $to\n\n");
    return $to;
}

#-> sub CPAN::Shell::expandany ;
sub expandany {
    my($self,$s) = @_;
    CPAN->debug("s[$s]") if $CPAN::DEBUG;
    my $module_as_path = "";
    if ($s =~ m|(?:\w+/)*\w+\.pm$|) { # same regexp in sub m
        $module_as_path = $s;
        $module_as_path =~ s/.pm$//;
        $module_as_path =~ s|/|::|g;
    }
    if ($module_as_path) {
        if ($module_as_path =~ m|^Bundle::|) {
            $self->local_bundles;
            return $self->expand('Bundle',$module_as_path);
        } else {
            return $self->expand('Module',$module_as_path)
                if $CPAN::META->exists('CPAN::Module',$module_as_path);
        }
    } elsif ($s =~ m|/| or substr($s,-1,1) eq ".") { # looks like a file or a directory
        $s = CPAN::Distribution->normalize($s);
        return $CPAN::META->instance('CPAN::Distribution',$s);
        # Distributions spring into existence, not expand
    } elsif ($s =~ m|^Bundle::|) {
        $self->local_bundles; # scanning so late for bundles seems
                              # both attractive and crumpy: always
                              # current state but easy to forget
                              # somewhere
        return $self->expand('Bundle',$s);
    } else {
        return $self->expand('Module',$s)
            if $CPAN::META->exists('CPAN::Module',$s);
    }
    return;
}

#-> sub CPAN::Shell::expand ;
sub expand {
    my $self = shift;
    my($type,@args) = @_;
    CPAN->debug("type[$type]args[@args]") if $CPAN::DEBUG;
    my $class = "CPAN::$type";
    my $methods = ['id'];
    for my $meth (qw(name)) {
        next unless $class->can($meth);
        push @$methods, $meth;
    }
    $self->expand_by_method($class,$methods,@args);
}

#-> sub CPAN::Shell::expand_by_method ;
sub expand_by_method {
    my $self = shift;
    my($class,$methods,@args) = @_;
    my($arg,@m);
    for $arg (@args) {
        my($regex,$command);
        if ($arg =~ m|^/(.*)/$|) {
            $regex = $1;
# FIXME:  there seem to be some ='s in the author data, which trigger
#         a failure here.  This needs to be contemplated.
#            } elsif ($arg =~ m/=/) {
#                $command = 1;
        }
        my $obj;
        CPAN->debug(sprintf "class[%s]regex[%s]command[%s]",
                    $class,
                    defined $regex ? $regex : "UNDEFINED",
                    defined $command ? $command : "UNDEFINED",
                   ) if $CPAN::DEBUG;
        if (defined $regex) {
            if (CPAN::_sqlite_running()) {
                CPAN::Index->reload;
                $CPAN::SQLite->search($class, $regex);
            }
            for $obj (
                      $CPAN::META->all_objects($class)
                     ) {
                unless ($obj && UNIVERSAL::can($obj,"id") && $obj->id) {
                    # BUG, we got an empty object somewhere
                    require Data::Dumper;
                    CPAN->debug(sprintf(
                                        "Bug in CPAN: Empty id on obj[%s][%s]",
                                        $obj,
                                        Data::Dumper::Dumper($obj)
                                       )) if $CPAN::DEBUG;
                    next;
                }
                for my $method (@$methods) {
                    my $match = eval {$obj->$method() =~ /$regex/i};
                    if ($@) {
                        my($err) = $@ =~ /^(.+) at .+? line \d+\.$/;
                        $err ||= $@; # if we were too restrictive above
                        $CPAN::Frontend->mydie("$err\n");
                    } elsif ($match) {
                        push @m, $obj;
                        last;
                    }
                }
            }
        } elsif ($command) {
            die "equal sign in command disabled (immature interface), ".
                "you can set
 ! \$CPAN::Shell::ADVANCED_QUERY=1
to enable it. But please note, this is HIGHLY EXPERIMENTAL code
that may go away anytime.\n"
                    unless $ADVANCED_QUERY;
            my($method,$criterion) = $arg =~ /(.+?)=(.+)/;
            my($matchcrit) = $criterion =~ m/^~(.+)/;
            for my $self (
                          sort
                          {$a->id cmp $b->id}
                          $CPAN::META->all_objects($class)
                         ) {
                my $lhs = $self->$method() or next; # () for 5.00503
                if ($matchcrit) {
                    push @m, $self if $lhs =~ m/$matchcrit/;
                } else {
                    push @m, $self if $lhs eq $criterion;
                }
            }
        } else {
            my($xarg) = $arg;
            if ( $class eq 'CPAN::Bundle' ) {
                $xarg =~ s/^(Bundle::)?(.*)/Bundle::$2/;
            } elsif ($class eq "CPAN::Distribution") {
                $xarg = CPAN::Distribution->normalize($arg);
            } else {
                $xarg =~ s/:+/::/g;
            }
            if ($CPAN::META->exists($class,$xarg)) {
                $obj = $CPAN::META->instance($class,$xarg);
            } elsif ($CPAN::META->exists($class,$arg)) {
                $obj = $CPAN::META->instance($class,$arg);
            } else {
                next;
            }
            push @m, $obj;
        }
    }
    @m = sort {$a->id cmp $b->id} @m;
    if ( $CPAN::DEBUG ) {
        my $wantarray = wantarray;
        my $join_m = join ",", map {$_->id} @m;
        # $self->debug("wantarray[$wantarray]join_m[$join_m]");
        my $count = scalar @m;
        $self->debug("class[$class]wantarray[$wantarray]count m[$count]");
    }
    return wantarray ? @m : $m[0];
}

#-> sub CPAN::Shell::format_result ;
sub format_result {
    my($self) = shift;
    my($type,@args) = @_;
    @args = '/./' unless @args;
    my(@result) = $self->expand($type,@args);
    my $result = @result == 1 ?
        $result[0]->as_string :
            @result == 0 ?
                "No objects of type $type found for argument @args\n" :
                    join("",
                         (map {$_->as_glimpse} @result),
                         scalar @result, " items found\n",
                        );
    $result;
}

#-> sub CPAN::Shell::report_fh ;
{
    my $installation_report_fh;
    my $previously_noticed = 0;

sub report_fh {
        return $installation_report_fh if $installation_report_fh;
        if ($CPAN::META->has_usable("File::Temp")) {
            $installation_report_fh
                = File::Temp->new(
                                  dir      => File::Spec->tmpdir,
                                  template => 'cpan_install_XXXX',
                                  suffix   => '.txt',
                                  unlink   => 0,
                                 );
        }
        unless ( $installation_report_fh ) {
            warn("Couldn't open installation report file; " .
                 "no report file will be generated."
                ) unless $previously_noticed++;
        }
    }
}

# The only reason for this method is currently to have a reliable
# debugging utility that reveals which output is going through which
# channel. No, I don't like the colors ;-)

# to turn colordebugging on, write
# cpan> o conf colorize_output 1

#-> sub CPAN::Shell::colorize_output ;
{
    my $print_ornamented_have_warned = 0;
    sub colorize_output {
        my $colorize_output = $CPAN::Config->{colorize_output};
        if ($colorize_output && !$CPAN::META->has_inst("Term::ANSIColor")) {
            unless ($print_ornamented_have_warned++) {
                # no myprint/mywarn within myprint/mywarn!
                warn "Colorize_output is set to true but Term::ANSIColor is not
installed. To activate colorized output, please install Term::ANSIColor.\n\n";
            }
            $colorize_output = 0;
        }
        return $colorize_output;
    }
}

#-> sub CPAN::Shell::print_ornamented ;
sub print_ornamented {
    my($self,$what,$ornament) = @_;
    return unless defined $what;

local $| = 1; # Flush immediately
    if ( $CPAN::Be_Silent ) {
        # WARNING: variable Be_Silent is poisoned and must be eliminated.
        print {report_fh()} $what;
        return;
    }
    my $swhat = "$what"; # stringify if it is an object
    if ($CPAN::Config->{term_is_latin}) {
        # note: deprecated, need to switch to $LANG and $LC_*
        # courtesy jhi:
        $swhat
            =~ s{([\xC0-\xDF])([\x80-\xBF])}{chr(ord($1)<<6&0xC0|ord($2)&0x3F)}eg; #};
    }
    if ($self->colorize_output) {
        if ( $CPAN::DEBUG && $swhat =~ /^Debug\(/ ) {
            # if you want to have this configurable, please file a bugreport
            $ornament = $CPAN::Config->{colorize_debug} || "black on_cyan";
        }
        my $color_on = eval { Term::ANSIColor::color($ornament) } || "";
        if ($@) {
            print "Term::ANSIColor rejects color[$ornament]: $@\n
Please choose a different color (Hint: try 'o conf init /color/')\n";
        }
        # GGOLDBACH/Test-GreaterVersion-0.008 broke without this
        # $trailer construct. We want the newline be the last thing if
        # there is a newline at the end ensuring that the next line is
        # empty for other players
        my $trailer = "";
        $trailer = $1 if $swhat =~ s/([\r\n]+)\z//;
        print $color_on,
            $swhat,
                Term::ANSIColor::color("reset"),
                      $trailer;
    } else {
        print $swhat;
    }
}

#-> sub CPAN::Shell::myprint ;

# where is myprint/mywarn/Frontend/etc. documented? Where to use what?
# I think, we send everything to STDOUT and use print for normal/good
# news and warn for news that need more attention. Yes, this is our
# working contract for now.
sub myprint {
    my($self,$what) = @_;
    $self->print_ornamented($what,
                            $CPAN::Config->{colorize_print}||'bold blue on_white',
                           );
}

my %already_printed;
#-> sub CPAN::Shell::mywarnonce ;
sub myprintonce {
    my($self,$what) = @_;
    $self->myprint($what) unless $already_printed{$what}++;
}

sub optprint {
    my($self,$category,$what) = @_;
    my $vname = $category . "_verbosity";
    CPAN::HandleConfig->load unless $CPAN::Config_loaded++;
    if (!$CPAN::Config->{$vname}
        || $CPAN::Config->{$vname} =~ /^v/
       ) {
        $CPAN::Frontend->myprint($what);
    }
}

#-> sub CPAN::Shell::myexit ;
sub myexit {
    my($self,$what) = @_;
    $self->myprint($what);
    exit;
}

#-> sub CPAN::Shell::mywarn ;
sub mywarn {
    my($self,$what) = @_;
    $self->print_ornamented($what, $CPAN::Config->{colorize_warn}||'bold red on_white');
}

my %already_warned;
#-> sub CPAN::Shell::mywarnonce ;
sub mywarnonce {
    my($self,$what) = @_;
    $self->mywarn($what) unless $already_warned{$what}++;
}

# only to be used for shell commands
#-> sub CPAN::Shell::mydie ;
sub mydie {
    my($self,$what) = @_;
    $self->mywarn($what);

# If it is the shell, we want the following die to be silent,
    # but if it is not the shell, we would need a 'die $what'. We need
    # to take care that only shell commands use mydie. Is this
    # possible?

die "\n";
}

# sub CPAN::Shell::colorable_makemaker_prompt ;
sub colorable_makemaker_prompt {
    my($foo,$bar) = @_;
    if (CPAN::Shell->colorize_output) {
        my $ornament = $CPAN::Config->{colorize_print}||'bold blue on_white';
        my $color_on = eval { Term::ANSIColor::color($ornament); } || "";
        print $color_on;
    }
    my $ans = ExtUtils::MakeMaker::prompt($foo,$bar);
    if (CPAN::Shell->colorize_output) {
        print Term::ANSIColor::color('reset');
    }
    return $ans;
}

# use this only for unrecoverable errors!
#-> sub CPAN::Shell::unrecoverable_error ;
sub unrecoverable_error {
    my($self,$what) = @_;
    my @lines = split /\n/, $what;
    my $longest = 0;
    for my $l (@lines) {
        $longest = length $l if length $l > $longest;
    }
    $longest = 62 if $longest > 62;
    for my $l (@lines) {
        if ($l =~ /^\s*$/) {
            $l = "\n";
            next;
        }
        $l = "==> $l";
        if (length $l < 66) {
            $l = pack "A66 A*", $l, "<==";
        }
        $l .= "\n";
    }
    unshift @lines, "\n";
    $self->mydie(join "", @lines);
}

#-> sub CPAN::Shell::mysleep ;
sub mysleep {
    my($self, $sleep) = @_;
    if (CPAN->has_inst("Time::HiRes")) {
        Time::HiRes::sleep($sleep);
    } else {
        sleep($sleep < 1 ? 1 : int($sleep + 0.5));
    }
}

#-> sub CPAN::Shell::setup_output ;
sub setup_output {
    return if -t STDOUT;
    my $odef = select STDERR;
    $| = 1;
    select STDOUT;
    $| = 1;
    select $odef;
}

#-> sub CPAN::Shell::rematein ;
# RE-adme||MA-ke||TE-st||IN-stall : nearly everything runs through here
sub rematein {
    my $self = shift;
    # this variable was global and disturbed programmers, so localize:
    local $CPAN::Distrostatus::something_has_failed_at;
    my($meth,@some) = @_;
    my @pragma;
    while($meth =~ /^(ff?orce|notest)$/) {
        push @pragma, $meth;
        $meth = shift @some or
            $CPAN::Frontend->mydie("Pragma $pragma[-1] used without method: ".
                                   "cannot continue");
    }
    setup_output();
    CPAN->debug("pragma[@pragma]meth[$meth]some[@some]") if $CPAN::DEBUG;

# Here is the place to set "test_count" on all involved parties to
    # 0. We then can pass this counter on to the involved
    # distributions and those can refuse to test if test_count > X. In
    # the first stab at it we could use a 1 for "X".

# But when do I reset the distributions to start with 0 again?
    # Jost suggested to have a random or cycling interaction ID that
    # we pass through. But the ID is something that is just left lying
    # around in addition to the counter, so I'd prefer to set the
    # counter to 0 now, and repeat at the end of the loop. But what
    # about dependencies? They appear later and are not reset, they
    # enter the queue but not its copy. How do they get a sensible
    # test_count?

# With configure_requires, "get" is vulnerable in recursion.

my $needs_recursion_protection = "get|make|test|install";

# construct the queue
    my($s,@s,@qcopy);
  STHING: foreach $s (@some) {
        my $obj;
        if (ref $s) {
            CPAN->debug("s is an object[$s]") if $CPAN::DEBUG;
            $obj = $s;
        } elsif ($s =~ m|[\$\@\%]|) { # looks like a perl variable
        } elsif ($s =~ m|^/|) { # looks like a regexp
            if (substr($s,-1,1) eq ".") {
                $obj = CPAN::Shell->expandany($s);
            } else {
                my @obj;
            CLASS: for my $class (qw(Distribution Bundle Module)) {
                    if (@obj = $self->expand($class,$s)) {
                        last CLASS;
                    }
                }
                if (@obj) {
                    if (1==@obj) {
                        $obj = $obj[0];
                    } else {
                        $CPAN::Frontend->mywarn("Sorry, $meth with a regular expression is ".
                                                "only supported when unambiguous.\nRejecting argument '$s'\n");
                        $CPAN::Frontend->mysleep(2);
                        next STHING;
                    }
                }
            }
        } elsif ($meth eq "ls") {
            $self->globls($s,\@pragma);
            next STHING;
        } else {
            CPAN->debug("calling expandany [$s]") if $CPAN::DEBUG;
            $obj = CPAN::Shell->expandany($s);
        }
        if (0) {
        } elsif (ref $obj) {
            if ($meth =~ /^($needs_recursion_protection)$/) {
                # it would be silly to check for recursion for look or dump
                # (we are in CPAN::Shell::rematein)
                CPAN->debug("Testing against recursion") if $CPAN::DEBUG;
                eval {  $obj->color_cmd_tmps(0,1); };
                if ($@) {
                    if (ref $@
                        and $@->isa("CPAN::Exception::RecursiveDependency")) {
                        $CPAN::Frontend->mywarn($@);
                    } else {
                        if (0) {
                            require Carp;
                            Carp::confess(sprintf "DEBUG: \$\@[%s]ref[%s]", $@, ref $@);
                        }
                        die;
                    }
                }
            }
            CPAN::Queue->queue_item(qmod => $obj->id, reqtype => "c");
            push @qcopy, $obj;
        } elsif ($CPAN::META->exists('CPAN::Author',uc($s))) {
            $obj = $CPAN::META->instance('CPAN::Author',uc($s));
            if ($meth =~ /^(dump|ls|reports)$/) {
                $obj->$meth();
            } else {
                $CPAN::Frontend->mywarn(
                                        join "",
                                        "Don't be silly, you can't $meth ",
                                        $obj->fullname,
                                        " ;-)\n"
                                       );
                $CPAN::Frontend->mysleep(2);
            }
        } elsif ($s =~ m|[\$\@\%]| && $meth eq "dump") {
            CPAN::InfoObj->dump($s);
        } else {
            $CPAN::Frontend
                ->mywarn(qq{Warning: Cannot $meth $s, }.
                         qq{don't know what it is.
Try the command

i /$s/

to find objects with matching identifiers.
});
            $CPAN::Frontend->mysleep(2);
        }
    }

# queuerunner (please be warned: when I started to change the
    # queue to hold objects instead of names, I made one or two
    # mistakes and never found which. I reverted back instead)
  QITEM: while (my $q = CPAN::Queue->first) {
        my $obj;
        my $s = $q->as_string;
        my $reqtype = $q->reqtype || "";
        $obj = CPAN::Shell->expandany($s);
        unless ($obj) {
            # don't know how this can happen, maybe we should panic,
            # but maybe we get a solution from the first user who hits
            # this unfortunate exception?
            $CPAN::Frontend->mywarn("Warning: Could not expand string '$s' ".
                                    "to an object. Skipping.\n");
            $CPAN::Frontend->mysleep(5);
            CPAN::Queue->delete_first($s);
            next QITEM;
        }
        $obj->{reqtype} ||= "";
        {
            # force debugging because CPAN::SQLite somehow delivers us
            # an empty object;

# local $CPAN::DEBUG = 1024; # Shell; probably fixed now

CPAN->debug("s[$s]obj-reqtype[$obj->{reqtype}]".
                        "q-reqtype[$reqtype]") if $CPAN::DEBUG;
        }
        if ($obj->{reqtype}) {
            if ($obj->{reqtype} eq "b" && $reqtype =~ /^[rc]$/) {
                $obj->{reqtype} = $reqtype;
                if (
                    exists $obj->{install}
                    &&
                    (
                     UNIVERSAL::can($obj->{install},"failed") ?
                     $obj->{install}->failed :
                     $obj->{install} =~ /^NO/
                    )
                   ) {
                    delete $obj->{install};
                    $CPAN::Frontend->mywarn
                        ("Promoting $obj->{ID} from 'build_requires' to 'requires'");
                }
            }
        } else {
            $obj->{reqtype} = $reqtype;
        }

for my $pragma (@pragma) {
            if ($pragma
                &&
                $obj->can($pragma)) {
                $obj->$pragma($meth);
            }
        }
        if (UNIVERSAL::can($obj, 'called_for')) {
            $obj->called_for($s);
        }
        CPAN->debug(qq{pragma[@pragma]meth[$meth]}.
                    qq{ID[$obj->{ID}]}) if $CPAN::DEBUG;

push @qcopy, $obj;
        if ($meth =~ /^(report)$/) { # they came here with a pragma?
            $self->$meth($obj);
        } elsif (! UNIVERSAL::can($obj,$meth)) {
            # Must never happen
            my $serialized = "";
            if (0) {
            } elsif ($CPAN::META->has_inst("YAML::Syck")) {
                $serialized = YAML::Syck::Dump($obj);
            } elsif ($CPAN::META->has_inst("YAML")) {
                $serialized = YAML::Dump($obj);
            } elsif ($CPAN::META->has_inst("Data::Dumper")) {
                $serialized = Data::Dumper::Dumper($obj);
            } else {
                require overload;
                $serialized = overload::StrVal($obj);
            }
            CPAN->debug("Going to panic. meth[$meth]s[$s]") if $CPAN::DEBUG;
            $CPAN::Frontend->mydie("Panic: obj[$serialized] cannot meth[$meth]");
        } elsif ($obj->$meth()) {
            CPAN::Queue->delete($s);
            CPAN->debug("From queue deleted. meth[$meth]s[$s]") if $CPAN::DEBUG;
        } else {
            CPAN->debug("Failed. pragma[@pragma]meth[$meth]") if $CPAN::DEBUG;
        }

$obj->undelay;
        for my $pragma (@pragma) {
            my $unpragma = "un$pragma";
            if ($obj->can($unpragma)) {
                $obj->$unpragma();
            }
        }
        if ($CPAN::Config->{halt_on_failure}
                &&
                    CPAN::Distrostatus::something_has_just_failed()
              ) {
            $CPAN::Frontend->mywarn("Stopping: '$meth' failed for '$s'.\n");
            CPAN::Queue->nullify_queue;
            last QITEM;
        }
        CPAN::Queue->delete_first($s);
    }
    if ($meth =~ /^($needs_recursion_protection)$/) {
        for my $obj (@qcopy) {
            $obj->color_cmd_tmps(0,0);
        }
    }
}

#-> sub CPAN::Shell::recent ;
sub recent {
  my($self) = @_;
  if ($CPAN::META->has_inst("XML::LibXML")) {
      my $url = $CPAN::Defaultrecent;
      $CPAN::Frontend->myprint("Fetching '$url'\n");
      unless ($CPAN::META->has_usable("LWP")) {
          $CPAN::Frontend->mydie("LWP not installed; cannot continue");
      }
      CPAN::LWP::UserAgent->config;
      my $Ua;
      eval { $Ua = CPAN::LWP::UserAgent->new; };
      if ($@) {
          $CPAN::Frontend->mydie("CPAN::LWP::UserAgent->new dies with $@\n");
      }
      my $resp = $Ua->get($url);
      unless ($resp->is_success) {
          $CPAN::Frontend->mydie(sprintf "Could not download '%s': %s\n", $url, $resp->code);
      }
      $CPAN::Frontend->myprint("DONE\n\n");
      my $xml = XML::LibXML->new->parse_string($resp->content);
      if (0) {
          my $s = $xml->serialize(2);
          $s =~ s/\n\s*\n/\n/g;
          $CPAN::Frontend->myprint($s);
          return;
      }
      my @distros;
      if ($url =~ /winnipeg/) {
          my $pubdate = $xml->findvalue("/rss/channel/pubDate");
          $CPAN::Frontend->myprint("    pubDate: $pubdate\n\n");
          for my $eitem ($xml->findnodes("/rss/channel/item")) {
              my $distro = $eitem->findvalue("enclosure/\@url");
              $distro =~ s|.*?/authors/id/./../||;
              my $size   = $eitem->findvalue("enclosure/\@length");
              my $desc   = $eitem->findvalue("description");
              $desc =~ s/.+? - //;
              $CPAN::Frontend->myprint("$distro [$size b]\n    $desc\n");
              push @distros, $distro;
          }
      } elsif ($url =~ /search.*uploads.rdf/) {
          # xmlns:rdf="http://www.w3.org/1999/02/22-rdf-syntax-ns#"
          # xmlns="http://purl.org/rss/1.0/"
          # xmlns:taxo="http://purl.org/rss/1.0/modules/taxonomy/"
          # xmlns:dc="http://purl.org/dc/elements/1.1/"
          # xmlns:syn="http://purl.org/rss/1.0/modules/syndication/"
          # xmlns:admin="http://webns.net/mvcb/"

my $dc_date = $xml->findvalue("//*[local-name(.) = 'RDF']/*[local-name(.) = 'channel']/*[local-name(.) = 'date']");
          $CPAN::Frontend->myprint("    dc:date: $dc_date\n\n");
          my $finish_eitem = 0;
          local $SIG{INT} = sub { $finish_eitem = 1 };
        EITEM: for my $eitem ($xml->findnodes("//*[local-name(.) = 'RDF']/*[local-name(.) = 'item']")) {
              my $distro = $eitem->findvalue("\@rdf:about");
              $distro =~ s|.*~||; # remove up to the tilde before the name
              $distro =~ s|/$||; # remove trailing slash
              $distro =~ s|([^/]+)|\U$1\E|; # upcase the name
              my $author = uc $1 or die "distro[$distro] without author, cannot continue";
              my $desc   = $eitem->findvalue("*[local-name(.) = 'description']");
              my $i = 0;
            SUBDIRTEST: while () {
                  last SUBDIRTEST if ++$i >= 6; # half a dozen must do!
                  if (my @ret = $self->globls("$distro*")) {
                      @ret = grep {$_->[2] !~ /meta/} @ret;
                      @ret = grep {length $_->[2]} @ret;
                      if (@ret) {
                          $distro = "$author/$ret[0][2]";
                          last SUBDIRTEST;
                      }
                  }
                  $distro =~ s|/|/*/|; # allow it to reside in a subdirectory
              }

next EITEM if $distro =~ m|\*|; # did not find the thing
              $CPAN::Frontend->myprint("____$desc\n");
              push @distros, $distro;
              last EITEM if $finish_eitem;
          }
      }
      return \@distros;
  } else {
      # deprecated old version
      $CPAN::Frontend->mydie("no XML::LibXML installed, cannot continue\n");
  }
}

#-> sub CPAN::Shell::smoke ;
sub smoke {
    my($self) = @_;
    my $distros = $self->recent;
  DISTRO: for my $distro (@$distros) {
        next if $distro =~ m|/Bundle-|; # XXX crude heuristic to skip bundles
        $CPAN::Frontend->myprint(sprintf "Downloading and testing '$distro'\n");
        {
            my $skip = 0;
            local $SIG{INT} = sub { $skip = 1 };
            for (0..9) {
                $CPAN::Frontend->myprint(sprintf "\r%2d (Hit ^C to skip)", 10-$_);
                sleep 1;
                if ($skip) {
                    $CPAN::Frontend->myprint(" skipped\n");
                    next DISTRO;
                }
            }
        }
        $CPAN::Frontend->myprint("\r  \n"); # leave the dirty line with a newline
        $self->test($distro);
    }
}

{
    # set up the dispatching methods
    no strict "refs";
    for my $command (qw(
                        clean
                        cvs_import
                        dump
                        force
                        fforce
                        get
                        install
                        look
                        ls
                        make
                        notest
                        perldoc
                        readme
                        reports
                        test
                       )) {
        *$command = sub { shift->rematein($command, @_); };
    }
}

Back to Directory File Manager