This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
https://perl5.git.perl.org / perl5.git / blame
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | blame (incremental) | history | HEAD
[PATCH] Update CPAN.pm to 1.93_52
[perl5.git] / lib / CPAN / Shell.pm
CommitLineData
f9916dde
A		 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",
2f2071b1
A		 20 "CPAN/Author.pm",
21 "CPAN/CacheMgr.pm",
22 "CPAN/Complete.pm",
f9916dde 23 "CPAN/Debug.pm",
2f2071b1
A		 24 "CPAN/DeferredCode.pm",
25 "CPAN/Distribution.pm",
f9916dde 26 "CPAN/Distroprefs.pm",
2f2071b1
A		 27 "CPAN/Distrostatus.pm",
28 "CPAN/Exception/RecursiveDependency.pm",
29 "CPAN/Exception/yaml_not_installed.pm",
f9916dde 30 "CPAN/FirstTime.pm",
2f2071b1
A		 31 "CPAN/FTP.pm",
32 "CPAN/FTP/netrc.pm",
f9916dde 33 "CPAN/HandleConfig.pm",
2f2071b1
A		 34 "CPAN/Index.pm",
35 "CPAN/InfoObj.pm",
f9916dde 36 "CPAN/Kwalify.pm",
2f2071b1
A		 37 "CPAN/LWP/UserAgent.pm",
38 "CPAN/Module.pm",
39 "CPAN/Prompt.pm",
f9916dde
A		 40 "CPAN/Queue.pm",
41 "CPAN/Reporter/Config.pm",
42 "CPAN/Reporter/History.pm",
43 "CPAN/Reporter/PrereqCheck.pm",
44 "CPAN/Reporter.pm",
2f2071b1 45 "CPAN/Shell.pm",
f9916dde
A		 46 "CPAN/SQLite.pm",
47 "CPAN/Tarzip.pm",
48 "CPAN/Version.pm",
49 );
50$VERSION = "5.5";
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
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
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 (upto 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 }
2f2071b1 274 CPAN->debug("author[$author]pathglob[$pathglob]silent[$silent]") if $CPAN::DEBUG;
f9916dde
A		 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 $CPAN::Frontend->myprint($self->format_result('Module',@_));
329}
330
331#-> sub CPAN::Shell::i ;
332sub i {
333 my($self) = shift;
334 my(@args) = @_;
335 @args = '/./' unless @args;
336 my(@result);
337 for my $type (qw/Bundle Distribution Module/) {
338 push @result, $self->expand($type,@args);
339 }
340 # Authors are always uppercase.
341 push @result, $self->expand("Author", map { uc $_ } @args);
342
343 my $result = @result == 1 ?
344 $result[0]->as_string :
345 @result == 0 ?
346 "No objects found of any type for argument @args\n" :
347 join("",
348 (map {$_->as_glimpse} @result),
349 scalar @result, " items found\n",
350 );
351 $CPAN::Frontend->myprint($result);
352}
353
354#-> sub CPAN::Shell::o ;
355
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
360sub o {
361 my($self,$o_type,@o_what) = @_;
362 $o_type ||= "";
363 CPAN->debug("o_type[$o_type] o_what[".join(" | ",@o_what)."]\n");
364 if ($o_type eq 'conf') {
365 my($cfilter);
366 ($cfilter) = $o_what[0] =~ m|^/(.*)/$| if @o_what;
367 if (!@o_what or $cfilter) { # print all things, "o conf"
368 $cfilter ||= "";
369 my $qrfilter = eval 'qr/$cfilter/';
370 my($k,$v);
371 $CPAN::Frontend->myprint("\$CPAN::Config options from ");
372 my @from;
373 if (exists $INC{'CPAN/Config.pm'}) {
374 push @from, $INC{'CPAN/Config.pm'};
375 }
376 if (exists $INC{'CPAN/MyConfig.pm'}) {
377 push @from, $INC{'CPAN/MyConfig.pm'};
378 }
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);
385 }
386 $CPAN::Frontend->myprint("\n");
387 for $k (sort keys %CPAN::HandleConfig::keys) {
388 next unless $k =~ /$qrfilter/;
389 CPAN::HandleConfig->prettyprint($k);
390 }
391 $CPAN::Frontend->myprint("\n");
392 } else {
393 if (CPAN::HandleConfig->edit(@o_what)) {
394 } else {
395 $CPAN::Frontend->myprint(qq{Type 'o conf' to view all configuration }.
396 qq{items\n\n});
397 }
398 }
399 } elsif ($o_type eq 'debug') {
400 my(%valid);
401 @o_what = () if defined $o_what[0] && $o_what[0] =~ /help/i;
402 if (@o_what) {
403 while (@o_what) {
404 my($what) = shift @o_what;
405 if ($what =~ s/^-// && exists $CPAN::DEBUG{$what}) {
406 $CPAN::DEBUG &= $CPAN::DEBUG ^ $CPAN::DEBUG{$what};
407 next;
408 }
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') {
414 my($max) = 0;
415 for (values %CPAN::DEBUG) {
416 $max += $_;
417 }
418 $CPAN::DEBUG = $max;
419 } else {
420 my($known) = 0;
421 for (keys %CPAN::DEBUG) {
422 next unless lc($_) eq lc($what);
423 $CPAN::DEBUG |= $CPAN::DEBUG{$_};
424 $known = 1;
425 }
426 $CPAN::Frontend->myprint("unknown argument [$what]\n")
427 unless $known;
428 }
429 }
430 } else {
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.};
435 require Text::Wrap;
436 $CPAN::Frontend->myprint(Text::Wrap::fill("","",$raw));
437 $CPAN::Frontend->myprint("\n\n");
438 }
439 if ($CPAN::DEBUG) {
440 $CPAN::Frontend->myprint("Options set for debugging ($CPAN::DEBUG):\n");
441 my($k,$v);
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;
446 }
447 } else {
448 $CPAN::Frontend->myprint("Debugging turned off completely.\n");
449 }
450 } else {
451 $CPAN::Frontend->myprint(qq{
452Known options:
453 conf set or get configuration variables
454 debug set or get debugging options
455});
456 }
457}
458
459# CPAN::Shell::paintdots_onreload
460sub paintdots_onreload {
461 my($ref) = shift;
462 sub {
463 if ( $_[0] =~ /[Ss]ubroutine ([\w:]+) redefined/ ) {
464 my($subr) = $1;
465 ++$$ref;
466 local($|) = 1;
467 # $CPAN::Frontend->myprint(".($subr)");
468 $CPAN::Frontend->myprint(".");
469 if ($subr =~ /\bshell\b/i) {
470 # warn "debug[$_[0]]";
471
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
475
476 $CPAN::GOTOSHELL=1;
477 }
478 return;
479 }
480 warn @_;
481 };
482}
483
484#-> sub CPAN::Shell::hosts ;
485sub hosts {
486 my($self) = @_;
487 my $fullstats = CPAN::FTP->_ftp_statistics();
488 my $history = $fullstats->{history} || [];
489 my %S; # statistics
490 while (my $last = pop @$history) {
491 my $attempts = $last->{attempts} or next;
492 my $start;
493 if (@$attempts) {
494 $start = $attempts->[-1]{start};
495 if ($#$attempts > 0) {
496 for my $i (0..$#$attempts-1) {
497 my $url = $attempts->[$i]{url} or next;
498 $S{no}{$url}++;
499 }
500 }
501 } else {
502 $start = $last->{start};
503 }
504 next unless $last->{thesiteurl}; # C-C? bad filenames?
505 $S{start} = $start;
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} ||= {};
511 $s->{n}++;
512 $s->{dlsize} ||= 0;
513 $s->{dlsize} += $dlsize/1024;
514 $s->{dltime} ||= 0;
515 $s->{dltime} += $dltime;
516 }
517 my $res;
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},
522 $url,
523 ];
524 }
525 for my $url (keys %{$S{no}}) {
526 push @{$res->{no}}, [$S{no}{$url},
527 $url,
528 ];
529 }
530 my $R = ""; # report
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";
534 }
535 if ($res->{ok} && @{$res->{ok}}) {
536 $R .= sprintf "\nSuccessful downloads:
537 N kB secs kB/s url\n";
538 my $i = 20;
539 for (sort { $b->[3] <=> $a->[3] } @{$res->{ok}}) {
540 $R .= sprintf "%4d %8d %5d %9.1f %s\n", @$_;
541 last if --$i<=0;
542 }
543 }
544 if ($res->{no} && @{$res->{no}}) {
545 $R .= sprintf "\nUnsuccessful downloads:\n";
546 my $i = 20;
547 for (sort { $b->[0] <=> $a->[0] } @{$res->{no}}) {
548 $R .= sprintf "%4d %s\n", @$_;
549 last if --$i<=0;
550 }
551 }
552 $CPAN::Frontend->myprint($R);
553}
554
555# here is where 'reload cpan' is done
556#-> sub CPAN::Shell::reload ;
557sub reload {
558 my($self,$command,@arg) = @_;
559 $command ||= "";
560 $self->debug("self[$self]command[$command]arg[@arg]") if $CPAN::DEBUG;
561 if ($command =~ /^cpan$/i) {
562 my $redef = 0;
563 chdir $CPAN::iCwd if $CPAN::iCwd; # may fail
564 my $failed;
565 MFILE: for my $f (@relo) {
566 next unless exists $INC{$f};
567 my $p = $f;
568 $p =~ s/\.pm$//;
569 $p =~ s|/|::|g;
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)");
575 }
576 $CPAN::Frontend->myprint("\n$redef subroutines redefined\n");
577 if ($failed) {
578 my $errors = $failed == 1 ? "error" : "errors";
579 $CPAN::Frontend->mywarn("\n$failed $errors during reload. You better quit ".
580 "this session.\n");
581 }
582 } elsif ($command =~ /^index$/i) {
583 CPAN::Index->force_reload;
584 } else {
585 $CPAN::Frontend->myprint(qq{cpan re-evals the CPAN modules
586index re-reads the index files\n});
587 }
588}
589
590# reload means only load again what we have loaded before
591#-> sub CPAN::Shell::_reload_this ;
592sub _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
596 # reload but say OK
597 my $pwd = CPAN::anycwd();
598 CPAN->debug("pwd[$pwd]") if $CPAN::DEBUG;
599 my($file);
600 for my $inc (@INC) {
601 $file = File::Spec->catfile($inc,split /\//, $f);
602 last if -f $file;
603 $file = "";
604 }
605 CPAN->debug("file[$file]") if $CPAN::DEBUG;
606 my @inc = @INC;
607 unless ($file && -f $file) {
608 # this thingie is not in the INC path, maybe CPAN/MyConfig.pm?
609 $file = $INC{$f};
610 unless (CPAN->has_inst("File::Basename")) {
611 @inc = File::Basename::dirname($file);
612 } else {
613 # do we ever need this?
614 @inc = substr($file,0,-length($f)-1); # bring in back to me!
615 }
616 }
617 CPAN->debug("file[$file]inc[@inc]") if $CPAN::DEBUG;
618 unless (-f $file) {
619 $CPAN::Frontend->mywarn("Found no file to reload for '$f'\n");
620 return;
621 }
622 my $mtime = (stat $file)[9];
623 $reload->{$f} ||= -1;
624 my $must_reload = $mtime != $reload->{$f};
625 $args ||= {};
626 $must_reload ||= $args->{reloforce}; # o conf defaults needs this
627 if ($must_reload) {
628 my $fh = FileHandle->new($file) or
629 $CPAN::Frontend->mydie("Could not open $file: $!");
630 local($/);
631 local $^W = 1;
632 my $content = <$fh>;
633 CPAN->debug(sprintf("reload file[%s] content[%s...]",$file,substr($content,0,128)))
634 if $CPAN::DEBUG;
635 delete $INC{$f};
636 local @INC = @inc;
637 eval "require '$f'";
638 if ($@) {
639 warn $@;
640 return;
641 }
642 $reload->{$f} = $mtime;
643 } else {
644 $CPAN::Frontend->myprint("__unchanged__");
645 }
646 return 1;
647}
648
649#-> sub CPAN::Shell::mkmyconfig ;
650sub 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 ||= {};
659 $CPAN::Config = {
660 %$CPAN::Config,
661 build_dir => undef,
662 cpan_home => undef,
663 keep_source_where => undef,
664 histfile => undef,
665 };
666 CPAN::FirstTime::init($cpanpm, %args);
667}
668
669#-> sub CPAN::Shell::_binary_extensions ;
670sub _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;
680 local($|) = 1;
681 $CPAN::Frontend->myprint(".");
682 push @result, $module;
683 }
684# print join " | ", @result;
685 $CPAN::Frontend->myprint("\n");
686 return @result;
687}
688
689#-> sub CPAN::Shell::recompile ;
690sub 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
695 # don't do it twice
696 $cpan_file = $module->cpan_file;
697 my $pack = $CPAN::META->instance('CPAN::Distribution',$cpan_file);
698 $pack->force;
699 $dist{$cpan_file}++;
700 }
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);
704 $pack->install;
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
708 }
709}
710
711#-> sub CPAN::Shell::scripts ;
712sub scripts {
713 my($self, $arg) = @_;
714 $CPAN::Frontend->mywarn(">>>> experimental command, currently unsupported <<<<\n\n");
715
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");
719 }
720 }
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");
725 }
726 $p->parse_file($indexfile);
727 my @hrefs;
728 my $qrarg;
729 if ($arg =~ s|^/(.+)/$|$1|) {
730 $qrarg = eval 'qr/$arg/'; # hide construct from 5.004
731 }
732 for my $l ($p->links) {
733 my $tag = shift @$l;
734 next unless $tag eq "a";
735 my %att = @$l;
736 my $href = $att{href};
737 next unless $href =~ s|^\.\./authors/id/./../||;
738 if ($arg) {
739 if ($qrarg) {
740 if ($href =~ $qrarg) {
741 push @hrefs, $href;
742 }
743 } else {
744 if ($href =~ /\Q$arg\E/) {
745 push @hrefs, $href;
746 }
747 }
748 } else {
749 push @hrefs, $href;
750 }
751 }
752 # now filter for the latest version if there is more than one of a name
753 my %stems;
754 for (sort @hrefs) {
755 my $href = $_;
756 s/-v?\d.*//;
757 my $stem = $_;
758 $stems{$stem} ||= [];
759 push @{$stems{$stem}}, $href;
760 }
761 for (sort keys %stems) {
762 my $highest;
763 if (@{$stems{$_}} > 1) {
764 $highest = List::Util::reduce {
765 Sort::Versions::versioncmp($a,$b) > 0 ? $a : $b
766 } @{$stems{$_}};
767 } else {
768 $highest = $stems{$_}[0];
769 }
770 $CPAN::Frontend->myprint("$highest\n");
771 }
772}
773
774#-> sub CPAN::Shell::report ;
775sub report {
776 my($self,@args) = @_;
777 unless ($CPAN::META->has_inst("CPAN::Reporter")) {
778 $CPAN::Frontend->mydie("CPAN::Reporter not installed; cannot continue");
779 }
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)
783}
784
785# compare with is_tested
786#-> sub CPAN::Shell::install_tested
787sub install_tested {
788 my($self,@some) = @_;
789 $CPAN::Frontend->mywarn("install_tested() must not be called with arguments.\n"),
790 return if @some;
791 CPAN::Index->reload;
792
793 for my $b (reverse $CPAN::META->_list_sorted_descending_is_tested) {
794 my $yaml = "$b.yml";
795 unless (-f $yaml) {
796 $CPAN::Frontend->mywarn("No YAML file for $b available, skipping\n");
797 next;
798 }
799 my $yaml_content = CPAN->_yaml_loadfile($yaml);
800 my $id = $yaml_content->[0]{distribution}{ID};
801 unless ($id) {
802 $CPAN::Frontend->mywarn("No ID found in '$yaml', skipping\n");
803 next;
804 }
805 my $do = CPAN::Shell->expandany($id);
806 unless ($do) {
807 $CPAN::Frontend->mywarn("Could not expand ID '$id', skipping\n");
808 next;
809 }
810 unless ($do->{build_dir}) {
811 $CPAN::Frontend->mywarn("Distro '$id' has no build_dir, skipping\n");
812 next;
813 }
814 unless ($do->{build_dir} eq $b) {
815 $CPAN::Frontend->mywarn("Distro '$id' has build_dir '$do->{build_dir}' but expected '$b', skipping\n");
816 next;
817 }
818 push @some, $do;
819 }
820
821 $CPAN::Frontend->mywarn("No tested distributions found.\n"),
822 return unless @some;
823
824 @some = grep { $_->{make_test} && ! $_->{make_test}->failed } @some;
825 $CPAN::Frontend->mywarn("No distributions tested with this build of perl found.\n"),
826 return unless @some;
827
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;
831
832 CPAN->debug("some[@some]");
833 for my $d (@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);
837 $self->install($d);
838 }
839}
840
841#-> sub CPAN::Shell::upgrade ;
842sub upgrade {
843 my($self,@args) = @_;
844 $self->install($self->r(@args));
845}
846
847#-> sub CPAN::Shell::_u_r_common ;
848sub _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]$/;
854 my(@args) = @_;
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
863 # for metadata cache
864 my $expand = scalar @expand;
865 $CPAN::Frontend->myprint(sprintf "%d matches in the database, time[%d]\n", $expand, time);
866 }
867 my @sexpand;
868 if ($] < 5.008) {
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;
872 } else {
873 @sexpand = map {
874 $_->[1]
875 } sort {
876 $b->[0] <=> $a->[0]
877 ||
878 $a->[1]{ID} cmp $b->[1]{ID},
879 } map {
880 [$_->_is_representative_module,
881 $_
882 ]
883 } @expand;
884 }
885 if ($CPAN::DEBUG) {
886 $CPAN::Frontend->myprint(sprintf "sorted at time[%d]\n", time);
887 sleep 1;
888 }
889 MODULE: for $module (@sexpand) {
890 my $file = $module->cpan_file;
891 next MODULE unless defined $file; # ??
892 $file =~ s!^./../!!;
893 my($latest) = $module->cpan_version;
894 my($inst_file) = $module->inst_file;
895 CPAN->debug("file[$file]latest[$latest]") if $CPAN::DEBUG;
896 my($have);
897 return if $CPAN::Signal;
898 my($next_MODULE);
899 eval { # version.pm involved!
900 if ($inst_file) {
901 if ($what eq "a") {
902 $have = $module->inst_version;
903 } elsif ($what eq "r") {
904 $have = $module->inst_version;
905 local($^W) = 0;
906 if ($have eq "undef") {
907 $version_undefs++;
908 push @version_undefs, $module->as_glimpse;
909 } elsif (CPAN::Version->vcmp($have,0)==0) {
910 $version_zeroes++;
911 push @version_zeroes, $module->as_glimpse;
912 }
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") {
918 ++$next_MODULE;
919 }
920 } else {
921 if ($what eq "a") {
922 ++$next_MODULE;
923 } elsif ($what eq "r") {
924 ++$next_MODULE;
925 } elsif ($what eq "u") {
926 $have = "-";
927 }
928 }
929 };
930 next MODULE if $next_MODULE;
931 if ($@) {
932 $CPAN::Frontend->mywarn
933 (sprintf("Error while comparing cpan/installed versions of '%s':
934INST_FILE: %s
935INST_VERSION: %s %s
936CPAN_VERSION: %s %s
937",
938 $module->id,
939 $inst_file || "",
940 (defined $have ? $have : "[UNDEFINED]"),
941 (ref $have ? ref $have : ""),
942 $latest,
943 (ref $latest ? ref $latest : ""),
944 ));
945 next MODULE;
946 }
947 return if $CPAN::Signal; # this is sometimes lengthy
948 $seen{$file} ||= 0;
949 if ($what eq "a") {
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/;
958 }
959 unless ($headerdone++) {
960 $CPAN::Frontend->myprint("\n");
961 $CPAN::Frontend->myprint(sprintf(
962 $sprintf,
963 "",
964 "Package namespace",
965 "",
966 "installed",
967 "latest",
968 "in CPAN file"
969 ));
970 }
971 my $color_on = "";
972 my $color_off = "";
973 if (
974 $COLOR_REGISTERED
975 &&
976 $CPAN::META->has_inst("Term::ANSIColor")
977 &&
978 $module->description
979 ) {
980 $color_on = Term::ANSIColor::color("green");
981 $color_off = Term::ANSIColor::color("reset");
982 }
983 $CPAN::Frontend->myprint(sprintf $sprintf,
984 $color_on,
985 $module->id,
986 $color_off,
987 $have,
988 $latest,
989 $file);
990 $need{$module->id}++;
991 }
992 unless (%need) {
993 if ($what eq "u") {
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");
997 }
998 }
999 if ($what eq "r") {
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}) {
1005 local $" = "\t";
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});
1009 } else {
1010 $CPAN::Frontend->myprint(qq{(use 'o conf show_zero_versions 1' }.
1011 qq{to show them)\n});
1012 }
1013 }
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}) {
1019 local $" = "\t";
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});
1023 } else {
1024 $CPAN::Frontend->myprint(qq{(use 'o conf show_unparsable_versions 1' }.
1025 qq{to show them)\n});
1026 }
1027 }
1028 }
1029 @result;
1030}
1031
1032#-> sub CPAN::Shell::r ;
1033sub r {
1034 shift->_u_r_common("r",@_);
1035}
1036
1037#-> sub CPAN::Shell::u ;
1038sub u {
1039 shift->_u_r_common("u",@_);
1040}
1041
1042#-> sub CPAN::Shell::failed ;
1043sub failed {
1044 my($self,$only_id,$silent) = @_;
1045 my @failed;
1046 DIST: for my $d ($CPAN::META->all_objects("CPAN::Distribution")) {
1047 my $failed = "";
1048 NAY: for my $nosayer ( # order matters!
1049 "unwrapped",
1050 "writemakefile",
1051 "signature_verify",
1052 "make",
1053 "make_test",
1054 "install",
1055 "make_clean",
1056 ) {
1057 next unless exists $d->{$nosayer};
1058 next unless defined $d->{$nosayer};
1059 next unless (
1060 UNIVERSAL::can($d->{$nosayer},"failed") ?
1061 $d->{$nosayer}->failed :
1062 $d->{$nosayer} =~ /^NO/
1063 );
1064 next NAY if $only_id && $only_id != (
1065 UNIVERSAL::can($d->{$nosayer},"commandid")
1066 ?
1067 $d->{$nosayer}->commandid
1068 :
1069 $CPAN::CurrentCommandId
1070 );
1071 $failed = $nosayer;
1072 last;
1073 }
1074 next DIST unless $failed;
1075 my $id = $d->id;
1076 $id =~ s|^./../||;
1077 #$print .= sprintf(
1078 # " %-45s: %s %s\n",
1079 push @failed,
1080 (
1081 UNIVERSAL::can($d->{$failed},"failed") ?
1082 [
1083 $d->{$failed}->commandid,
1084 $id,
1085 $failed,
1086 $d->{$failed}->text,
1087 $d->{$failed}{TIME}||0,
1088 ] :
1089 [
1090 1,
1091 $id,
1092 $failed,
1093 $d->{$failed},
1094 0,
1095 ]
1096 );
1097 }
1098 my $scope;
1099 if ($only_id) {
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
1104 # a second for this
1105 } else {
1106 $scope = "this session";
1107 }
1108 if (@failed) {
1109 my $print;
1110 my $debug = 0;
1111 if ($debug) {
1112 $print = join "",
1113 map { sprintf "%5d %-45s: %s %s\n", @$_ }
1114 sort { $a->[0] <=> $b->[0] } @failed;
1115 } else {
1116 $print = join "",
1117 map { sprintf " %-45s: %s %s\n", @$_[1..3] }
1118 sort {
1119 $a->[0] <=> $b->[0]
1120 ||
1121 $a->[4] <=> $b->[4]
1122 } @failed;
1123 }
1124 $CPAN::Frontend->myprint("Failed during $scope:\n$print");
1125 } elsif (!$only_id || !$silent) {
1126 $CPAN::Frontend->myprint("Nothing failed in $scope\n");
1127 }
1128}
1129
1130# XXX intentionally undocumented because completely bogus, unportable,
1131# useless, etc.
1132
1133#-> sub CPAN::Shell::status ;
1134sub status {
1135 my($self) = @_;
1136 require Devel::Size;
1137 my $ps = FileHandle->new;
1138 open $ps, "/proc/$$/status";
1139 my $vm = 0;
1140 while (<$ps>) {
1141 next unless /VmSize:\s+(\d+)/;
1142 $vm = $1;
1143 last;
1144 }
1145 $CPAN::Frontend->mywarn(sprintf(
1146 "%-27s %6d\n%-27s %6d\n",
1147 "vm",
1148 $vm,
1149 "CPAN::META",
1150 Devel::Size::total_size($CPAN::META)/1024,
1151 ));
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",
1157 $k2,
1158 Devel::Size::total_size($CPAN::META->{$k}{$k2})/1024,
1159 scalar keys %{$CPAN::META->{$k}{$k2}};
1160 }
1161 }
1162}
1163
1164# compare with install_tested
1165#-> sub CPAN::Shell::is_tested
1166sub is_tested {
1167 my($self) = @_;
1168 CPAN::Index->reload;
1169 for my $b (reverse $CPAN::META->_list_sorted_descending_is_tested) {
1170 my $time;
1171 if ($CPAN::META->{is_tested}{$b}) {
1172 $time = scalar(localtime $CPAN::META->{is_tested}{$b});
1173 } else {
1174 $time = scalar localtime;
1175 $time =~ s/\S/?/g;
1176 }
1177 $CPAN::Frontend->myprint(sprintf "%s %s\n", $time, $b);
1178 }
1179}
1180
1181#-> sub CPAN::Shell::autobundle ;
1182sub autobundle {
1183 my($self) = shift;
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");
1190 return;
1191 }
1192 my($y,$m,$d) = (localtime)[5,4,3];
1193 $y+=1900;
1194 $m++;
1195 my($c) = 0;
1196 my($me) = sprintf "Snapshot_%04d_%02d_%02d_%02d", $y, $m, $d, $c;
1197 my($to) = File::Spec->catfile($todir,"$me.pm");
1198 while (-f $to) {
1199 $me = sprintf "Snapshot_%04d_%02d_%02d_%02d", $y, $m, $d, ++$c;
1200 $to = File::Spec->catfile($todir,"$me.pm");
1201 }
1202 my($fh) = FileHandle->new(">$to") or Carp::croak "Can't open >$to: $!";
1203 $fh->print(
1204 "package Bundle::$me;\n\n",
1205 "\$VERSION = '0.01';\n\n",
1206 "1;\n\n",
1207 "__END__\n\n",
1208 "=head1 NAME\n\n",
1209 "Bundle::$me - Snapshot of installation on ",
1210 $Config::Config{'myhostname'},
1211 " on ",
1212 scalar(localtime),
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",
1218 Config->myconfig,
1219 "\n\n=head1 AUTHOR\n\n",
1220 "This Bundle has been generated automatically ",
1221 "by the autobundle routine in CPAN.pm.\n",
1222 );
1223 $fh->close;
1224 $CPAN::Frontend->myprint("\nWrote bundle file
1225 $to\n\n");
1226}
1227
1228#-> sub CPAN::Shell::expandany ;
1229sub expandany {
1230 my($self,$s) = @_;
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
1240 # somewhere
1241 return $self->expand('Bundle',$s);
1242 } else {
1243 return $self->expand('Module',$s)
1244 if $CPAN::META->exists('CPAN::Module',$s);
1245 }
1246 return;
1247}
1248
1249#-> sub CPAN::Shell::expand ;
1250sub expand {
1251 my $self = shift;
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;
1259 }
1260 $self->expand_by_method($class,$methods,@args);
1261}
1262
1263#-> sub CPAN::Shell::expand_by_method ;
1264sub expand_by_method {
1265 my $self = shift;
1266 my($class,$methods,@args) = @_;
1267 my($arg,@m);
1268 for $arg (@args) {
1269 my($regex,$command);
1270 if ($arg =~ m|^/(.*)/$|) {
1271 $regex = $1;
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/=/) {
1275# $command = 1;
1276 }
1277 my $obj;
1278 CPAN->debug(sprintf "class[%s]regex[%s]command[%s]",
1279 $class,
1280 defined $regex ? $regex : "UNDEFINED",
1281 defined $command ? $command : "UNDEFINED",
1282 ) if $CPAN::DEBUG;
1283 if (defined $regex) {
1284 if (CPAN::_sqlite_running()) {
1285 CPAN::Index->reload;
1286 $CPAN::SQLite->search($class, $regex);
1287 }
1288 for $obj (
1289 $CPAN::META->all_objects($class)
1290 ) {
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]",
1296 $obj,
1297 Data::Dumper::Dumper($obj)
1298 )) if $CPAN::DEBUG;
1299 next;
1300 }
1301 for my $method (@$methods) {
1302 my $match = eval {$obj->$method() =~ /$regex/i};
1303 if ($@) {
1304 my($err) = $@ =~ /^(.+) at .+? line \d+\.$/;
1305 $err ||= $@; # if we were too restrictive above
1306 $CPAN::Frontend->mydie("$err\n");
1307 } elsif ($match) {
1308 push @m, $obj;
1309 last;
1310 }
1311 }
1312 }
1313 } elsif ($command) {
1314 die "equal sign in command disabled (immature interface), ".
1315 "you can set
1316 ! \$CPAN::Shell::ADVANCED_QUERY=1
1317to enable it. But please note, this is HIGHLY EXPERIMENTAL code
1318that may go away anytime.\n"
1319 unless $ADVANCED_QUERY;
1320 my($method,$criterion) = $arg =~ /(.+?)=(.+)/;
1321 my($matchcrit) = $criterion =~ m/^~(.+)/;
1322 for my $self (
1323 sort
1324 {$a->id cmp $b->id}
1325 $CPAN::META->all_objects($class)
1326 ) {
1327 my $lhs = $self->$method() or next; # () for 5.00503
1328 if ($matchcrit) {
1329 push @m, $self if $lhs =~ m/$matchcrit/;
1330 } else {
1331 push @m, $self if $lhs eq $criterion;
1332 }
1333 }
1334 } else {
1335 my($xarg) = $arg;
1336 if ( $class eq 'CPAN::Bundle' ) {
1337 $xarg =~ s/^(Bundle::)?(.*)/Bundle::$2/;
1338 } elsif ($class eq "CPAN::Distribution") {
1339 $xarg = CPAN::Distribution->normalize($arg);
1340 } else {
1341 $xarg =~ s/:+/::/g;
1342 }
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);
1347 } else {
1348 next;
1349 }
1350 push @m, $obj;
1351 }
1352 }
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]");
1360 }
1361 return wantarray ? @m : $m[0];
1362}
1363
1364#-> sub CPAN::Shell::format_result ;
1365sub format_result {
1366 my($self) = shift;
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 :
1372 @result == 0 ?
1373 "No objects of type $type found for argument @args\n" :
1374 join("",
1375 (map {$_->as_glimpse} @result),
1376 scalar @result, " items found\n",
1377 );
1378 $result;
1379}
1380
1381#-> sub CPAN::Shell::report_fh ;
1382{
1383 my $installation_report_fh;
1384 my $previously_noticed = 0;
1385
1386 sub report_fh {
1387 return $installation_report_fh if $installation_report_fh;
1388 if ($CPAN::META->has_usable("File::Temp")) {
1389 $installation_report_fh
1390 = File::Temp->new(
1391 dir => File::Spec->tmpdir,
1392 template => 'cpan_install_XXXX',
1393 suffix => '.txt',
1394 unlink => 0,
1395 );
1396 }
1397 unless ( $installation_report_fh ) {
1398 warn("Couldn't open installation report file; " .
1399 "no report file will be generated."
1400 ) unless $previously_noticed++;
1401 }
1402 }
1403}
1404
1405
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 ;-)
1409
1410# to turn colordebugging on, write
1411# cpan> o conf colorize_output 1
1412
1413#-> sub CPAN::Shell::colorize_output ;
1414{
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
1422installed. To activate colorized output, please install Term::ANSIColor.\n\n";
1423 }
1424 $colorize_output = 0;
1425 }
1426 return $colorize_output;
1427 }
1428}
1429
1430
1431#-> sub CPAN::Shell::print_ornamented ;
1432sub print_ornamented {
1433 my($self,$what,$ornament) = @_;
1434 return unless defined $what;
1435
1436 local $| = 1; # Flush immediately
1437 if ( $CPAN::Be_Silent ) {
1438 print {report_fh()} $what;
1439 return;
1440 }
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_*
1444 # courtesy jhi:
1445 $swhat
1446 =~ s{([\xC0-\xDF])([\x80-\xBF])}{chr(ord($1)<<6&0xC0|ord($2)&0x3F)}eg; #};
1447 }
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";
1452 }
1453 my $color_on = eval { Term::ANSIColor::color($ornament) } || "";
1454 if ($@) {
1455 print "Term::ANSIColor rejects color[$ornament]: $@\n
1456Please choose a different color (Hint: try 'o conf init /color/')\n";
1457 }
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
1462 my $trailer = "";
1463 $trailer = $1 if $swhat =~ s/([\r\n]+)\z//;
1464 print $color_on,
1465 $swhat,
1466 Term::ANSIColor::color("reset"),
1467 $trailer;
1468 } else {
1469 print $swhat;
1470 }
1471}
1472
1473#-> sub CPAN::Shell::myprint ;
1474
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.
1479sub myprint {
1480 my($self,$what) = @_;
1481 $self->print_ornamented($what,
1482 $CPAN::Config->{colorize_print}||'bold blue on_white',
1483 );
1484}
1485
1486sub optprint {
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/
1492 ) {
1493 $CPAN::Frontend->myprint($what);
1494 }
1495}
1496
1497#-> sub CPAN::Shell::myexit ;
1498sub myexit {
1499 my($self,$what) = @_;
1500 $self->myprint($what);
1501 exit;
1502}
1503
1504#-> sub CPAN::Shell::mywarn ;
1505sub mywarn {
1506 my($self,$what) = @_;
1507 $self->print_ornamented($what, $CPAN::Config->{colorize_warn}||'bold red on_white');
1508}
1509
1510# only to be used for shell commands
1511#-> sub CPAN::Shell::mydie ;
1512sub mydie {
1513 my($self,$what) = @_;
1514 $self->mywarn($what);
1515
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
1519 # possible?
1520
1521 die "\n";
1522}
1523
1524# sub CPAN::Shell::colorable_makemaker_prompt ;
1525sub colorable_makemaker_prompt {
1526 my($foo,$bar) = @_;
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); } || "";
1530 print $color_on;
1531 }
1532 my $ans = ExtUtils::MakeMaker::prompt($foo,$bar);
1533 if (CPAN::Shell->colorize_output) {
1534 print Term::ANSIColor::color('reset');
1535 }
1536 return $ans;
1537}
1538
1539# use this only for unrecoverable errors!
1540#-> sub CPAN::Shell::unrecoverable_error ;
1541sub unrecoverable_error {
1542 my($self,$what) = @_;
1543 my @lines = split /\n/, $what;
1544 my $longest = 0;
1545 for my $l (@lines) {
1546 $longest = length $l if length $l > $longest;
1547 }
1548 $longest = 62 if $longest > 62;
1549 for my $l (@lines) {
1550 if ($l =~ /^\s*$/) {
1551 $l = "\n";
1552 next;
1553 }
1554 $l = "==> $l";
1555 if (length $l < 66) {
1556 $l = pack "A66 A*", $l, "<==";
1557 }
1558 $l .= "\n";
1559 }
1560 unshift @lines, "\n";
1561 $self->mydie(join "", @lines);
1562}
1563
1564#-> sub CPAN::Shell::mysleep ;
1565sub mysleep {
1566 my($self, $sleep) = @_;
1567 if (CPAN->has_inst("Time::HiRes")) {
1568 Time::HiRes::sleep($sleep);
1569 } else {
1570 sleep($sleep < 1 ? 1 : int($sleep + 0.5));
1571 }
1572}
1573
1574#-> sub CPAN::Shell::setup_output ;
1575sub setup_output {
1576 return if -t STDOUT;
1577 my $odef = select STDERR;
1578 $| = 1;
1579 select STDOUT;
1580 $| = 1;
1581 select $odef;
1582}
1583
1584#-> sub CPAN::Shell::rematein ;
1585# RE-adme||MA-ke||TE-st||IN-stall : nearly everything runs through here
1586sub rematein {
1587 my $self = shift;
1588 my($meth,@some) = @_;
1589 my @pragma;
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: ".
1594 "cannot continue");
1595 }
1596 setup_output();
1597 CPAN->debug("pragma[@pragma]meth[$meth]some[@some]") if $CPAN::DEBUG;
1598
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".
1603
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
1611 # test_count?
1612
1613 # With configure_requires, "get" is vulnerable in recursion.
1614
1615 my $needs_recursion_protection = "get|make|test|install";
1616
1617 # construct the queue
1618 my($s,@s,@qcopy);
1619 STHING: foreach $s (@some) {
1620 my $obj;
1621 if (ref $s) {
1622 CPAN->debug("s is an object[$s]") if $CPAN::DEBUG;
1623 $obj = $s;
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);
1628 } else {
1629 $CPAN::Frontend->mywarn("Sorry, $meth with a regular expression is ".
1630 "not supported.\nRejecting argument '$s'\n");
1631 $CPAN::Frontend->mysleep(2);
1632 next;
1633 }
1634 } elsif ($meth eq "ls") {
1635 $self->globls($s,\@pragma);
1636 next STHING;
1637 } else {
1638 CPAN->debug("calling expandany [$s]") if $CPAN::DEBUG;
1639 $obj = CPAN::Shell->expandany($s);
1640 }
1641 if (0) {
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); };
1648 if ($@) {
1649 if (ref $@
1650 and $@->isa("CPAN::Exception::RecursiveDependency")) {
1651 $CPAN::Frontend->mywarn($@);
1652 } else {
1653 if (0) {
1654 require Carp;
1655 Carp::confess(sprintf "DEBUG: \$\@[%s]ref[%s]", $@, ref $@);
1656 }
1657 die;
1658 }
1659 }
1660 }
1661 CPAN::Queue->queue_item(qmod => $obj->id, reqtype => "c");
1662 push @qcopy, $obj;
1663 } elsif ($CPAN::META->exists('CPAN::Author',uc($s))) {
1664 $obj = $CPAN::META->instance('CPAN::Author',uc($s));
1665 if ($meth =~ /^(dump|ls|reports)$/) {
1666 $obj->$meth();
1667 } else {
1668 $CPAN::Frontend->mywarn(
1669 join "",
1670 "Don't be silly, you can't $meth ",
1671 $obj->fullname,
1672 " ;-)\n"
1673 );
1674 $CPAN::Frontend->mysleep(2);
1675 }
1676 } elsif ($s =~ m|[\$\@\%]| && $meth eq "dump") {
1677 CPAN::InfoObj->dump($s);
1678 } else {
1679 $CPAN::Frontend
1680 ->mywarn(qq{Warning: Cannot $meth $s, }.
1681 qq{don't know what it is.
1682Try the command
1683
1684 i /$s/
1685
1686to find objects with matching identifiers.
1687});
1688 $CPAN::Frontend->mysleep(2);
1689 }
1690 }
1691
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) {
1696 my $obj;
1697 my $s = $q->as_string;
1698 my $reqtype = $q->reqtype || "";
1699 $obj = CPAN::Shell->expandany($s);
1700 unless ($obj) {
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);
1708 next QITEM;
1709 }
1710 $obj->{reqtype} ||= "";
1711 {
1712 # force debugging because CPAN::SQLite somehow delivers us
1713 # an empty object;
1714
1715 # local $CPAN::DEBUG = 1024; # Shell; probably fixed now
1716
1717 CPAN->debug("s[$s]obj-reqtype[$obj->{reqtype}]".
1718 "q-reqtype[$reqtype]") if $CPAN::DEBUG;
1719 }
1720 if ($obj->{reqtype}) {
1721 if ($obj->{reqtype} eq "b" && $reqtype =~ /^[rc]$/) {
1722 $obj->{reqtype} = $reqtype;
1723 if (
1724 exists $obj->{install}
1725 &&
1726 (
1727 UNIVERSAL::can($obj->{install},"failed") ?
1728 $obj->{install}->failed :
1729 $obj->{install} =~ /^NO/
1730 )
1731 ) {
1732 delete $obj->{install};
1733 $CPAN::Frontend->mywarn
1734 ("Promoting $obj->{ID} from 'build_requires' to 'requires'");
1735 }
1736 }
1737 } else {
1738 $obj->{reqtype} = $reqtype;
1739 }
1740
1741 for my $pragma (@pragma) {
1742 if ($pragma
1743 &&
1744 $obj->can($pragma)) {
1745 $obj->$pragma($meth);
1746 }
1747 }
1748 if (UNIVERSAL::can($obj, 'called_for')) {
1749 $obj->called_for($s);
1750 }
1751 CPAN->debug(qq{pragma[@pragma]meth[$meth]}.
1752 qq{ID[$obj->{ID}]}) if $CPAN::DEBUG;
1753
1754 push @qcopy, $obj;
1755 if ($meth =~ /^(report)$/) { # they came here with a pragma?
1756 $self->$meth($obj);
1757 } elsif (! UNIVERSAL::can($obj,$meth)) {
1758 # Must never happen
1759 my $serialized = "";
1760 if (0) {
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);
1767 } else {
1768 require overload;
1769 $serialized = overload::StrVal($obj);
1770 }
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;
1776 } else {
1777 CPAN->debug("Failed. pragma[@pragma]meth[$meth]") if $CPAN::DEBUG;
1778 }
1779
1780 $obj->undelay;
1781 for my $pragma (@pragma) {
1782 my $unpragma = "un$pragma";
1783 if ($obj->can($unpragma)) {
1784 $obj->$unpragma();
1785 }
1786 }
1787 if ($CPAN::Config->{halt_on_failure}
1788 &&
1789 CPAN::Distrostatus::something_has_just_failed()
1790 ) {
1791 $CPAN::Frontend->mywarn("Stopping: '$meth' failed for '$s'.\n");
1792 CPAN::Queue->nullify_queue;
1793 last QITEM;
1794 }
1795 CPAN::Queue->delete_first($s);
1796 }
1797 if ($meth =~ /^($needs_recursion_protection)$/) {
1798 for my $obj (@qcopy) {
1799 $obj->color_cmd_tmps(0,0);
1800 }
1801 }
1802}
1803
1804#-> sub CPAN::Shell::recent ;
1805sub recent {
1806 my($self) = @_;
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");
1812 }
1813 CPAN::LWP::UserAgent->config;
1814 my $Ua;
1815 eval { $Ua = CPAN::LWP::UserAgent->new; };
1816 if ($@) {
1817 $CPAN::Frontend->mydie("CPAN::LWP::UserAgent->new dies with $@\n");
1818 }
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);
1822 }
1823 $CPAN::Frontend->myprint("DONE\n\n");
1824 my $xml = XML::LibXML->new->parse_string($resp->content);
1825 if (0) {
1826 my $s = $xml->serialize(2);
1827 $s =~ s/\n\s*\n/\n/g;
1828 $CPAN::Frontend->myprint($s);
1829 return;
1830 }
1831 my @distros;
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;
1843 }
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/"
1851
1852
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']");
1864 my $i = 0;
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;
1870 if (@ret) {
1871 $distro = "$author/$ret[0][2]";
1872 last SUBDIRTEST;
1873 }
1874 }
1875 $distro =~ s|/|/*/|; # allow it to reside in a subdirectory
1876 }
1877
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;
1882 }
1883 }
1884 return \@distros;
1885 } else {
1886 # deprecated old version
1887 $CPAN::Frontend->mydie("no XML::LibXML installed, cannot continue\n");
1888 }
1889}
1890
1891#-> sub CPAN::Shell::smoke ;
1892sub smoke {
1893 my($self) = @_;
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");
1898 {
1899 my $skip = 0;
1900 local $SIG{INT} = sub { $skip = 1 };
1901 for (0..9) {
1902 $CPAN::Frontend->myprint(sprintf "\r%2d (Hit ^C to skip)", 10-$_);
1903 sleep 1;
1904 if ($skip) {
1905 $CPAN::Frontend->myprint(" skipped\n");
1906 next DISTRO;
1907 }
1908 }
1909 }
1910 $CPAN::Frontend->myprint("\r \n"); # leave the dirty line with a newline
1911 $self->test($distro);
1912 }
1913}
1914
1915{
1916 # set up the dispatching methods
1917 no strict "refs";
1918 for my $command (qw(
1919 clean
1920 cvs_import
1921 dump
1922 force
1923 fforce
1924 get
1925 install
1926 look
1927 ls
1928 make
1929 notest
1930 perldoc
1931 readme
1932 reports
1933 test
1934 )) {
1935 *$command = sub { shift->rematein($command, @_); };
1936 }
1937}
1938
19391;
Unnamed repository; edit this file 'description' to name the repository.