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