4 # -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*-
5 # vim: ts=4 sts=4 sw=4:
24 "CPAN/DeferredCode.pm",
25 "CPAN/Distribution.pm",
26 "CPAN/Distroprefs.pm",
27 "CPAN/Distrostatus.pm",
28 "CPAN/Exception/RecursiveDependency.pm",
29 "CPAN/Exception/yaml_not_installed.pm",
33 "CPAN/HandleConfig.pm",
37 "CPAN/LWP/UserAgent.pm",
41 "CPAN/Reporter/Config.pm",
42 "CPAN/Reporter/History.pm",
43 "CPAN/Reporter/PrereqCheck.pm",
51 # record the initial timestamp for reload.
52 $reload = { map {$INC{$_} ? ($_,(stat $INC{$_})[9]) : ()} @relo };
53 @CPAN::Shell::ISA = qw(CPAN::Debug);
56 $COLOR_REGISTERED ||= 0;
59 '!' => "eval the rest of the line as perl",
61 autobundle => "write inventory into a bundle file",
62 b => "info about bundle",
64 clean => "clean up a distribution's build directory",
66 d => "info about a distribution",
69 failed => "list all failed actions within current session",
70 fforce => "redo a command from scratch",
71 force => "redo a command",
72 get => "download a distribution",
74 help => "overview over commands; 'help ...' explains specific commands",
75 hosts => "statistics about recently used hosts",
76 i => "info about authors/bundles/distributions/modules",
77 install => "install a distribution",
78 install_tested => "install all distributions tested OK",
79 is_tested => "list all distributions tested OK",
80 look => "open a subshell in a distribution's directory",
81 ls => "list distributions matching a fileglob",
82 m => "info about a module",
83 make => "make/build a distribution",
84 mkmyconfig => "write current config into a CPAN/MyConfig.pm file",
85 notest => "run a (usually install) command but leave out the test phase",
86 o => "'o conf ...' for config stuff; 'o debug ...' for debugging",
87 perldoc => "try to get a manpage for a module",
89 quit => "leave the cpan shell",
90 r => "review upgradable modules",
91 readme => "display the README of a distro with a pager",
92 recent => "show recent uploads to the CPAN",
94 reload => "'reload cpan' or 'reload index'",
95 report => "test a distribution and send a test report to cpantesters",
96 reports => "info about reported tests from cpantesters",
99 test => "test a distribution",
100 u => "display uninstalled modules",
101 upgrade => "combine 'r' command with immediate installation",
104 $autoload_recursion ||= 0;
106 #-> sub CPAN::Shell::AUTOLOAD ;
107 sub AUTOLOAD { ## no critic
108 $autoload_recursion++;
110 my $class = shift(@_);
111 # warn "autoload[$l] class[$class]";
114 warn "Refusing to autoload '$l' while signal pending";
115 $autoload_recursion--;
118 if ($autoload_recursion > 1) {
119 my $fullcommand = join " ", map { "'$_'" } $l, @_;
120 warn "Refusing to autoload $fullcommand in recursion\n";
121 $autoload_recursion--;
125 # XXX needs to be reconsidered
126 if ($CPAN::META->has_inst('CPAN::WAIT')) {
129 $CPAN::Frontend->mywarn(qq{
130 Commands starting with "w" require CPAN::WAIT to be installed.
131 Please consider installing CPAN::WAIT to use the fulltext index.
132 For this you just need to type
137 $CPAN::Frontend->mywarn(qq{Unknown shell command '$l'. }.
141 $autoload_recursion--;
146 #-> sub CPAN::Shell::h ;
148 my($class,$about) = @_;
149 if (defined $about) {
151 if (exists $Help->{$about}) {
152 if (ref $Help->{$about}) { # aliases
153 $about = ${$Help->{$about}};
155 $help = $Help->{$about};
157 $help = "No help available";
159 $CPAN::Frontend->myprint("$about\: $help\n");
161 my $filler = " " x (80 - 28 - length($CPAN::VERSION));
162 $CPAN::Frontend->myprint(qq{
163 Display Information $filler (ver $CPAN::VERSION)
164 command argument description
165 a,b,d,m WORD or /REGEXP/ about authors, bundles, distributions, modules
166 i WORD or /REGEXP/ about any of the above
167 ls AUTHOR or GLOB about files in the author's directory
168 (with WORD being a module, bundle or author name or a distribution
169 name of the form AUTHOR/DISTRIBUTION)
171 Download, Test, Make, Install...
172 get download clean make clean
173 make make (implies get) look open subshell in dist directory
174 test make test (implies make) readme display these README files
175 install make install (implies test) perldoc display POD documentation
178 r WORDs or /REGEXP/ or NONE report updates for some/matching/all modules
179 upgrade WORDs or /REGEXP/ or NONE upgrade some/matching/all modules
182 force CMD try hard to do command fforce CMD try harder
183 notest CMD skip testing
186 h,? display this menu ! perl-code eval a perl command
187 o conf [opt] set and query options q quit the cpan shell
188 reload cpan load CPAN.pm again reload index load newer indices
189 autobundle Snapshot recent latest CPAN uploads});
195 #-> sub CPAN::Shell::a ;
198 # authors are always UPPERCASE
200 $_ = uc $_ unless /=/;
202 $CPAN::Frontend->myprint($self->format_result('Author',@arg));
205 #-> sub CPAN::Shell::globls ;
207 my($self,$s,$pragmas) = @_;
208 # ls is really very different, but we had it once as an ordinary
209 # command in the Shell (upto rev. 321) and we could not handle
211 my(@accept,@preexpand);
212 if ($s =~ /[\*\?\/]/) {
213 if ($CPAN::META->has_inst("Text::Glob")) {
214 if (my($au,$pathglob) = $s =~ m|(.*?)/(.*)|) {
215 my $rau = Text::Glob::glob_to_regex(uc $au);
216 CPAN::Shell->debug("au[$au]pathglob[$pathglob]rau[$rau]")
218 push @preexpand, map { $_->id . "/" . $pathglob }
219 CPAN::Shell->expand_by_method('CPAN::Author',['id'],"/$rau/");
221 my $rau = Text::Glob::glob_to_regex(uc $s);
222 push @preexpand, map { $_->id }
223 CPAN::Shell->expand_by_method('CPAN::Author',
228 $CPAN::Frontend->mydie("Text::Glob not installed, cannot proceed");
231 push @preexpand, uc $s;
234 unless (/^[A-Z0-9\-]+(\/|$)/i) {
235 $CPAN::Frontend->mywarn("ls command rejects argument $_: not an author\n");
240 my $silent = @accept>1;
243 for my $a (@accept) {
244 my($author,$pathglob);
245 if ($a =~ m|(.*?)/(.*)|) {
248 $author = CPAN::Shell->expand_by_method('CPAN::Author',
251 or $CPAN::Frontend->mydie("No author found for $a2\n");
253 $author = CPAN::Shell->expand_by_method('CPAN::Author',
256 or $CPAN::Frontend->mydie("No author found for $a\n");
259 my $alpha = substr $author->id, 0, 1;
261 if ($alpha eq $last_alpha) {
265 $last_alpha = $alpha;
267 $CPAN::Frontend->myprint($ad);
269 for my $pragma (@$pragmas) {
270 if ($author->can($pragma)) {
274 CPAN->debug("author[$author]pathglob[$pathglob]silent[$silent]") if $CPAN::DEBUG;
275 push @results, $author->ls($pathglob,$silent); # silent if
278 for my $pragma (@$pragmas) {
279 my $unpragma = "un$pragma";
280 if ($author->can($unpragma)) {
281 $author->$unpragma();
288 #-> sub CPAN::Shell::local_bundles ;
290 my($self,@which) = @_;
291 my($incdir,$bdir,$dh);
292 foreach $incdir ($CPAN::Config->{'cpan_home'},@INC) {
293 my @bbase = "Bundle";
294 while (my $bbase = shift @bbase) {
295 $bdir = File::Spec->catdir($incdir,split /::/, $bbase);
296 CPAN->debug("bdir[$bdir]\@bbase[@bbase]") if $CPAN::DEBUG;
297 if ($dh = DirHandle->new($bdir)) { # may fail
299 for $entry ($dh->read) {
300 next if $entry =~ /^\./;
301 next unless $entry =~ /^\w+(\.pm)?(?!\n)\Z/;
302 if (-d File::Spec->catdir($bdir,$entry)) {
303 push @bbase, "$bbase\::$entry";
305 next unless $entry =~ s/\.pm(?!\n)\Z//;
306 $CPAN::META->instance('CPAN::Bundle',"$bbase\::$entry");
314 #-> sub CPAN::Shell::b ;
316 my($self,@which) = @_;
317 CPAN->debug("which[@which]") if $CPAN::DEBUG;
318 $self->local_bundles;
319 $CPAN::Frontend->myprint($self->format_result('Bundle',@which));
322 #-> sub CPAN::Shell::d ;
323 sub d { $CPAN::Frontend->myprint(shift->format_result('Distribution',@_));}
325 #-> sub CPAN::Shell::m ;
326 sub m { # emacs confused here }; sub mimimimimi { # emacs in sync here
328 $CPAN::Frontend->myprint($self->format_result('Module',@_));
331 #-> sub CPAN::Shell::i ;
335 @args = '/./' unless @args;
337 for my $type (qw/Bundle Distribution Module/) {
338 push @result, $self->expand($type,@args);
340 # Authors are always uppercase.
341 push @result, $self->expand("Author", map { uc $_ } @args);
343 my $result = @result == 1 ?
344 $result[0]->as_string :
346 "No objects found of any type for argument @args\n" :
348 (map {$_->as_glimpse} @result),
349 scalar @result, " items found\n",
351 $CPAN::Frontend->myprint($result);
354 #-> sub CPAN::Shell::o ;
356 # CPAN::Shell::o and CPAN::HandleConfig::edit are closely related. 'o
357 # conf' calls through to CPAN::HandleConfig::edit. 'o conf' should
358 # probably have been called 'set' and 'o debug' maybe 'set debug' or
359 # 'debug'; 'o conf ARGS' calls ->edit in CPAN/HandleConfig.pm
361 my($self,$o_type,@o_what) = @_;
363 CPAN->debug("o_type[$o_type] o_what[".join(" | ",@o_what)."]\n");
364 if ($o_type eq 'conf') {
366 ($cfilter) = $o_what[0] =~ m|^/(.*)/$| if @o_what;
367 if (!@o_what or $cfilter) { # print all things, "o conf"
369 my $qrfilter = eval 'qr/$cfilter/';
371 $CPAN::Frontend->myprint("\$CPAN::Config options from ");
373 if (exists $INC{'CPAN/Config.pm'}) {
374 push @from, $INC{'CPAN/Config.pm'};
376 if (exists $INC{'CPAN/MyConfig.pm'}) {
377 push @from, $INC{'CPAN/MyConfig.pm'};
379 $CPAN::Frontend->myprint(join " and ", map {"'$_'"} @from);
380 $CPAN::Frontend->myprint(":\n");
381 for $k (sort keys %CPAN::HandleConfig::can) {
382 next unless $k =~ /$qrfilter/;
383 $v = $CPAN::HandleConfig::can{$k};
384 $CPAN::Frontend->myprint(sprintf " %-18s [%s]\n", $k, $v);
386 $CPAN::Frontend->myprint("\n");
387 for $k (sort keys %CPAN::HandleConfig::keys) {
388 next unless $k =~ /$qrfilter/;
389 CPAN::HandleConfig->prettyprint($k);
391 $CPAN::Frontend->myprint("\n");
393 if (CPAN::HandleConfig->edit(@o_what)) {
395 $CPAN::Frontend->myprint(qq{Type 'o conf' to view all configuration }.
399 } elsif ($o_type eq 'debug') {
401 @o_what = () if defined $o_what[0] && $o_what[0] =~ /help/i;
404 my($what) = shift @o_what;
405 if ($what =~ s/^-// && exists $CPAN::DEBUG{$what}) {
406 $CPAN::DEBUG &= $CPAN::DEBUG ^ $CPAN::DEBUG{$what};
409 if ( exists $CPAN::DEBUG{$what} ) {
410 $CPAN::DEBUG |= $CPAN::DEBUG{$what};
411 } elsif ($what =~ /^\d/) {
412 $CPAN::DEBUG = $what;
413 } elsif (lc $what eq 'all') {
415 for (values %CPAN::DEBUG) {
421 for (keys %CPAN::DEBUG) {
422 next unless lc($_) eq lc($what);
423 $CPAN::DEBUG |= $CPAN::DEBUG{$_};
426 $CPAN::Frontend->myprint("unknown argument [$what]\n")
431 my $raw = "Valid options for debug are ".
432 join(", ",sort(keys %CPAN::DEBUG), 'all').
433 qq{ or a number. Completion works on the options. }.
434 qq{Case is ignored.};
436 $CPAN::Frontend->myprint(Text::Wrap::fill("","",$raw));
437 $CPAN::Frontend->myprint("\n\n");
440 $CPAN::Frontend->myprint("Options set for debugging ($CPAN::DEBUG):\n");
442 for $k (sort {$CPAN::DEBUG{$a} <=> $CPAN::DEBUG{$b}} keys %CPAN::DEBUG) {
443 $v = $CPAN::DEBUG{$k};
444 $CPAN::Frontend->myprint(sprintf " %-14s(%s)\n", $k, $v)
445 if $v & $CPAN::DEBUG;
448 $CPAN::Frontend->myprint("Debugging turned off completely.\n");
451 $CPAN::Frontend->myprint(qq{
453 conf set or get configuration variables
454 debug set or get debugging options
459 # CPAN::Shell::paintdots_onreload
460 sub paintdots_onreload {
463 if ( $_[0] =~ /[Ss]ubroutine ([\w:]+) redefined/ ) {
467 # $CPAN::Frontend->myprint(".($subr)");
468 $CPAN::Frontend->myprint(".");
469 if ($subr =~ /\bshell\b/i) {
470 # warn "debug[$_[0]]";
472 # It would be nice if we could detect that a
473 # subroutine has actually changed, but for now we
474 # practically always set the GOTOSHELL global
484 #-> sub CPAN::Shell::hosts ;
487 my $fullstats = CPAN::FTP->_ftp_statistics();
488 my $history = $fullstats->{history} || [];
490 while (my $last = pop @$history) {
491 my $attempts = $last->{attempts} or next;
494 $start = $attempts->[-1]{start};
495 if ($#$attempts > 0) {
496 for my $i (0..$#$attempts-1) {
497 my $url = $attempts->[$i]{url} or next;
502 $start = $last->{start};
504 next unless $last->{thesiteurl}; # C-C? bad filenames?
506 $S{end} ||= $last->{end};
507 my $dltime = $last->{end} - $start;
508 my $dlsize = $last->{filesize} || 0;
509 my $url = ref $last->{thesiteurl} ? $last->{thesiteurl}->text : $last->{thesiteurl};
510 my $s = $S{ok}{$url} ||= {};
513 $s->{dlsize} += $dlsize/1024;
515 $s->{dltime} += $dltime;
518 for my $url (keys %{$S{ok}}) {
519 next if $S{ok}{$url}{dltime} == 0; # div by zero
520 push @{$res->{ok}}, [@{$S{ok}{$url}}{qw(n dlsize dltime)},
521 $S{ok}{$url}{dlsize}/$S{ok}{$url}{dltime},
525 for my $url (keys %{$S{no}}) {
526 push @{$res->{no}}, [$S{no}{$url},
531 if ($S{start} && $S{end}) {
532 $R .= sprintf "Log starts: %s\n", $S{start} ? scalar(localtime $S{start}) : "unknown";
533 $R .= sprintf "Log ends : %s\n", $S{end} ? scalar(localtime $S{end}) : "unknown";
535 if ($res->{ok} && @{$res->{ok}}) {
536 $R .= sprintf "\nSuccessful downloads:
537 N kB secs kB/s url\n";
539 for (sort { $b->[3] <=> $a->[3] } @{$res->{ok}}) {
540 $R .= sprintf "%4d %8d %5d %9.1f %s\n", @$_;
544 if ($res->{no} && @{$res->{no}}) {
545 $R .= sprintf "\nUnsuccessful downloads:\n";
547 for (sort { $b->[0] <=> $a->[0] } @{$res->{no}}) {
548 $R .= sprintf "%4d %s\n", @$_;
552 $CPAN::Frontend->myprint($R);
555 # here is where 'reload cpan' is done
556 #-> sub CPAN::Shell::reload ;
558 my($self,$command,@arg) = @_;
560 $self->debug("self[$self]command[$command]arg[@arg]") if $CPAN::DEBUG;
561 if ($command =~ /^cpan$/i) {
563 chdir $CPAN::iCwd if $CPAN::iCwd; # may fail
565 MFILE: for my $f (@relo) {
566 next unless exists $INC{$f};
570 $CPAN::Frontend->myprint("($p");
571 local($SIG{__WARN__}) = paintdots_onreload(\$redef);
572 $self->_reload_this($f) or $failed++;
573 my $v = eval "$p\::->VERSION";
574 $CPAN::Frontend->myprint("v$v)");
576 $CPAN::Frontend->myprint("\n$redef subroutines redefined\n");
578 my $errors = $failed == 1 ? "error" : "errors";
579 $CPAN::Frontend->mywarn("\n$failed $errors during reload. You better quit ".
582 } elsif ($command =~ /^index$/i) {
583 CPAN::Index->force_reload;
585 $CPAN::Frontend->myprint(qq{cpan re-evals the CPAN modules
586 index re-reads the index files\n});
590 # reload means only load again what we have loaded before
591 #-> sub CPAN::Shell::_reload_this ;
593 my($self,$f,$args) = @_;
594 CPAN->debug("f[$f]") if $CPAN::DEBUG;
595 return 1 unless $INC{$f}; # we never loaded this, so we do not
597 my $pwd = CPAN::anycwd();
598 CPAN->debug("pwd[$pwd]") if $CPAN::DEBUG;
601 $file = File::Spec->catfile($inc,split /\//, $f);
605 CPAN->debug("file[$file]") if $CPAN::DEBUG;
607 unless ($file && -f $file) {
608 # this thingie is not in the INC path, maybe CPAN/MyConfig.pm?
610 unless (CPAN->has_inst("File::Basename")) {
611 @inc = File::Basename::dirname($file);
613 # do we ever need this?
614 @inc = substr($file,0,-length($f)-1); # bring in back to me!
617 CPAN->debug("file[$file]inc[@inc]") if $CPAN::DEBUG;
619 $CPAN::Frontend->mywarn("Found no file to reload for '$f'\n");
622 my $mtime = (stat $file)[9];
623 $reload->{$f} ||= -1;
624 my $must_reload = $mtime != $reload->{$f};
626 $must_reload ||= $args->{reloforce}; # o conf defaults needs this
628 my $fh = FileHandle->new($file) or
629 $CPAN::Frontend->mydie("Could not open $file: $!");
633 CPAN->debug(sprintf("reload file[%s] content[%s...]",$file,substr($content,0,128)))
642 $reload->{$f} = $mtime;
644 $CPAN::Frontend->myprint("__unchanged__");
649 #-> sub CPAN::Shell::mkmyconfig ;
651 my($self, $cpanpm, %args) = @_;
652 require CPAN::FirstTime;
653 my $home = CPAN::HandleConfig::home();
654 $cpanpm = $INC{'CPAN/MyConfig.pm'} ||
655 File::Spec->catfile(split /\//, "$home/.cpan/CPAN/MyConfig.pm");
656 File::Path::mkpath(File::Basename::dirname($cpanpm)) unless -e $cpanpm;
657 CPAN::HandleConfig::require_myconfig_or_config();
658 $CPAN::Config ||= {};
663 keep_source_where => undef,
666 CPAN::FirstTime::init($cpanpm, %args);
669 #-> sub CPAN::Shell::_binary_extensions ;
670 sub _binary_extensions {
671 my($self) = shift @_;
672 my(@result,$module,%seen,%need,$headerdone);
673 for $module ($self->expand('Module','/./')) {
674 my $file = $module->cpan_file;
675 next if $file eq "N/A";
676 next if $file =~ /^Contact Author/;
677 my $dist = $CPAN::META->instance('CPAN::Distribution',$file);
678 next if $dist->isa_perl;
679 next unless $module->xs_file;
681 $CPAN::Frontend->myprint(".");
682 push @result, $module;
684 # print join " | ", @result;
685 $CPAN::Frontend->myprint("\n");
689 #-> sub CPAN::Shell::recompile ;
691 my($self) = shift @_;
692 my($module,@module,$cpan_file,%dist);
693 @module = $self->_binary_extensions();
694 for $module (@module) { # we force now and compile later, so we
696 $cpan_file = $module->cpan_file;
697 my $pack = $CPAN::META->instance('CPAN::Distribution',$cpan_file);
701 for $cpan_file (sort keys %dist) {
702 $CPAN::Frontend->myprint(" CPAN: Recompiling $cpan_file\n\n");
703 my $pack = $CPAN::META->instance('CPAN::Distribution',$cpan_file);
705 $CPAN::Signal = 0; # it's tempting to reset Signal, so we can
706 # stop a package from recompiling,
707 # e.g. IO-1.12 when we have perl5.003_10
711 #-> sub CPAN::Shell::scripts ;
713 my($self, $arg) = @_;
714 $CPAN::Frontend->mywarn(">>>> experimental command, currently unsupported <<<<\n\n");
716 for my $req (qw( HTML::LinkExtor Sort::Versions List::Util )) {
717 unless ($CPAN::META->has_inst($req)) {
718 $CPAN::Frontend->mywarn(" $req not available\n");
721 my $p = HTML::LinkExtor->new();
722 my $indexfile = "/home/ftp/pub/PAUSE/scripts/new/index.html";
723 unless (-f $indexfile) {
724 $CPAN::Frontend->mydie("found no indexfile[$indexfile]\n");
726 $p->parse_file($indexfile);
729 if ($arg =~ s|^/(.+)/$|$1|) {
730 $qrarg = eval 'qr/$arg/'; # hide construct from 5.004
732 for my $l ($p->links) {
734 next unless $tag eq "a";
736 my $href = $att{href};
737 next unless $href =~ s|^\.\./authors/id/./../||;
740 if ($href =~ $qrarg) {
744 if ($href =~ /\Q$arg\E/) {
752 # now filter for the latest version if there is more than one of a name
758 $stems{$stem} ||= [];
759 push @{$stems{$stem}}, $href;
761 for (sort keys %stems) {
763 if (@{$stems{$_}} > 1) {
764 $highest = List::Util::reduce {
765 Sort::Versions::versioncmp($a,$b) > 0 ? $a : $b
768 $highest = $stems{$_}[0];
770 $CPAN::Frontend->myprint("$highest\n");
774 #-> sub CPAN::Shell::report ;
776 my($self,@args) = @_;
777 unless ($CPAN::META->has_inst("CPAN::Reporter")) {
778 $CPAN::Frontend->mydie("CPAN::Reporter not installed; cannot continue");
780 local $CPAN::Config->{test_report} = 1;
781 $self->force("test",@args); # force is there so that the test be
782 # re-run (as documented)
785 # compare with is_tested
786 #-> sub CPAN::Shell::install_tested
788 my($self,@some) = @_;
789 $CPAN::Frontend->mywarn("install_tested() must not be called with arguments.\n"),
793 for my $b (reverse $CPAN::META->_list_sorted_descending_is_tested) {
796 $CPAN::Frontend->mywarn("No YAML file for $b available, skipping\n");
799 my $yaml_content = CPAN->_yaml_loadfile($yaml);
800 my $id = $yaml_content->[0]{distribution}{ID};
802 $CPAN::Frontend->mywarn("No ID found in '$yaml', skipping\n");
805 my $do = CPAN::Shell->expandany($id);
807 $CPAN::Frontend->mywarn("Could not expand ID '$id', skipping\n");
810 unless ($do->{build_dir}) {
811 $CPAN::Frontend->mywarn("Distro '$id' has no build_dir, skipping\n");
814 unless ($do->{build_dir} eq $b) {
815 $CPAN::Frontend->mywarn("Distro '$id' has build_dir '$do->{build_dir}' but expected '$b', skipping\n");
821 $CPAN::Frontend->mywarn("No tested distributions found.\n"),
824 @some = grep { $_->{make_test} && ! $_->{make_test}->failed } @some;
825 $CPAN::Frontend->mywarn("No distributions tested with this build of perl found.\n"),
828 # @some = grep { not $_->uptodate } @some;
829 # $CPAN::Frontend->mywarn("No non-uptodate distributions tested with this build of perl found.\n"),
830 # return unless @some;
832 CPAN->debug("some[@some]");
834 my $id = $d->can("pretty_id") ? $d->pretty_id : $d->id;
835 $CPAN::Frontend->myprint("install_tested: Running for $id\n");
836 $CPAN::Frontend->mysleep(1);
841 #-> sub CPAN::Shell::upgrade ;
843 my($self,@args) = @_;
844 $self->install($self->r(@args));
847 #-> sub CPAN::Shell::_u_r_common ;
849 my($self) = shift @_;
850 my($what) = shift @_;
851 CPAN->debug("self[$self] what[$what] args[@_]") if $CPAN::DEBUG;
852 Carp::croak "Usage: \$obj->_u_r_common(a|r|u)" unless
853 $what && $what =~ /^[aru]$/;
855 @args = '/./' unless @args;
856 my(@result,$module,%seen,%need,$headerdone,
857 $version_undefs,$version_zeroes,
858 @version_undefs,@version_zeroes);
859 $version_undefs = $version_zeroes = 0;
860 my $sprintf = "%s%-25s%s %9s %9s %s\n";
861 my @expand = $self->expand('Module',@args);
862 if ($CPAN::DEBUG) { # Looks like noise to me, was very useful for debugging
864 my $expand = scalar @expand;
865 $CPAN::Frontend->myprint(sprintf "%d matches in the database, time[%d]\n", $expand, time);
869 # hard to believe that the more complex sorting can lead to
870 # stack curruptions on older perl
871 @sexpand = sort {$a->id cmp $b->id} @expand;
878 $a->[1]{ID} cmp $b->[1]{ID},
880 [$_->_is_representative_module,
886 $CPAN::Frontend->myprint(sprintf "sorted at time[%d]\n", time);
889 MODULE: for $module (@sexpand) {
890 my $file = $module->cpan_file;
891 next MODULE unless defined $file; # ??
893 my($latest) = $module->cpan_version;
894 my($inst_file) = $module->inst_file;
895 CPAN->debug("file[$file]latest[$latest]") if $CPAN::DEBUG;
897 return if $CPAN::Signal;
899 eval { # version.pm involved!
902 $have = $module->inst_version;
903 } elsif ($what eq "r") {
904 $have = $module->inst_version;
906 if ($have eq "undef") {
908 push @version_undefs, $module->as_glimpse;
909 } elsif (CPAN::Version->vcmp($have,0)==0) {
911 push @version_zeroes, $module->as_glimpse;
913 ++$next_MODULE unless CPAN::Version->vgt($latest, $have);
914 # to be pedantic we should probably say:
915 # && !($have eq "undef" && $latest ne "undef" && $latest gt "");
916 # to catch the case where CPAN has a version 0 and we have a version undef
917 } elsif ($what eq "u") {
923 } elsif ($what eq "r") {
925 } elsif ($what eq "u") {
930 next MODULE if $next_MODULE;
932 $CPAN::Frontend->mywarn
933 (sprintf("Error while comparing cpan/installed versions of '%s':
940 (defined $have ? $have : "[UNDEFINED]"),
941 (ref $have ? ref $have : ""),
943 (ref $latest ? ref $latest : ""),
947 return if $CPAN::Signal; # this is sometimes lengthy
950 push @result, sprintf "%s %s\n", $module->id, $have;
951 } elsif ($what eq "r") {
952 push @result, $module->id;
953 next MODULE if $seen{$file}++;
954 } elsif ($what eq "u") {
955 push @result, $module->id;
956 next MODULE if $seen{$file}++;
957 next MODULE if $file =~ /^Contact/;
959 unless ($headerdone++) {
960 $CPAN::Frontend->myprint("\n");
961 $CPAN::Frontend->myprint(sprintf(
976 $CPAN::META->has_inst("Term::ANSIColor")
980 $color_on = Term::ANSIColor::color("green");
981 $color_off = Term::ANSIColor::color("reset");
983 $CPAN::Frontend->myprint(sprintf $sprintf,
990 $need{$module->id}++;
994 $CPAN::Frontend->myprint("No modules found for @args\n");
995 } elsif ($what eq "r") {
996 $CPAN::Frontend->myprint("All modules are up to date for @args\n");
1000 if ($version_zeroes) {
1001 my $s_has = $version_zeroes > 1 ? "s have" : " has";
1002 $CPAN::Frontend->myprint(qq{$version_zeroes installed module$s_has }.
1003 qq{a version number of 0\n});
1004 if ($CPAN::Config->{show_zero_versions}) {
1006 $CPAN::Frontend->myprint(qq{ they are\n\t@version_zeroes\n});
1007 $CPAN::Frontend->myprint(qq{(use 'o conf show_zero_versions 0' }.
1008 qq{to hide them)\n});
1010 $CPAN::Frontend->myprint(qq{(use 'o conf show_zero_versions 1' }.
1011 qq{to show them)\n});
1014 if ($version_undefs) {
1015 my $s_has = $version_undefs > 1 ? "s have" : " has";
1016 $CPAN::Frontend->myprint(qq{$version_undefs installed module$s_has no }.
1017 qq{parsable version number\n});
1018 if ($CPAN::Config->{show_unparsable_versions}) {
1020 $CPAN::Frontend->myprint(qq{ they are\n\t@version_undefs\n});
1021 $CPAN::Frontend->myprint(qq{(use 'o conf show_unparsable_versions 0' }.
1022 qq{to hide them)\n});
1024 $CPAN::Frontend->myprint(qq{(use 'o conf show_unparsable_versions 1' }.
1025 qq{to show them)\n});
1032 #-> sub CPAN::Shell::r ;
1034 shift->_u_r_common("r",@_);
1037 #-> sub CPAN::Shell::u ;
1039 shift->_u_r_common("u",@_);
1042 #-> sub CPAN::Shell::failed ;
1044 my($self,$only_id,$silent) = @_;
1046 DIST: for my $d ($CPAN::META->all_objects("CPAN::Distribution")) {
1048 NAY: for my $nosayer ( # order matters!
1057 next unless exists $d->{$nosayer};
1058 next unless defined $d->{$nosayer};
1060 UNIVERSAL::can($d->{$nosayer},"failed") ?
1061 $d->{$nosayer}->failed :
1062 $d->{$nosayer} =~ /^NO/
1064 next NAY if $only_id && $only_id != (
1065 UNIVERSAL::can($d->{$nosayer},"commandid")
1067 $d->{$nosayer}->commandid
1069 $CPAN::CurrentCommandId
1074 next DIST unless $failed;
1078 # " %-45s: %s %s\n",
1081 UNIVERSAL::can($d->{$failed},"failed") ?
1083 $d->{$failed}->commandid,
1086 $d->{$failed}->text,
1087 $d->{$failed}{TIME}||0,
1100 $scope = "this command";
1101 } elsif ($CPAN::Index::HAVE_REANIMATED) {
1102 $scope = "this or a previous session";
1103 # it might be nice to have a section for previous session and
1106 $scope = "this session";
1113 map { sprintf "%5d %-45s: %s %s\n", @$_ }
1114 sort { $a->[0] <=> $b->[0] } @failed;
1117 map { sprintf " %-45s: %s %s\n", @$_[1..3] }
1124 $CPAN::Frontend->myprint("Failed during $scope:\n$print");
1125 } elsif (!$only_id || !$silent) {
1126 $CPAN::Frontend->myprint("Nothing failed in $scope\n");
1130 # XXX intentionally undocumented because completely bogus, unportable,
1133 #-> sub CPAN::Shell::status ;
1136 require Devel::Size;
1137 my $ps = FileHandle->new;
1138 open $ps, "/proc/$$/status";
1141 next unless /VmSize:\s+(\d+)/;
1145 $CPAN::Frontend->mywarn(sprintf(
1146 "%-27s %6d\n%-27s %6d\n",
1150 Devel::Size::total_size($CPAN::META)/1024,
1152 for my $k (sort keys %$CPAN::META) {
1153 next unless substr($k,0,4) eq "read";
1154 warn sprintf " %-26s %6d\n", $k, Devel::Size::total_size($CPAN::META->{$k})/1024;
1155 for my $k2 (sort keys %{$CPAN::META->{$k}}) {
1156 warn sprintf " %-25s %6d (keys: %6d)\n",
1158 Devel::Size::total_size($CPAN::META->{$k}{$k2})/1024,
1159 scalar keys %{$CPAN::META->{$k}{$k2}};
1164 # compare with install_tested
1165 #-> sub CPAN::Shell::is_tested
1168 CPAN::Index->reload;
1169 for my $b (reverse $CPAN::META->_list_sorted_descending_is_tested) {
1171 if ($CPAN::META->{is_tested}{$b}) {
1172 $time = scalar(localtime $CPAN::META->{is_tested}{$b});
1174 $time = scalar localtime;
1177 $CPAN::Frontend->myprint(sprintf "%s %s\n", $time, $b);
1181 #-> sub CPAN::Shell::autobundle ;
1184 CPAN::HandleConfig->load unless $CPAN::Config_loaded++;
1185 my(@bundle) = $self->_u_r_common("a",@_);
1186 my($todir) = File::Spec->catdir($CPAN::Config->{'cpan_home'},"Bundle");
1187 File::Path::mkpath($todir);
1188 unless (-d $todir) {
1189 $CPAN::Frontend->myprint("Couldn't mkdir $todir for some reason\n");
1192 my($y,$m,$d) = (localtime)[5,4,3];
1196 my($me) = sprintf "Snapshot_%04d_%02d_%02d_%02d", $y, $m, $d, $c;
1197 my($to) = File::Spec->catfile($todir,"$me.pm");
1199 $me = sprintf "Snapshot_%04d_%02d_%02d_%02d", $y, $m, $d, ++$c;
1200 $to = File::Spec->catfile($todir,"$me.pm");
1202 my($fh) = FileHandle->new(">$to") or Carp::croak "Can't open >$to: $!";
1204 "package Bundle::$me;\n\n",
1205 "\$VERSION = '0.01';\n\n",
1209 "Bundle::$me - Snapshot of installation on ",
1210 $Config::Config{'myhostname'},
1213 "\n\n=head1 SYNOPSIS\n\n",
1214 "perl -MCPAN -e 'install Bundle::$me'\n\n",
1215 "=head1 CONTENTS\n\n",
1216 join("\n", @bundle),
1217 "\n\n=head1 CONFIGURATION\n\n",
1219 "\n\n=head1 AUTHOR\n\n",
1220 "This Bundle has been generated automatically ",
1221 "by the autobundle routine in CPAN.pm.\n",
1224 $CPAN::Frontend->myprint("\nWrote bundle file
1228 #-> sub CPAN::Shell::expandany ;
1231 CPAN->debug("s[$s]") if $CPAN::DEBUG;
1232 if ($s =~ m|/| or substr($s,-1,1) eq ".") { # looks like a file or a directory
1233 $s = CPAN::Distribution->normalize($s);
1234 return $CPAN::META->instance('CPAN::Distribution',$s);
1235 # Distributions spring into existence, not expand
1236 } elsif ($s =~ m|^Bundle::|) {
1237 $self->local_bundles; # scanning so late for bundles seems
1238 # both attractive and crumpy: always
1239 # current state but easy to forget
1241 return $self->expand('Bundle',$s);
1243 return $self->expand('Module',$s)
1244 if $CPAN::META->exists('CPAN::Module',$s);
1249 #-> sub CPAN::Shell::expand ;
1252 my($type,@args) = @_;
1253 CPAN->debug("type[$type]args[@args]") if $CPAN::DEBUG;
1254 my $class = "CPAN::$type";
1255 my $methods = ['id'];
1256 for my $meth (qw(name)) {
1257 next unless $class->can($meth);
1258 push @$methods, $meth;
1260 $self->expand_by_method($class,$methods,@args);
1263 #-> sub CPAN::Shell::expand_by_method ;
1264 sub expand_by_method {
1266 my($class,$methods,@args) = @_;
1269 my($regex,$command);
1270 if ($arg =~ m|^/(.*)/$|) {
1272 # FIXME: there seem to be some ='s in the author data, which trigger
1273 # a failure here. This needs to be contemplated.
1274 # } elsif ($arg =~ m/=/) {
1278 CPAN->debug(sprintf "class[%s]regex[%s]command[%s]",
1280 defined $regex ? $regex : "UNDEFINED",
1281 defined $command ? $command : "UNDEFINED",
1283 if (defined $regex) {
1284 if (CPAN::_sqlite_running()) {
1285 CPAN::Index->reload;
1286 $CPAN::SQLite->search($class, $regex);
1289 $CPAN::META->all_objects($class)
1291 unless ($obj && UNIVERSAL::can($obj,"id") && $obj->id) {
1292 # BUG, we got an empty object somewhere
1293 require Data::Dumper;
1294 CPAN->debug(sprintf(
1295 "Bug in CPAN: Empty id on obj[%s][%s]",
1297 Data::Dumper::Dumper($obj)
1301 for my $method (@$methods) {
1302 my $match = eval {$obj->$method() =~ /$regex/i};
1304 my($err) = $@ =~ /^(.+) at .+? line \d+\.$/;
1305 $err ||= $@; # if we were too restrictive above
1306 $CPAN::Frontend->mydie("$err\n");
1313 } elsif ($command) {
1314 die "equal sign in command disabled (immature interface), ".
1316 ! \$CPAN::Shell::ADVANCED_QUERY=1
1317 to enable it. But please note, this is HIGHLY EXPERIMENTAL code
1318 that may go away anytime.\n"
1319 unless $ADVANCED_QUERY;
1320 my($method,$criterion) = $arg =~ /(.+?)=(.+)/;
1321 my($matchcrit) = $criterion =~ m/^~(.+)/;
1325 $CPAN::META->all_objects($class)
1327 my $lhs = $self->$method() or next; # () for 5.00503
1329 push @m, $self if $lhs =~ m/$matchcrit/;
1331 push @m, $self if $lhs eq $criterion;
1336 if ( $class eq 'CPAN::Bundle' ) {
1337 $xarg =~ s/^(Bundle::)?(.*)/Bundle::$2/;
1338 } elsif ($class eq "CPAN::Distribution") {
1339 $xarg = CPAN::Distribution->normalize($arg);
1343 if ($CPAN::META->exists($class,$xarg)) {
1344 $obj = $CPAN::META->instance($class,$xarg);
1345 } elsif ($CPAN::META->exists($class,$arg)) {
1346 $obj = $CPAN::META->instance($class,$arg);
1353 @m = sort {$a->id cmp $b->id} @m;
1354 if ( $CPAN::DEBUG ) {
1355 my $wantarray = wantarray;
1356 my $join_m = join ",", map {$_->id} @m;
1357 # $self->debug("wantarray[$wantarray]join_m[$join_m]");
1358 my $count = scalar @m;
1359 $self->debug("class[$class]wantarray[$wantarray]count m[$count]");
1361 return wantarray ? @m : $m[0];
1364 #-> sub CPAN::Shell::format_result ;
1367 my($type,@args) = @_;
1368 @args = '/./' unless @args;
1369 my(@result) = $self->expand($type,@args);
1370 my $result = @result == 1 ?
1371 $result[0]->as_string :
1373 "No objects of type $type found for argument @args\n" :
1375 (map {$_->as_glimpse} @result),
1376 scalar @result, " items found\n",
1381 #-> sub CPAN::Shell::report_fh ;
1383 my $installation_report_fh;
1384 my $previously_noticed = 0;
1387 return $installation_report_fh if $installation_report_fh;
1388 if ($CPAN::META->has_usable("File::Temp")) {
1389 $installation_report_fh
1391 dir => File::Spec->tmpdir,
1392 template => 'cpan_install_XXXX',
1397 unless ( $installation_report_fh ) {
1398 warn("Couldn't open installation report file; " .
1399 "no report file will be generated."
1400 ) unless $previously_noticed++;
1406 # The only reason for this method is currently to have a reliable
1407 # debugging utility that reveals which output is going through which
1408 # channel. No, I don't like the colors ;-)
1410 # to turn colordebugging on, write
1411 # cpan> o conf colorize_output 1
1413 #-> sub CPAN::Shell::colorize_output ;
1415 my $print_ornamented_have_warned = 0;
1416 sub colorize_output {
1417 my $colorize_output = $CPAN::Config->{colorize_output};
1418 if ($colorize_output && !$CPAN::META->has_inst("Term::ANSIColor")) {
1419 unless ($print_ornamented_have_warned++) {
1420 # no myprint/mywarn within myprint/mywarn!
1421 warn "Colorize_output is set to true but Term::ANSIColor is not
1422 installed. To activate colorized output, please install Term::ANSIColor.\n\n";
1424 $colorize_output = 0;
1426 return $colorize_output;
1431 #-> sub CPAN::Shell::print_ornamented ;
1432 sub print_ornamented {
1433 my($self,$what,$ornament) = @_;
1434 return unless defined $what;
1436 local $| = 1; # Flush immediately
1437 if ( $CPAN::Be_Silent ) {
1438 print {report_fh()} $what;
1441 my $swhat = "$what"; # stringify if it is an object
1442 if ($CPAN::Config->{term_is_latin}) {
1443 # note: deprecated, need to switch to $LANG and $LC_*
1446 =~ s{([\xC0-\xDF])([\x80-\xBF])}{chr(ord($1)<<6&0xC0|ord($2)&0x3F)}eg; #};
1448 if ($self->colorize_output) {
1449 if ( $CPAN::DEBUG && $swhat =~ /^Debug\(/ ) {
1450 # if you want to have this configurable, please file a bugreport
1451 $ornament = $CPAN::Config->{colorize_debug} || "black on_cyan";
1453 my $color_on = eval { Term::ANSIColor::color($ornament) } || "";
1455 print "Term::ANSIColor rejects color[$ornament]: $@\n
1456 Please choose a different color (Hint: try 'o conf init /color/')\n";
1458 # GGOLDBACH/Test-GreaterVersion-0.008 broke without this
1459 # $trailer construct. We want the newline be the last thing if
1460 # there is a newline at the end ensuring that the next line is
1461 # empty for other players
1463 $trailer = $1 if $swhat =~ s/([\r\n]+)\z//;
1466 Term::ANSIColor::color("reset"),
1473 #-> sub CPAN::Shell::myprint ;
1475 # where is myprint/mywarn/Frontend/etc. documented? Where to use what?
1476 # I think, we send everything to STDOUT and use print for normal/good
1477 # news and warn for news that need more attention. Yes, this is our
1478 # working contract for now.
1480 my($self,$what) = @_;
1481 $self->print_ornamented($what,
1482 $CPAN::Config->{colorize_print}||'bold blue on_white',
1487 my($self,$category,$what) = @_;
1488 my $vname = $category . "_verbosity";
1489 CPAN::HandleConfig->load unless $CPAN::Config_loaded++;
1490 if (!$CPAN::Config->{$vname}
1491 || $CPAN::Config->{$vname} =~ /^v/
1493 $CPAN::Frontend->myprint($what);
1497 #-> sub CPAN::Shell::myexit ;
1499 my($self,$what) = @_;
1500 $self->myprint($what);
1504 #-> sub CPAN::Shell::mywarn ;
1506 my($self,$what) = @_;
1507 $self->print_ornamented($what, $CPAN::Config->{colorize_warn}||'bold red on_white');
1510 # only to be used for shell commands
1511 #-> sub CPAN::Shell::mydie ;
1513 my($self,$what) = @_;
1514 $self->mywarn($what);
1516 # If it is the shell, we want the following die to be silent,
1517 # but if it is not the shell, we would need a 'die $what'. We need
1518 # to take care that only shell commands use mydie. Is this
1524 # sub CPAN::Shell::colorable_makemaker_prompt ;
1525 sub colorable_makemaker_prompt {
1527 if (CPAN::Shell->colorize_output) {
1528 my $ornament = $CPAN::Config->{colorize_print}||'bold blue on_white';
1529 my $color_on = eval { Term::ANSIColor::color($ornament); } || "";
1532 my $ans = ExtUtils::MakeMaker::prompt($foo,$bar);
1533 if (CPAN::Shell->colorize_output) {
1534 print Term::ANSIColor::color('reset');
1539 # use this only for unrecoverable errors!
1540 #-> sub CPAN::Shell::unrecoverable_error ;
1541 sub unrecoverable_error {
1542 my($self,$what) = @_;
1543 my @lines = split /\n/, $what;
1545 for my $l (@lines) {
1546 $longest = length $l if length $l > $longest;
1548 $longest = 62 if $longest > 62;
1549 for my $l (@lines) {
1550 if ($l =~ /^\s*$/) {
1555 if (length $l < 66) {
1556 $l = pack "A66 A*", $l, "<==";
1560 unshift @lines, "\n";
1561 $self->mydie(join "", @lines);
1564 #-> sub CPAN::Shell::mysleep ;
1566 my($self, $sleep) = @_;
1567 if (CPAN->has_inst("Time::HiRes")) {
1568 Time::HiRes::sleep($sleep);
1570 sleep($sleep < 1 ? 1 : int($sleep + 0.5));
1574 #-> sub CPAN::Shell::setup_output ;
1576 return if -t STDOUT;
1577 my $odef = select STDERR;
1584 #-> sub CPAN::Shell::rematein ;
1585 # RE-adme||MA-ke||TE-st||IN-stall : nearly everything runs through here
1588 my($meth,@some) = @_;
1590 while($meth =~ /^(ff?orce|notest)$/) {
1591 push @pragma, $meth;
1592 $meth = shift @some or
1593 $CPAN::Frontend->mydie("Pragma $pragma[-1] used without method: ".
1597 CPAN->debug("pragma[@pragma]meth[$meth]some[@some]") if $CPAN::DEBUG;
1599 # Here is the place to set "test_count" on all involved parties to
1600 # 0. We then can pass this counter on to the involved
1601 # distributions and those can refuse to test if test_count > X. In
1602 # the first stab at it we could use a 1 for "X".
1604 # But when do I reset the distributions to start with 0 again?
1605 # Jost suggested to have a random or cycling interaction ID that
1606 # we pass through. But the ID is something that is just left lying
1607 # around in addition to the counter, so I'd prefer to set the
1608 # counter to 0 now, and repeat at the end of the loop. But what
1609 # about dependencies? They appear later and are not reset, they
1610 # enter the queue but not its copy. How do they get a sensible
1613 # With configure_requires, "get" is vulnerable in recursion.
1615 my $needs_recursion_protection = "get|make|test|install";
1617 # construct the queue
1619 STHING: foreach $s (@some) {
1622 CPAN->debug("s is an object[$s]") if $CPAN::DEBUG;
1624 } elsif ($s =~ m|[\$\@\%]|) { # looks like a perl variable
1625 } elsif ($s =~ m|^/|) { # looks like a regexp
1626 if (substr($s,-1,1) eq ".") {
1627 $obj = CPAN::Shell->expandany($s);
1629 $CPAN::Frontend->mywarn("Sorry, $meth with a regular expression is ".
1630 "not supported.\nRejecting argument '$s'\n");
1631 $CPAN::Frontend->mysleep(2);
1634 } elsif ($meth eq "ls") {
1635 $self->globls($s,\@pragma);
1638 CPAN->debug("calling expandany [$s]") if $CPAN::DEBUG;
1639 $obj = CPAN::Shell->expandany($s);
1642 } elsif (ref $obj) {
1643 if ($meth =~ /^($needs_recursion_protection)$/) {
1644 # it would be silly to check for recursion for look or dump
1645 # (we are in CPAN::Shell::rematein)
1646 CPAN->debug("Going to test against recursion") if $CPAN::DEBUG;
1647 eval { $obj->color_cmd_tmps(0,1); };
1650 and $@->isa("CPAN::Exception::RecursiveDependency")) {
1651 $CPAN::Frontend->mywarn($@);
1655 Carp::confess(sprintf "DEBUG: \$\@[%s]ref[%s]", $@, ref $@);
1661 CPAN::Queue->queue_item(qmod => $obj->id, reqtype => "c");
1663 } elsif ($CPAN::META->exists('CPAN::Author',uc($s))) {
1664 $obj = $CPAN::META->instance('CPAN::Author',uc($s));
1665 if ($meth =~ /^(dump|ls|reports)$/) {
1668 $CPAN::Frontend->mywarn(
1670 "Don't be silly, you can't $meth ",
1674 $CPAN::Frontend->mysleep(2);
1676 } elsif ($s =~ m|[\$\@\%]| && $meth eq "dump") {
1677 CPAN::InfoObj->dump($s);
1680 ->mywarn(qq{Warning: Cannot $meth $s, }.
1681 qq{don't know what it is.
1686 to find objects with matching identifiers.
1688 $CPAN::Frontend->mysleep(2);
1692 # queuerunner (please be warned: when I started to change the
1693 # queue to hold objects instead of names, I made one or two
1694 # mistakes and never found which. I reverted back instead)
1695 QITEM: while (my $q = CPAN::Queue->first) {
1697 my $s = $q->as_string;
1698 my $reqtype = $q->reqtype || "";
1699 $obj = CPAN::Shell->expandany($s);
1701 # don't know how this can happen, maybe we should panic,
1702 # but maybe we get a solution from the first user who hits
1703 # this unfortunate exception?
1704 $CPAN::Frontend->mywarn("Warning: Could not expand string '$s' ".
1705 "to an object. Skipping.\n");
1706 $CPAN::Frontend->mysleep(5);
1707 CPAN::Queue->delete_first($s);
1710 $obj->{reqtype} ||= "";
1712 # force debugging because CPAN::SQLite somehow delivers us
1715 # local $CPAN::DEBUG = 1024; # Shell; probably fixed now
1717 CPAN->debug("s[$s]obj-reqtype[$obj->{reqtype}]".
1718 "q-reqtype[$reqtype]") if $CPAN::DEBUG;
1720 if ($obj->{reqtype}) {
1721 if ($obj->{reqtype} eq "b" && $reqtype =~ /^[rc]$/) {
1722 $obj->{reqtype} = $reqtype;
1724 exists $obj->{install}
1727 UNIVERSAL::can($obj->{install},"failed") ?
1728 $obj->{install}->failed :
1729 $obj->{install} =~ /^NO/
1732 delete $obj->{install};
1733 $CPAN::Frontend->mywarn
1734 ("Promoting $obj->{ID} from 'build_requires' to 'requires'");
1738 $obj->{reqtype} = $reqtype;
1741 for my $pragma (@pragma) {
1744 $obj->can($pragma)) {
1745 $obj->$pragma($meth);
1748 if (UNIVERSAL::can($obj, 'called_for')) {
1749 $obj->called_for($s);
1751 CPAN->debug(qq{pragma[@pragma]meth[$meth]}.
1752 qq{ID[$obj->{ID}]}) if $CPAN::DEBUG;
1755 if ($meth =~ /^(report)$/) { # they came here with a pragma?
1757 } elsif (! UNIVERSAL::can($obj,$meth)) {
1759 my $serialized = "";
1761 } elsif ($CPAN::META->has_inst("YAML::Syck")) {
1762 $serialized = YAML::Syck::Dump($obj);
1763 } elsif ($CPAN::META->has_inst("YAML")) {
1764 $serialized = YAML::Dump($obj);
1765 } elsif ($CPAN::META->has_inst("Data::Dumper")) {
1766 $serialized = Data::Dumper::Dumper($obj);
1769 $serialized = overload::StrVal($obj);
1771 CPAN->debug("Going to panic. meth[$meth]s[$s]") if $CPAN::DEBUG;
1772 $CPAN::Frontend->mydie("Panic: obj[$serialized] cannot meth[$meth]");
1773 } elsif ($obj->$meth()) {
1774 CPAN::Queue->delete($s);
1775 CPAN->debug("From queue deleted. meth[$meth]s[$s]") if $CPAN::DEBUG;
1777 CPAN->debug("Failed. pragma[@pragma]meth[$meth]") if $CPAN::DEBUG;
1781 for my $pragma (@pragma) {
1782 my $unpragma = "un$pragma";
1783 if ($obj->can($unpragma)) {
1787 if ($CPAN::Config->{halt_on_failure}
1789 CPAN::Distrostatus::something_has_just_failed()
1791 $CPAN::Frontend->mywarn("Stopping: '$meth' failed for '$s'.\n");
1792 CPAN::Queue->nullify_queue;
1795 CPAN::Queue->delete_first($s);
1797 if ($meth =~ /^($needs_recursion_protection)$/) {
1798 for my $obj (@qcopy) {
1799 $obj->color_cmd_tmps(0,0);
1804 #-> sub CPAN::Shell::recent ;
1807 if ($CPAN::META->has_inst("XML::LibXML")) {
1808 my $url = $CPAN::Defaultrecent;
1809 $CPAN::Frontend->myprint("Going to fetch '$url'\n");
1810 unless ($CPAN::META->has_usable("LWP")) {
1811 $CPAN::Frontend->mydie("LWP not installed; cannot continue");
1813 CPAN::LWP::UserAgent->config;
1815 eval { $Ua = CPAN::LWP::UserAgent->new; };
1817 $CPAN::Frontend->mydie("CPAN::LWP::UserAgent->new dies with $@\n");
1819 my $resp = $Ua->get($url);
1820 unless ($resp->is_success) {
1821 $CPAN::Frontend->mydie(sprintf "Could not download '%s': %s\n", $url, $resp->code);
1823 $CPAN::Frontend->myprint("DONE\n\n");
1824 my $xml = XML::LibXML->new->parse_string($resp->content);
1826 my $s = $xml->serialize(2);
1827 $s =~ s/\n\s*\n/\n/g;
1828 $CPAN::Frontend->myprint($s);
1832 if ($url =~ /winnipeg/) {
1833 my $pubdate = $xml->findvalue("/rss/channel/pubDate");
1834 $CPAN::Frontend->myprint(" pubDate: $pubdate\n\n");
1835 for my $eitem ($xml->findnodes("/rss/channel/item")) {
1836 my $distro = $eitem->findvalue("enclosure/\@url");
1837 $distro =~ s|.*?/authors/id/./../||;
1838 my $size = $eitem->findvalue("enclosure/\@length");
1839 my $desc = $eitem->findvalue("description");
1840 $desc =~ s/.+? - //;
1841 $CPAN::Frontend->myprint("$distro [$size b]\n $desc\n");
1842 push @distros, $distro;
1844 } elsif ($url =~ /search.*uploads.rdf/) {
1845 # xmlns:rdf="http://www.w3.org/1999/02/22-rdf-syntax-ns#"
1846 # xmlns="http://purl.org/rss/1.0/"
1847 # xmlns:taxo="http://purl.org/rss/1.0/modules/taxonomy/"
1848 # xmlns:dc="http://purl.org/dc/elements/1.1/"
1849 # xmlns:syn="http://purl.org/rss/1.0/modules/syndication/"
1850 # xmlns:admin="http://webns.net/mvcb/"
1853 my $dc_date = $xml->findvalue("//*[local-name(.) = 'RDF']/*[local-name(.) = 'channel']/*[local-name(.) = 'date']");
1854 $CPAN::Frontend->myprint(" dc:date: $dc_date\n\n");
1855 my $finish_eitem = 0;
1856 local $SIG{INT} = sub { $finish_eitem = 1 };
1857 EITEM: for my $eitem ($xml->findnodes("//*[local-name(.) = 'RDF']/*[local-name(.) = 'item']")) {
1858 my $distro = $eitem->findvalue("\@rdf:about");
1859 $distro =~ s|.*~||; # remove up to the tilde before the name
1860 $distro =~ s|/$||; # remove trailing slash
1861 $distro =~ s|([^/]+)|\U$1\E|; # upcase the name
1862 my $author = uc $1 or die "distro[$distro] without author, cannot continue";
1863 my $desc = $eitem->findvalue("*[local-name(.) = 'description']");
1865 SUBDIRTEST: while () {
1866 last SUBDIRTEST if ++$i >= 6; # half a dozen must do!
1867 if (my @ret = $self->globls("$distro*")) {
1868 @ret = grep {$_->[2] !~ /meta/} @ret;
1869 @ret = grep {length $_->[2]} @ret;
1871 $distro = "$author/$ret[0][2]";
1875 $distro =~ s|/|/*/|; # allow it to reside in a subdirectory
1878 next EITEM if $distro =~ m|\*|; # did not find the thing
1879 $CPAN::Frontend->myprint("____$desc\n");
1880 push @distros, $distro;
1881 last EITEM if $finish_eitem;
1886 # deprecated old version
1887 $CPAN::Frontend->mydie("no XML::LibXML installed, cannot continue\n");
1891 #-> sub CPAN::Shell::smoke ;
1894 my $distros = $self->recent;
1895 DISTRO: for my $distro (@$distros) {
1896 next if $distro =~ m|/Bundle-|; # XXX crude heuristic to skip bundles
1897 $CPAN::Frontend->myprint(sprintf "Going to download and test '$distro'\n");
1900 local $SIG{INT} = sub { $skip = 1 };
1902 $CPAN::Frontend->myprint(sprintf "\r%2d (Hit ^C to skip)", 10-$_);
1905 $CPAN::Frontend->myprint(" skipped\n");
1910 $CPAN::Frontend->myprint("\r \n"); # leave the dirty line with a newline
1911 $self->test($distro);
1916 # set up the dispatching methods
1918 for my $command (qw(
1935 *$command = sub { shift->rematein($command, @_); };