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