summaryrefslogtreecommitdiff
path: root/Master/tlpkg/tlperl/lib/CPAN/Shell.pm
diff options
context:
space:
mode:
Diffstat (limited to 'Master/tlpkg/tlperl/lib/CPAN/Shell.pm')
-rw-r--r--Master/tlpkg/tlperl/lib/CPAN/Shell.pm1988
1 files changed, 1988 insertions, 0 deletions
diff --git a/Master/tlpkg/tlperl/lib/CPAN/Shell.pm b/Master/tlpkg/tlperl/lib/CPAN/Shell.pm
new file mode 100644
index 00000000000..91cbdd22ac8
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/CPAN/Shell.pm
@@ -0,0 +1,1988 @@
+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.5001";
+# 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);
+ $CPAN::Frontend->myprint("\$CPAN::Config options from ");
+ my @from;
+ if (exists $INC{'CPAN/Config.pm'}) {
+ push @from, $INC{'CPAN/Config.pm'};
+ }
+ if (exists $INC{'CPAN/MyConfig.pm'}) {
+ push @from, $INC{'CPAN/MyConfig.pm'};
+ }
+ $CPAN::Frontend->myprint(join " and ", map {"'$_'"} @from);
+ $CPAN::Frontend->myprint(":\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, $cpanpm, %args) = @_;
+ require CPAN::FirstTime;
+ my $home = CPAN::HandleConfig::home();
+ $cpanpm = $INC{'CPAN/MyConfig.pm'} ||
+ File::Spec->catfile(split /\//, "$home/.cpan/CPAN/MyConfig.pm");
+ File::Path::mkpath(File::Basename::dirname($cpanpm)) unless -e $cpanpm;
+ CPAN::HandleConfig::require_myconfig_or_config();
+ $CPAN::Config ||= {};
+ $CPAN::Config = {
+ %$CPAN::Config,
+ build_dir => undef,
+ cpan_home => undef,
+ keep_source_where => undef,
+ histfile => undef,
+ };
+ CPAN::FirstTime::init($cpanpm, %args);
+}
+
+#-> 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");
+}
+
+#-> 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 ) {
+ 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("Going to test 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("Going to fetch '$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 "Going to download and test '$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, @_); };
+ }
+}
+
+1;