diff options
Diffstat (limited to 'Master/tlpkg/tlperl0/lib/CPAN/Shell.pm')
-rwxr-xr-x | Master/tlpkg/tlperl0/lib/CPAN/Shell.pm | 1974 |
1 files changed, 1974 insertions, 0 deletions
diff --git a/Master/tlpkg/tlperl0/lib/CPAN/Shell.pm b/Master/tlpkg/tlperl0/lib/CPAN/Shell.pm new file mode 100755 index 00000000000..8fb5628b112 --- /dev/null +++ b/Master/tlpkg/tlperl0/lib/CPAN/Shell.pm @@ -0,0 +1,1974 @@ +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.5"; +# 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', + ); +} + +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'); +} + +# 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; |