← Index
NYTProf Performance Profile   « line view »
For /Users/brian/bin/perls/cpan5.26.1
  Run on Sat Dec 30 01:41:10 2017
Reported on Sat Dec 30 01:44:14 2017

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