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