| [ Index ] |
PHP Cross Reference of Unnamed Project |
[Summary view] [Print] [Text view]
1 # -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*- 2 use strict; 3 package CPAN; 4 $CPAN::VERSION = '1.9205'; 5 $CPAN::VERSION = eval $CPAN::VERSION if $CPAN::VERSION =~ /_/; 6 7 use CPAN::HandleConfig; 8 use CPAN::Version; 9 use CPAN::Debug; 10 use CPAN::Queue; 11 use CPAN::Tarzip; 12 use CPAN::DeferedCode; 13 use Carp (); 14 use Config (); 15 use Cwd (); 16 use DirHandle (); 17 use Exporter (); 18 use ExtUtils::MakeMaker qw(prompt); # for some unknown reason, 19 # 5.005_04 does not work without 20 # this 21 use File::Basename (); 22 use File::Copy (); 23 use File::Find; 24 use File::Path (); 25 use File::Spec (); 26 use FileHandle (); 27 use Fcntl qw(:flock); 28 use Safe (); 29 use Sys::Hostname qw(hostname); 30 use Text::ParseWords (); 31 use Text::Wrap (); 32 33 sub find_perl (); 34 35 # we need to run chdir all over and we would get at wrong libraries 36 # there 37 BEGIN { 38 if (File::Spec->can("rel2abs")) { 39 for my $inc (@INC) { 40 $inc = File::Spec->rel2abs($inc) unless ref $inc; 41 } 42 } 43 } 44 no lib "."; 45 46 require Mac::BuildTools if $^O eq 'MacOS'; 47 $ENV{PERL5_CPAN_IS_RUNNING}=$$; 48 $ENV{PERL5_CPANPLUS_IS_RUNNING}=$$; # https://rt.cpan.org/Ticket/Display.html?id=23735 49 50 END { $CPAN::End++; &cleanup; } 51 52 $CPAN::Signal ||= 0; 53 $CPAN::Frontend ||= "CPAN::Shell"; 54 unless (@CPAN::Defaultsites) { 55 @CPAN::Defaultsites = map { 56 CPAN::URL->new(TEXT => $_, FROM => "DEF") 57 } 58 "http://www.perl.org/CPAN/", 59 "ftp://ftp.perl.org/pub/CPAN/"; 60 } 61 # $CPAN::iCwd (i for initial) is going to be initialized during find_perl 62 $CPAN::Perl ||= CPAN::find_perl(); 63 $CPAN::Defaultdocs ||= "http://search.cpan.org/perldoc?"; 64 $CPAN::Defaultrecent ||= "http://search.cpan.org/uploads.rdf"; 65 $CPAN::Defaultrecent ||= "http://cpan.uwinnipeg.ca/htdocs/cpan.xml"; 66 67 # our globals are getting a mess 68 use vars qw( 69 $AUTOLOAD 70 $Be_Silent 71 $CONFIG_DIRTY 72 $Defaultdocs 73 $Echo_readline 74 $Frontend 75 $GOTOSHELL 76 $HAS_USABLE 77 $Have_warned 78 $MAX_RECURSION 79 $META 80 $RUN_DEGRADED 81 $Signal 82 $SQLite 83 $Suppress_readline 84 $VERSION 85 $autoload_recursion 86 $term 87 @Defaultsites 88 @EXPORT 89 ); 90 91 $MAX_RECURSION = 32; 92 93 @CPAN::ISA = qw(CPAN::Debug Exporter); 94 95 # note that these functions live in CPAN::Shell and get executed via 96 # AUTOLOAD when called directly 97 @EXPORT = qw( 98 autobundle 99 bundle 100 clean 101 cvs_import 102 expand 103 force 104 fforce 105 get 106 install 107 install_tested 108 is_tested 109 make 110 mkmyconfig 111 notest 112 perldoc 113 readme 114 recent 115 recompile 116 report 117 shell 118 smoke 119 test 120 upgrade 121 ); 122 123 sub soft_chdir_with_alternatives ($); 124 125 { 126 $autoload_recursion ||= 0; 127 128 #-> sub CPAN::AUTOLOAD ; 129 sub AUTOLOAD { 130 $autoload_recursion++; 131 my($l) = $AUTOLOAD; 132 $l =~ s/.*:://; 133 if ($CPAN::Signal) { 134 warn "Refusing to autoload '$l' while signal pending"; 135 $autoload_recursion--; 136 return; 137 } 138 if ($autoload_recursion > 1) { 139 my $fullcommand = join " ", map { "'$_'" } $l, @_; 140 warn "Refusing to autoload $fullcommand in recursion\n"; 141 $autoload_recursion--; 142 return; 143 } 144 my(%export); 145 @export{@EXPORT} = ''; 146 CPAN::HandleConfig->load unless $CPAN::Config_loaded++; 147 if (exists $export{$l}) { 148 CPAN::Shell->$l(@_); 149 } else { 150 die(qq{Unknown CPAN command "$AUTOLOAD". }. 151 qq{Type ? for help.\n}); 152 } 153 $autoload_recursion--; 154 } 155 } 156 157 #-> sub CPAN::shell ; 158 sub shell { 159 my($self) = @_; 160 $Suppress_readline = ! -t STDIN unless defined $Suppress_readline; 161 CPAN::HandleConfig->load unless $CPAN::Config_loaded++; 162 163 my $oprompt = shift || CPAN::Prompt->new; 164 my $prompt = $oprompt; 165 my $commandline = shift || ""; 166 $CPAN::CurrentCommandId ||= 1; 167 168 local($^W) = 1; 169 unless ($Suppress_readline) { 170 require Term::ReadLine; 171 if (! $term 172 or 173 $term->ReadLine eq "Term::ReadLine::Stub" 174 ) { 175 $term = Term::ReadLine->new('CPAN Monitor'); 176 } 177 if ($term->ReadLine eq "Term::ReadLine::Gnu") { 178 my $attribs = $term->Attribs; 179 $attribs->{attempted_completion_function} = sub { 180 &CPAN::Complete::gnu_cpl; 181 } 182 } else { 183 $readline::rl_completion_function = 184 $readline::rl_completion_function = 'CPAN::Complete::cpl'; 185 } 186 if (my $histfile = $CPAN::Config->{'histfile'}) {{ 187 unless ($term->can("AddHistory")) { 188 $CPAN::Frontend->mywarn("Terminal does not support AddHistory.\n"); 189 last; 190 } 191 $META->readhist($term,$histfile); 192 }} 193 for ($CPAN::Config->{term_ornaments}) { # alias 194 local $Term::ReadLine::termcap_nowarn = 1; 195 $term->ornaments($_) if defined; 196 } 197 # $term->OUT is autoflushed anyway 198 my $odef = select STDERR; 199 $| = 1; 200 select STDOUT; 201 $| = 1; 202 select $odef; 203 } 204 205 $META->checklock(); 206 my @cwd = grep { defined $_ and length $_ } 207 CPAN::anycwd(), 208 File::Spec->can("tmpdir") ? File::Spec->tmpdir() : (), 209 File::Spec->rootdir(); 210 my $try_detect_readline; 211 $try_detect_readline = $term->ReadLine eq "Term::ReadLine::Stub" if $term; 212 unless ($CPAN::Config->{inhibit_startup_message}) { 213 my $rl_avail = $Suppress_readline ? "suppressed" : 214 ($term->ReadLine ne "Term::ReadLine::Stub") ? "enabled" : 215 "available (maybe install Bundle::CPAN or Bundle::CPANxxl?)"; 216 $CPAN::Frontend->myprint( 217 sprintf qq{ 218 cpan shell -- CPAN exploration and modules installation (v%s) 219 ReadLine support %s 220 221 }, 222 $CPAN::VERSION, 223 $rl_avail 224 ) 225 } 226 my($continuation) = ""; 227 my $last_term_ornaments; 228 SHELLCOMMAND: while () { 229 if ($Suppress_readline) { 230 if ($Echo_readline) { 231 $|=1; 232 } 233 print $prompt; 234 last SHELLCOMMAND unless defined ($_ = <> ); 235 if ($Echo_readline) { 236 # backdoor: I could not find a way to record sessions 237 print $_; 238 } 239 chomp; 240 } else { 241 last SHELLCOMMAND unless 242 defined ($_ = $term->readline($prompt, $commandline)); 243 } 244 $_ = "$continuation$_" if $continuation; 245 s/^\s+//; 246 next SHELLCOMMAND if /^$/; 247 s/^\s*\?\s*/help /; 248 if (/^(?:q(?:uit)?|bye|exit)$/i) { 249 last SHELLCOMMAND; 250 } elsif (s/\\$//s) { 251 chomp; 252 $continuation = $_; 253 $prompt = " > "; 254 } elsif (/^\!/) { 255 s/^\!//; 256 my($eval) = $_; 257 package CPAN::Eval; 258 use strict; 259 use vars qw($import_done); 260 CPAN->import(':DEFAULT') unless $import_done++; 261 CPAN->debug("eval[$eval]") if $CPAN::DEBUG; 262 eval($eval); 263 warn $@ if $@; 264 $continuation = ""; 265 $prompt = $oprompt; 266 } elsif (/./) { 267 my(@line); 268 eval { @line = Text::ParseWords::shellwords($_) }; 269 warn($@), next SHELLCOMMAND if $@; 270 warn("Text::Parsewords could not parse the line [$_]"), 271 next SHELLCOMMAND unless @line; 272 $CPAN::META->debug("line[".join("|",@line)."]") if $CPAN::DEBUG; 273 my $command = shift @line; 274 eval { CPAN::Shell->$command(@line) }; 275 if ($@) { 276 my $err = "$@"; 277 if ($err =~ /\S/) { 278 require Carp; 279 require Dumpvalue; 280 my $dv = Dumpvalue->new(); 281 Carp::cluck(sprintf "Catching error: %s", $dv->stringify($err)); 282 } 283 } 284 if ($command =~ /^( 285 # classic commands 286 make 287 |test 288 |install 289 |clean 290 291 # pragmas for classic commands 292 |ff?orce 293 |notest 294 295 # compounds 296 |report 297 |smoke 298 |upgrade 299 )$/x) { 300 # only commands that tell us something about failed distros 301 CPAN::Shell->failed($CPAN::CurrentCommandId,1); 302 } 303 soft_chdir_with_alternatives(\@cwd); 304 $CPAN::Frontend->myprint("\n"); 305 $continuation = ""; 306 $CPAN::CurrentCommandId++; 307 $prompt = $oprompt; 308 } 309 } continue { 310 $commandline = ""; # I do want to be able to pass a default to 311 # shell, but on the second command I see no 312 # use in that 313 $Signal=0; 314 CPAN::Queue->nullify_queue; 315 if ($try_detect_readline) { 316 if ($CPAN::META->has_inst("Term::ReadLine::Gnu") 317 || 318 $CPAN::META->has_inst("Term::ReadLine::Perl") 319 ) { 320 delete $INC{"Term/ReadLine.pm"}; 321 my $redef = 0; 322 local($SIG{__WARN__}) = CPAN::Shell::paintdots_onreload(\$redef); 323 require Term::ReadLine; 324 $CPAN::Frontend->myprint("\n$redef subroutines in ". 325 "Term::ReadLine redefined\n"); 326 $GOTOSHELL = 1; 327 } 328 } 329 if ($term and $term->can("ornaments")) { 330 for ($CPAN::Config->{term_ornaments}) { # alias 331 if (defined $_) { 332 if (not defined $last_term_ornaments 333 or $_ != $last_term_ornaments 334 ) { 335 local $Term::ReadLine::termcap_nowarn = 1; 336 $term->ornaments($_); 337 $last_term_ornaments = $_; 338 } 339 } else { 340 undef $last_term_ornaments; 341 } 342 } 343 } 344 for my $class (qw(Module Distribution)) { 345 # again unsafe meta access? 346 for my $dm (keys %{$CPAN::META->{readwrite}{"CPAN::$class"}}) { 347 next unless $CPAN::META->{readwrite}{"CPAN::$class"}{$dm}{incommandcolor}; 348 CPAN->debug("BUG: $class '$dm' was in command state, resetting"); 349 delete $CPAN::META->{readwrite}{"CPAN::$class"}{$dm}{incommandcolor}; 350 } 351 } 352 if ($GOTOSHELL) { 353 $GOTOSHELL = 0; # not too often 354 $META->savehist if $CPAN::term && $CPAN::term->can("GetHistory"); 355 @_ = ($oprompt,""); 356 goto &shell; 357 } 358 } 359 soft_chdir_with_alternatives(\@cwd); 360 } 361 362 #-> CPAN::soft_chdir_with_alternatives ; 363 sub soft_chdir_with_alternatives ($) { 364 my($cwd) = @_; 365 unless (@$cwd) { 366 my $root = File::Spec->rootdir(); 367 $CPAN::Frontend->mywarn(qq{Warning: no good directory to chdir to! 368 Trying '$root' as temporary haven. 369 }); 370 push @$cwd, $root; 371 } 372 while () { 373 if (chdir $cwd->[0]) { 374 return; 375 } else { 376 if (@$cwd>1) { 377 $CPAN::Frontend->mywarn(qq{Could not chdir to "$cwd->[0]": $! 378 Trying to chdir to "$cwd->[1]" instead. 379 }); 380 shift @$cwd; 381 } else { 382 $CPAN::Frontend->mydie(qq{Could not chdir to "$cwd->[0]": $!}); 383 } 384 } 385 } 386 } 387 388 sub _flock { 389 my($fh,$mode) = @_; 390 if ($Config::Config{d_flock}) { 391 return flock $fh, $mode; 392 } elsif (!$Have_warned->{"d_flock"}++) { 393 $CPAN::Frontend->mywarn("Your OS does not support locking; continuing and ignoring all locking issues\n"); 394 $CPAN::Frontend->mysleep(5); 395 return 1; 396 } else { 397 return 1; 398 } 399 } 400 401 sub _yaml_module () { 402 my $yaml_module = $CPAN::Config->{yaml_module} || "YAML"; 403 if ( 404 $yaml_module ne "YAML" 405 && 406 !$CPAN::META->has_inst($yaml_module) 407 ) { 408 # $CPAN::Frontend->mywarn("'$yaml_module' not installed, falling back to 'YAML'\n"); 409 $yaml_module = "YAML"; 410 } 411 if ($yaml_module eq "YAML" 412 && 413 $CPAN::META->has_inst($yaml_module) 414 && 415 $YAML::VERSION < 0.60 416 && 417 !$Have_warned->{"YAML"}++ 418 ) { 419 $CPAN::Frontend->mywarn("Warning: YAML version '$YAML::VERSION' is too low, please upgrade!\n". 420 "I'll continue but problems are *very* likely to happen.\n" 421 ); 422 $CPAN::Frontend->mysleep(5); 423 } 424 return $yaml_module; 425 } 426 427 # CPAN::_yaml_loadfile 428 sub _yaml_loadfile { 429 my($self,$local_file) = @_; 430 return +[] unless -s $local_file; 431 my $yaml_module = _yaml_module; 432 if ($CPAN::META->has_inst($yaml_module)) { 433 # temporarly enable yaml code deserialisation 434 no strict 'refs'; 435 # 5.6.2 could not do the local() with the reference 436 local $YAML::LoadCode; 437 local $YAML::Syck::LoadCode; 438 ${ "$yaml_module\::LoadCode" } = $CPAN::Config->{yaml_load_code} || 0; 439 440 my $code; 441 if ($code = UNIVERSAL::can($yaml_module, "LoadFile")) { 442 my @yaml; 443 eval { @yaml = $code->($local_file); }; 444 if ($@) { 445 # this shall not be done by the frontend 446 die CPAN::Exception::yaml_process_error->new($yaml_module,$local_file,"parse",$@); 447 } 448 return \@yaml; 449 } elsif ($code = UNIVERSAL::can($yaml_module, "Load")) { 450 local *FH; 451 open FH, $local_file or die "Could not open '$local_file': $!"; 452 local $/; 453 my $ystream = <FH>; 454 my @yaml; 455 eval { @yaml = $code->($ystream); }; 456 if ($@) { 457 # this shall not be done by the frontend 458 die CPAN::Exception::yaml_process_error->new($yaml_module,$local_file,"parse",$@); 459 } 460 return \@yaml; 461 } 462 } else { 463 # this shall not be done by the frontend 464 die CPAN::Exception::yaml_not_installed->new($yaml_module, $local_file, "parse"); 465 } 466 return +[]; 467 } 468 469 # CPAN::_yaml_dumpfile 470 sub _yaml_dumpfile { 471 my($self,$local_file,@what) = @_; 472 my $yaml_module = _yaml_module; 473 if ($CPAN::META->has_inst($yaml_module)) { 474 my $code; 475 if (UNIVERSAL::isa($local_file, "FileHandle")) { 476 $code = UNIVERSAL::can($yaml_module, "Dump"); 477 eval { print $local_file $code->(@what) }; 478 } elsif ($code = UNIVERSAL::can($yaml_module, "DumpFile")) { 479 eval { $code->($local_file,@what); }; 480 } elsif ($code = UNIVERSAL::can($yaml_module, "Dump")) { 481 local *FH; 482 open FH, ">$local_file" or die "Could not open '$local_file': $!"; 483 print FH $code->(@what); 484 } 485 if ($@) { 486 die CPAN::Exception::yaml_process_error->new($yaml_module,$local_file,"dump",$@); 487 } 488 } else { 489 if (UNIVERSAL::isa($local_file, "FileHandle")) { 490 # I think this case does not justify a warning at all 491 } else { 492 die CPAN::Exception::yaml_not_installed->new($yaml_module, $local_file, "dump"); 493 } 494 } 495 } 496 497 sub _init_sqlite () { 498 unless ($CPAN::META->has_inst("CPAN::SQLite")) { 499 $CPAN::Frontend->mywarn(qq{CPAN::SQLite not installed, trying to work without\n}) 500 unless $Have_warned->{"CPAN::SQLite"}++; 501 return; 502 } 503 require CPAN::SQLite::META; # not needed since CVS version of 2006-12-17 504 $CPAN::SQLite ||= CPAN::SQLite::META->new($CPAN::META); 505 } 506 507 { 508 my $negative_cache = {}; 509 sub _sqlite_running { 510 if ($negative_cache->{time} && time < $negative_cache->{time} + 60) { 511 # need to cache the result, otherwise too slow 512 return $negative_cache->{fact}; 513 } else { 514 $negative_cache = {}; # reset 515 } 516 my $ret = $CPAN::Config->{use_sqlite} && ($CPAN::SQLite || _init_sqlite()); 517 return $ret if $ret; # fast anyway 518 $negative_cache->{time} = time; 519 return $negative_cache->{fact} = $ret; 520 } 521 } 522 523 package CPAN::CacheMgr; 524 use strict; 525 @CPAN::CacheMgr::ISA = qw(CPAN::InfoObj CPAN); 526 use File::Find; 527 528 package CPAN::FTP; 529 use strict; 530 use Fcntl qw(:flock); 531 use vars qw($connect_to_internet_ok $Ua $Thesite $ThesiteURL $Themethod); 532 @CPAN::FTP::ISA = qw(CPAN::Debug); 533 534 package CPAN::LWP::UserAgent; 535 use strict; 536 use vars qw(@ISA $USER $PASSWD $SETUPDONE); 537 # we delay requiring LWP::UserAgent and setting up inheritance until we need it 538 539 package CPAN::Complete; 540 use strict; 541 @CPAN::Complete::ISA = qw(CPAN::Debug); 542 # Q: where is the "How do I add a new command" HOWTO? 543 # A: svn diff -r 1048:1049 where andk added the report command 544 @CPAN::Complete::COMMANDS = sort qw( 545 ? ! a b d h i m o q r u 546 autobundle 547 bye 548 clean 549 cvs_import 550 dump 551 exit 552 failed 553 force 554 fforce 555 hosts 556 install 557 install_tested 558 is_tested 559 look 560 ls 561 make 562 mkmyconfig 563 notest 564 perldoc 565 quit 566 readme 567 recent 568 recompile 569 reload 570 report 571 reports 572 scripts 573 smoke 574 test 575 upgrade 576 ); 577 578 package CPAN::Index; 579 use strict; 580 use vars qw($LAST_TIME $DATE_OF_02 $DATE_OF_03 $HAVE_REANIMATED); 581 @CPAN::Index::ISA = qw(CPAN::Debug); 582 $LAST_TIME ||= 0; 583 $DATE_OF_03 ||= 0; 584 # use constant PROTOCOL => "2.0"; # outcommented to avoid warning on upgrade from 1.57 585 sub PROTOCOL { 2.0 } 586 587 package CPAN::InfoObj; 588 use strict; 589 @CPAN::InfoObj::ISA = qw(CPAN::Debug); 590 591 package CPAN::Author; 592 use strict; 593 @CPAN::Author::ISA = qw(CPAN::InfoObj); 594 595 package CPAN::Distribution; 596 use strict; 597 @CPAN::Distribution::ISA = qw(CPAN::InfoObj); 598 599 package CPAN::Bundle; 600 use strict; 601 @CPAN::Bundle::ISA = qw(CPAN::Module); 602 603 package CPAN::Module; 604 use strict; 605 @CPAN::Module::ISA = qw(CPAN::InfoObj); 606 607 package CPAN::Exception::RecursiveDependency; 608 use strict; 609 use overload '""' => "as_string"; 610 611 # a module sees its distribution (no version) 612 # a distribution sees its prereqs (which are module names) (usually with versions) 613 # a bundle sees its module names and/or its distributions (no version) 614 615 sub new { 616 my($class) = shift; 617 my($deps) = shift; 618 my (@deps,%seen,$loop_starts_with); 619 DCHAIN: for my $dep (@$deps) { 620 push @deps, {name => $dep, display_as => $dep}; 621 if ($seen{$dep}++) { 622 $loop_starts_with = $dep; 623 last DCHAIN; 624 } 625 } 626 my $in_loop = 0; 627 for my $i (0..$#deps) { 628 my $x = $deps[$i]{name}; 629 $in_loop ||= $x eq $loop_starts_with; 630 my $xo = CPAN::Shell->expandany($x) or next; 631 if ($xo->isa("CPAN::Module")) { 632 my $have = $xo->inst_version || "N/A"; 633 my($want,$d,$want_type); 634 if ($i>0 and $d = $deps[$i-1]{name}) { 635 my $do = CPAN::Shell->expandany($d); 636 $want = $do->{prereq_pm}{requires}{$x}; 637 if (defined $want) { 638 $want_type = "requires: "; 639 } else { 640 $want = $do->{prereq_pm}{build_requires}{$x}; 641 if (defined $want) { 642 $want_type = "build_requires: "; 643 } else { 644 $want_type = "unknown status"; 645 $want = "???"; 646 } 647 } 648 } else { 649 $want = $xo->cpan_version; 650 $want_type = "want: "; 651 } 652 $deps[$i]{have} = $have; 653 $deps[$i]{want_type} = $want_type; 654 $deps[$i]{want} = $want; 655 $deps[$i]{display_as} = "$x (have: $have; $want_type$want)"; 656 } elsif ($xo->isa("CPAN::Distribution")) { 657 $deps[$i]{display_as} = $xo->pretty_id; 658 if ($in_loop) { 659 $xo->{make} = CPAN::Distrostatus->new("NO cannot resolve circular dependency"); 660 } else { 661 $xo->{make} = CPAN::Distrostatus->new("NO one dependency ($loop_starts_with) is a circular dependency"); 662 } 663 $xo->store_persistent_state; # otherwise I will not reach 664 # all involved parties for 665 # the next session 666 } 667 } 668 bless { deps => \@deps }, $class; 669 } 670 671 sub as_string { 672 my($self) = shift; 673 my $ret = "\nRecursive dependency detected:\n "; 674 $ret .= join("\n => ", map {$_->{display_as}} @{$self->{deps}}); 675 $ret .= ".\nCannot resolve.\n"; 676 $ret; 677 } 678 679 package CPAN::Exception::yaml_not_installed; 680 use strict; 681 use overload '""' => "as_string"; 682 683 sub new { 684 my($class,$module,$file,$during) = @_; 685 bless { module => $module, file => $file, during => $during }, $class; 686 } 687 688 sub as_string { 689 my($self) = shift; 690 "'$self->{module}' not installed, cannot $self->{during} '$self->{file}'\n"; 691 } 692 693 package CPAN::Exception::yaml_process_error; 694 use strict; 695 use overload '""' => "as_string"; 696 697 sub new { 698 my($class,$module,$file,$during,$error) = @_; 699 bless { module => $module, 700 file => $file, 701 during => $during, 702 error => $error }, $class; 703 } 704 705 sub as_string { 706 my($self) = shift; 707 if ($self->{during}) { 708 if ($self->{file}) { 709 if ($self->{module}) { 710 if ($self->{error}) { 711 return "Alert: While trying to '$self->{during}' YAML file\n". 712 " '$self->{file}'\n". 713 "with '$self->{module}' the following error was encountered:\n". 714 " $self->{error}\n"; 715 } else { 716 return "Alert: While trying to '$self->{during}' YAML file\n". 717 " '$self->{file}'\n". 718 "with '$self->{module}' some unknown error was encountered\n"; 719 } 720 } else { 721 return "Alert: While trying to '$self->{during}' YAML file\n". 722 " '$self->{file}'\n". 723 "some unknown error was encountered\n"; 724 } 725 } else { 726 return "Alert: While trying to '$self->{during}' some YAML file\n". 727 "some unknown error was encountered\n"; 728 } 729 } else { 730 return "Alert: unknown error encountered\n"; 731 } 732 } 733 734 package CPAN::Prompt; use overload '""' => "as_string"; 735 use vars qw($prompt); 736 $prompt = "cpan> "; 737 $CPAN::CurrentCommandId ||= 0; 738 sub new { 739 bless {}, shift; 740 } 741 sub as_string { 742 my $word = "cpan"; 743 unless ($CPAN::META->{LOCK}) { 744 $word = "nolock_cpan"; 745 } 746 if ($CPAN::Config->{commandnumber_in_prompt}) { 747 sprintf "$word\[%d]> ", $CPAN::CurrentCommandId; 748 } else { 749 "$word> "; 750 } 751 } 752 753 package CPAN::URL; use overload '""' => "as_string", fallback => 1; 754 # accessors: TEXT(the url string), FROM(DEF=>defaultlist,USER=>urllist), 755 # planned are things like age or quality 756 sub new { 757 my($class,%args) = @_; 758 bless { 759 %args 760 }, $class; 761 } 762 sub as_string { 763 my($self) = @_; 764 $self->text; 765 } 766 sub text { 767 my($self,$set) = @_; 768 if (defined $set) { 769 $self->{TEXT} = $set; 770 } 771 $self->{TEXT}; 772 } 773 774 package CPAN::Distrostatus; 775 use overload '""' => "as_string", 776 fallback => 1; 777 sub new { 778 my($class,$arg) = @_; 779 bless { 780 TEXT => $arg, 781 FAILED => substr($arg,0,2) eq "NO", 782 COMMANDID => $CPAN::CurrentCommandId, 783 TIME => time, 784 }, $class; 785 } 786 sub commandid { shift->{COMMANDID} } 787 sub failed { shift->{FAILED} } 788 sub text { 789 my($self,$set) = @_; 790 if (defined $set) { 791 $self->{TEXT} = $set; 792 } 793 $self->{TEXT}; 794 } 795 sub as_string { 796 my($self) = @_; 797 $self->text; 798 } 799 800 package CPAN::Shell; 801 use strict; 802 use vars qw( 803 $ADVANCED_QUERY 804 $AUTOLOAD 805 $COLOR_REGISTERED 806 $Help 807 $autoload_recursion 808 $reload 809 @ISA 810 ); 811 @CPAN::Shell::ISA = qw(CPAN::Debug); 812 $COLOR_REGISTERED ||= 0; 813 $Help = { 814 '?' => \"help", 815 '!' => "eval the rest of the line as perl", 816 a => "whois author", 817 autobundle => "wtite inventory into a bundle file", 818 b => "info about bundle", 819 bye => \"quit", 820 clean => "clean up a distribution's build directory", 821 # cvs_import 822 d => "info about a distribution", 823 # dump 824 exit => \"quit", 825 failed => "list all failed actions within current session", 826 fforce => "redo a command from scratch", 827 force => "redo a command", 828 h => \"help", 829 help => "overview over commands; 'help ...' explains specific commands", 830 hosts => "statistics about recently used hosts", 831 i => "info about authors/bundles/distributions/modules", 832 install => "install a distribution", 833 install_tested => "install all distributions tested OK", 834 is_tested => "list all distributions tested OK", 835 look => "open a subshell in a distribution's directory", 836 ls => "list distributions according to a glob", 837 m => "info about a module", 838 make => "make/build a distribution", 839 mkmyconfig => "write current config into a CPAN/MyConfig.pm file", 840 notest => "run a (usually install) command but leave out the test phase", 841 o => "'o conf ...' for config stuff; 'o debug ...' for debugging", 842 perldoc => "try to get a manpage for a module", 843 q => \"quit", 844 quit => "leave the cpan shell", 845 r => "review over upgradeable modules", 846 readme => "display the README of a distro woth a pager", 847 recent => "show recent uploads to the CPAN", 848 # recompile 849 reload => "'reload cpan' or 'reload index'", 850 report => "test a distribution and send a test report to cpantesters", 851 reports => "info about reported tests from cpantesters", 852 # scripts 853 # smoke 854 test => "test a distribution", 855 u => "display uninstalled modules", 856 upgrade => "combine 'r' command with immediate installation", 857 }; 858 { 859 $autoload_recursion ||= 0; 860 861 #-> sub CPAN::Shell::AUTOLOAD ; 862 sub AUTOLOAD { 863 $autoload_recursion++; 864 my($l) = $AUTOLOAD; 865 my $class = shift(@_); 866 # warn "autoload[$l] class[$class]"; 867 $l =~ s/.*:://; 868 if ($CPAN::Signal) { 869 warn "Refusing to autoload '$l' while signal pending"; 870 $autoload_recursion--; 871 return; 872 } 873 if ($autoload_recursion > 1) { 874 my $fullcommand = join " ", map { "'$_'" } $l, @_; 875 warn "Refusing to autoload $fullcommand in recursion\n"; 876 $autoload_recursion--; 877 return; 878 } 879 if ($l =~ /^w/) { 880 # XXX needs to be reconsidered 881 if ($CPAN::META->has_inst('CPAN::WAIT')) { 882 CPAN::WAIT->$l(@_); 883 } else { 884 $CPAN::Frontend->mywarn(qq{ 885 Commands starting with "w" require CPAN::WAIT to be installed. 886 Please consider installing CPAN::WAIT to use the fulltext index. 887 For this you just need to type 888 install CPAN::WAIT 889 }); 890 } 891 } else { 892 $CPAN::Frontend->mywarn(qq{Unknown shell command '$l'. }. 893 qq{Type ? for help. 894 }); 895 } 896 $autoload_recursion--; 897 } 898 } 899 900 package CPAN; 901 use strict; 902 903 $META ||= CPAN->new; # In case we re-eval ourselves we need the || 904 905 # from here on only subs. 906 ################################################################################ 907 908 sub _perl_fingerprint { 909 my($self,$other_fingerprint) = @_; 910 my $dll = eval {OS2::DLLname()}; 911 my $mtime_dll = 0; 912 if (defined $dll) { 913 $mtime_dll = (-f $dll ? (stat(_))[9] : '-1'); 914 } 915 my $mtime_perl = (-f CPAN::find_perl ? (stat(_))[9] : '-1'); 916 my $this_fingerprint = { 917 '$^X' => CPAN::find_perl, 918 sitearchexp => $Config::Config{sitearchexp}, 919 'mtime_$^X' => $mtime_perl, 920 'mtime_dll' => $mtime_dll, 921 }; 922 if ($other_fingerprint) { 923 if (exists $other_fingerprint->{'stat($^X)'}) { # repair fp from rev. 1.88_57 924 $other_fingerprint->{'mtime_$^X'} = $other_fingerprint->{'stat($^X)'}[9]; 925 } 926 # mandatory keys since 1.88_57 927 for my $key (qw($^X sitearchexp mtime_dll mtime_$^X)) { 928 return unless $other_fingerprint->{$key} eq $this_fingerprint->{$key}; 929 } 930 return 1; 931 } else { 932 return $this_fingerprint; 933 } 934 } 935 936 sub suggest_myconfig () { 937 SUGGEST_MYCONFIG: if(!$INC{'CPAN/MyConfig.pm'}) { 938 $CPAN::Frontend->myprint("You don't seem to have a user ". 939 "configuration (MyConfig.pm) yet.\n"); 940 my $new = CPAN::Shell::colorable_makemaker_prompt("Do you want to create a ". 941 "user configuration now? (Y/n)", 942 "yes"); 943 if($new =~ m{^y}i) { 944 CPAN::Shell->mkmyconfig(); 945 return &checklock; 946 } else { 947 $CPAN::Frontend->mydie("OK, giving up."); 948 } 949 } 950 } 951 952 #-> sub CPAN::all_objects ; 953 sub all_objects { 954 my($mgr,$class) = @_; 955 CPAN::HandleConfig->load unless $CPAN::Config_loaded++; 956 CPAN->debug("mgr[$mgr] class[$class]") if $CPAN::DEBUG; 957 CPAN::Index->reload; 958 values %{ $META->{readwrite}{$class} }; # unsafe meta access, ok 959 } 960 961 # Called by shell, not in batch mode. In batch mode I see no risk in 962 # having many processes updating something as installations are 963 # continually checked at runtime. In shell mode I suspect it is 964 # unintentional to open more than one shell at a time 965 966 #-> sub CPAN::checklock ; 967 sub checklock { 968 my($self) = @_; 969 my $lockfile = File::Spec->catfile($CPAN::Config->{cpan_home},".lock"); 970 if (-f $lockfile && -M _ > 0) { 971 my $fh = FileHandle->new($lockfile) or 972 $CPAN::Frontend->mydie("Could not open lockfile '$lockfile': $!"); 973 my $otherpid = <$fh>; 974 my $otherhost = <$fh>; 975 $fh->close; 976 if (defined $otherpid && $otherpid) { 977 chomp $otherpid; 978 } 979 if (defined $otherhost && $otherhost) { 980 chomp $otherhost; 981 } 982 my $thishost = hostname(); 983 if (defined $otherhost && defined $thishost && 984 $otherhost ne '' && $thishost ne '' && 985 $otherhost ne $thishost) { 986 $CPAN::Frontend->mydie(sprintf("CPAN.pm panic: Lockfile '$lockfile'\n". 987 "reports other host $otherhost and other ". 988 "process $otherpid.\n". 989 "Cannot proceed.\n")); 990 } elsif ($RUN_DEGRADED) { 991 $CPAN::Frontend->mywarn("Running in degraded mode (experimental)\n"); 992 } elsif (defined $otherpid && $otherpid) { 993 return if $$ == $otherpid; # should never happen 994 $CPAN::Frontend->mywarn( 995 qq{ 996 There seems to be running another CPAN process (pid $otherpid). Contacting... 997 }); 998 if (kill 0, $otherpid) { 999 $CPAN::Frontend->mywarn(qq{Other job is running.\n}); 1000 my($ans) = 1001 CPAN::Shell::colorable_makemaker_prompt 1002 (qq{Shall I try to run in degraded }. 1003 qq{mode? (Y/n)},"y"); 1004 if ($ans =~ /^y/i) { 1005 $CPAN::Frontend->mywarn("Running in degraded mode (experimental). 1006 Please report if something unexpected happens\n"); 1007 $RUN_DEGRADED = 1; 1008 for ($CPAN::Config) { 1009 # XXX 1010 # $_->{build_dir_reuse} = 0; # 2006-11-17 akoenig Why was that? 1011 $_->{commandnumber_in_prompt} = 0; # visibility 1012 $_->{histfile} = ""; # who should win otherwise? 1013 $_->{cache_metadata} = 0; # better would be a lock? 1014 $_->{use_sqlite} = 0; # better would be a write lock! 1015 } 1016 } else { 1017 $CPAN::Frontend->mydie(" 1018 You may want to kill the other job and delete the lockfile. On UNIX try: 1019 kill $otherpid 1020 rm $lockfile 1021 "); 1022 } 1023 } elsif (-w $lockfile) { 1024 my($ans) = 1025 CPAN::Shell::colorable_makemaker_prompt 1026 (qq{Other job not responding. Shall I overwrite }. 1027 qq{the lockfile '$lockfile'? (Y/n)},"y"); 1028 $CPAN::Frontend->myexit("Ok, bye\n") 1029 unless $ans =~ /^y/i; 1030 } else { 1031 Carp::croak( 1032 qq{Lockfile '$lockfile' not writeable by you. }. 1033 qq{Cannot proceed.\n}. 1034 qq{ On UNIX try:\n}. 1035 qq{ rm '$lockfile'\n}. 1036 qq{ and then rerun us.\n} 1037 ); 1038 } 1039 } else { 1040 $CPAN::Frontend->mydie(sprintf("CPAN.pm panic: Found invalid lockfile ". 1041 "'$lockfile', please remove. Cannot proceed.\n")); 1042 } 1043 } 1044 my $dotcpan = $CPAN::Config->{cpan_home}; 1045 eval { File::Path::mkpath($dotcpan);}; 1046 if ($@) { 1047 # A special case at least for Jarkko. 1048 my $firsterror = $@; 1049 my $seconderror; 1050 my $symlinkcpan; 1051 if (-l $dotcpan) { 1052 $symlinkcpan = readlink $dotcpan; 1053 die "readlink $dotcpan failed: $!" unless defined $symlinkcpan; 1054 eval { File::Path::mkpath($symlinkcpan); }; 1055 if ($@) { 1056 $seconderror = $@; 1057 } else { 1058 $CPAN::Frontend->mywarn(qq{ 1059 Working directory $symlinkcpan created. 1060 }); 1061 } 1062 } 1063 unless (-d $dotcpan) { 1064 my $mess = qq{ 1065 Your configuration suggests "$dotcpan" as your 1066 CPAN.pm working directory. I could not create this directory due 1067 to this error: $firsterror\n}; 1068 $mess .= qq{ 1069 As "$dotcpan" is a symlink to "$symlinkcpan", 1070 I tried to create that, but I failed with this error: $seconderror 1071 } if $seconderror; 1072 $mess .= qq{ 1073 Please make sure the directory exists and is writable. 1074 }; 1075 $CPAN::Frontend->mywarn($mess); 1076 return suggest_myconfig; 1077 } 1078 } # $@ after eval mkpath $dotcpan 1079 if (0) { # to test what happens when a race condition occurs 1080 for (reverse 1..10) { 1081 print $_, "\n"; 1082 sleep 1; 1083 } 1084 } 1085 # locking 1086 if (!$RUN_DEGRADED && !$self->{LOCKFH}) { 1087 my $fh; 1088 unless ($fh = FileHandle->new("+>>$lockfile")) { 1089 if ($! =~ /Permission/) { 1090 $CPAN::Frontend->mywarn(qq{ 1091 1092 Your configuration suggests that CPAN.pm should use a working 1093 directory of 1094 $CPAN::Config->{cpan_home} 1095 Unfortunately we could not create the lock file 1096 $lockfile 1097 due to permission problems. 1098 1099 Please make sure that the configuration variable 1100 \$CPAN::Config->{cpan_home} 1101 points to a directory where you can write a .lock file. You can set 1102 this variable in either a CPAN/MyConfig.pm or a CPAN/Config.pm in your 1103 \@INC path; 1104 }); 1105 return suggest_myconfig; 1106 } 1107 } 1108 my $sleep = 1; 1109 while (!CPAN::_flock($fh, LOCK_EX|LOCK_NB)) { 1110 if ($sleep>10) { 1111 $CPAN::Frontend->mydie("Giving up\n"); 1112 } 1113 $CPAN::Frontend->mysleep($sleep++); 1114 $CPAN::Frontend->mywarn("Could not lock lockfile with flock: $!; retrying\n"); 1115 } 1116 1117 seek $fh, 0, 0; 1118 truncate $fh, 0; 1119 $fh->autoflush(1); 1120 $fh->print($$, "\n"); 1121 $fh->print(hostname(), "\n"); 1122 $self->{LOCK} = $lockfile; 1123 $self->{LOCKFH} = $fh; 1124 } 1125 $SIG{TERM} = sub { 1126 my $sig = shift; 1127 &cleanup; 1128 $CPAN::Frontend->mydie("Got SIG$sig, leaving"); 1129 }; 1130 $SIG{INT} = sub { 1131 # no blocks!!! 1132 my $sig = shift; 1133 &cleanup if $Signal; 1134 die "Got yet another signal" if $Signal > 1; 1135 $CPAN::Frontend->mydie("Got another SIG$sig") if $Signal; 1136 $CPAN::Frontend->mywarn("Caught SIG$sig, trying to continue\n"); 1137 $Signal++; 1138 }; 1139 1140 # From: Larry Wall <larry@wall.org> 1141 # Subject: Re: deprecating SIGDIE 1142 # To: perl5-porters@perl.org 1143 # Date: Thu, 30 Sep 1999 14:58:40 -0700 (PDT) 1144 # 1145 # The original intent of __DIE__ was only to allow you to substitute one 1146 # kind of death for another on an application-wide basis without respect 1147 # to whether you were in an eval or not. As a global backstop, it should 1148 # not be used any more lightly (or any more heavily :-) than class 1149 # UNIVERSAL. Any attempt to build a general exception model on it should 1150 # be politely squashed. Any bug that causes every eval {} to have to be 1151 # modified should be not so politely squashed. 1152 # 1153 # Those are my current opinions. It is also my optinion that polite 1154 # arguments degenerate to personal arguments far too frequently, and that 1155 # when they do, it's because both people wanted it to, or at least didn't 1156 # sufficiently want it not to. 1157 # 1158 # Larry 1159 1160 # global backstop to cleanup if we should really die 1161 $SIG{__DIE__} = \&cleanup; 1162 $self->debug("Signal handler set.") if $CPAN::DEBUG; 1163 } 1164 1165 #-> sub CPAN::DESTROY ; 1166 sub DESTROY { 1167 &cleanup; # need an eval? 1168 } 1169 1170 #-> sub CPAN::anycwd ; 1171 sub anycwd () { 1172 my $getcwd; 1173 $getcwd = $CPAN::Config->{'getcwd'} || 'cwd'; 1174 CPAN->$getcwd(); 1175 } 1176 1177 #-> sub CPAN::cwd ; 1178 sub cwd {Cwd::cwd();} 1179 1180 #-> sub CPAN::getcwd ; 1181 sub getcwd {Cwd::getcwd();} 1182 1183 #-> sub CPAN::fastcwd ; 1184 sub fastcwd {Cwd::fastcwd();} 1185 1186 #-> sub CPAN::backtickcwd ; 1187 sub backtickcwd {my $cwd = `cwd`; chomp $cwd; $cwd} 1188 1189 #-> sub CPAN::find_perl ; 1190 sub find_perl () { 1191 my($perl) = File::Spec->file_name_is_absolute($^X) ? $^X : ""; 1192 my $pwd = $CPAN::iCwd = CPAN::anycwd(); 1193 my $candidate = File::Spec->catfile($pwd,$^X); 1194 $perl ||= $candidate if MM->maybe_command($candidate); 1195 1196 unless ($perl) { 1197 my ($component,$perl_name); 1198 DIST_PERLNAME: foreach $perl_name ($^X, 'perl', 'perl5', "perl$]") { 1199 PATH_COMPONENT: foreach $component (File::Spec->path(), 1200 $Config::Config{'binexp'}) { 1201 next unless defined($component) && $component; 1202 my($abs) = File::Spec->catfile($component,$perl_name); 1203 if (MM->maybe_command($abs)) { 1204 $perl = $abs; 1205 last DIST_PERLNAME; 1206 } 1207 } 1208 } 1209 } 1210 1211 return $perl; 1212 } 1213 1214 1215 #-> sub CPAN::exists ; 1216 sub exists { 1217 my($mgr,$class,$id) = @_; 1218 CPAN::HandleConfig->load unless $CPAN::Config_loaded++; 1219 CPAN::Index->reload; 1220 ### Carp::croak "exists called without class argument" unless $class; 1221 $id ||= ""; 1222 $id =~ s/:+/::/g if $class eq "CPAN::Module"; 1223 my $exists; 1224 if (CPAN::_sqlite_running) { 1225 $exists = (exists $META->{readonly}{$class}{$id} or 1226 $CPAN::SQLite->set($class, $id)); 1227 } else { 1228 $exists = exists $META->{readonly}{$class}{$id}; 1229 } 1230 $exists ||= exists $META->{readwrite}{$class}{$id}; # unsafe meta access, ok 1231 } 1232 1233 #-> sub CPAN::delete ; 1234 sub delete { 1235 my($mgr,$class,$id) = @_; 1236 delete $META->{readonly}{$class}{$id}; # unsafe meta access, ok 1237 delete $META->{readwrite}{$class}{$id}; # unsafe meta access, ok 1238 } 1239 1240 #-> sub CPAN::has_usable 1241 # has_inst is sometimes too optimistic, we should replace it with this 1242 # has_usable whenever a case is given 1243 sub has_usable { 1244 my($self,$mod,$message) = @_; 1245 return 1 if $HAS_USABLE->{$mod}; 1246 my $has_inst = $self->has_inst($mod,$message); 1247 return unless $has_inst; 1248 my $usable; 1249 $usable = { 1250 LWP => [ # we frequently had "Can't locate object 1251 # method "new" via package "LWP::UserAgent" at 1252 # (eval 69) line 2006 1253 sub {require LWP}, 1254 sub {require LWP::UserAgent}, 1255 sub {require HTTP::Request}, 1256 sub {require URI::URL}, 1257 ], 1258 'Net::FTP' => [ 1259 sub {require Net::FTP}, 1260 sub {require Net::Config}, 1261 ], 1262 'File::HomeDir' => [ 1263 sub {require File::HomeDir; 1264 unless (CPAN::Version->vge(File::HomeDir::->VERSION, 0.52)) { 1265 for ("Will not use File::HomeDir, need 0.52\n") { 1266 $CPAN::Frontend->mywarn($_); 1267 die $_; 1268 } 1269 } 1270 }, 1271 ], 1272 'Archive::Tar' => [ 1273 sub {require Archive::Tar; 1274 unless (CPAN::Version->vge(Archive::Tar::->VERSION, 1.00)) { 1275 for ("Will not use Archive::Tar, need 1.00\n") { 1276 $CPAN::Frontend->mywarn($_); 1277 die $_; 1278 } 1279 } 1280 }, 1281 ], 1282 'File::Temp' => [ 1283 # XXX we should probably delete from 1284 # %INC too so we can load after we 1285 # installed a new enough version -- 1286 # I'm not sure. 1287 sub {require File::Temp; 1288 unless (CPAN::Version->vge(File::Temp::->VERSION,0.16)) { 1289 for ("Will not use File::Temp, need 0.16\n") { 1290 $CPAN::Frontend->mywarn($_); 1291 die $_; 1292 } 1293 } 1294 }, 1295 ] 1296 }; 1297 if ($usable->{$mod}) { 1298 for my $c (0..$#{$usable->{$mod}}) { 1299 my $code = $usable->{$mod}[$c]; 1300 my $ret = eval { &$code() }; 1301 $ret = "" unless defined $ret; 1302 if ($@) { 1303 # warn "DEBUG: c[$c]\$\@[$@]ret[$ret]"; 1304 return; 1305 } 1306 } 1307 } 1308 return $HAS_USABLE->{$mod} = 1; 1309 } 1310 1311 #-> sub CPAN::has_inst 1312 sub has_inst { 1313 my($self,$mod,$message) = @_; 1314 Carp::croak("CPAN->has_inst() called without an argument") 1315 unless defined $mod; 1316 my %dont = map { $_ => 1 } keys %{$CPAN::META->{dontload_hash}||{}}, 1317 keys %{$CPAN::Config->{dontload_hash}||{}}, 1318 @{$CPAN::Config->{dontload_list}||[]}; 1319 if (defined $message && $message eq "no" # afair only used by Nox 1320 || 1321 $dont{$mod} 1322 ) { 1323 $CPAN::META->{dontload_hash}{$mod}||=1; # unsafe meta access, ok 1324 return 0; 1325 } 1326 my $file = $mod; 1327 my $obj; 1328 $file =~ s|::|/|g; 1329 $file .= ".pm"; 1330 if ($INC{$file}) { 1331 # checking %INC is wrong, because $INC{LWP} may be true 1332 # although $INC{"URI/URL.pm"} may have failed. But as 1333 # I really want to say "bla loaded OK", I have to somehow 1334 # cache results. 1335 ### warn "$file in %INC"; #debug 1336 return 1; 1337 } elsif (eval { require $file }) { 1338 # eval is good: if we haven't yet read the database it's 1339 # perfect and if we have installed the module in the meantime, 1340 # it tries again. The second require is only a NOOP returning 1341 # 1 if we had success, otherwise it's retrying 1342 1343 my $mtime = (stat $INC{$file})[9]; 1344 # privileged files loaded by has_inst; Note: we use $mtime 1345 # as a proxy for a checksum. 1346 $CPAN::Shell::reload->{$file} = $mtime; 1347 my $v = eval "\$$mod\::VERSION"; 1348 $v = $v ? " (v$v)" : ""; 1349 CPAN::Shell->optprint("load_module","CPAN: $mod loaded ok$v\n"); 1350 if ($mod eq "CPAN::WAIT") { 1351 push @CPAN::Shell::ISA, 'CPAN::WAIT'; 1352 } 1353 return 1; 1354 } elsif ($mod eq "Net::FTP") { 1355 $CPAN::Frontend->mywarn(qq{ 1356 Please, install Net::FTP as soon as possible. CPAN.pm installs it for you 1357 if you just type 1358 install Bundle::libnet 1359 1360 }) unless $Have_warned->{"Net::FTP"}++; 1361 $CPAN::Frontend->mysleep(3); 1362 } elsif ($mod eq "Digest::SHA") { 1363 if ($Have_warned->{"Digest::SHA"}++) { 1364 $CPAN::Frontend->mywarn(qq{CPAN: checksum security checks disabled }. 1365 qq{because Digest::SHA not installed.\n}); 1366 } else { 1367 $CPAN::Frontend->mywarn(qq{ 1368 CPAN: checksum security checks disabled because Digest::SHA not installed. 1369 Please consider installing the Digest::SHA module. 1370 1371 }); 1372 $CPAN::Frontend->mysleep(2); 1373 } 1374 } elsif ($mod eq "Module::Signature") { 1375 # NOT prefs_lookup, we are not a distro 1376 my $check_sigs = $CPAN::Config->{check_sigs}; 1377 if (not $check_sigs) { 1378 # they do not want us:-( 1379 } elsif (not $Have_warned->{"Module::Signature"}++) { 1380 # No point in complaining unless the user can 1381 # reasonably install and use it. 1382 if (eval { require Crypt::OpenPGP; 1 } || 1383 ( 1384 defined $CPAN::Config->{'gpg'} 1385 && 1386 $CPAN::Config->{'gpg'} =~ /\S/ 1387 ) 1388 ) { 1389 $CPAN::Frontend->mywarn(qq{ 1390 CPAN: Module::Signature security checks disabled because Module::Signature 1391 not installed. Please consider installing the Module::Signature module. 1392 You may also need to be able to connect over the Internet to the public 1393 keyservers like pgp.mit.edu (port 11371). 1394 1395 }); 1396 $CPAN::Frontend->mysleep(2); 1397 } 1398 } 1399 } else { 1400 delete $INC{$file}; # if it inc'd LWP but failed during, say, URI 1401 } 1402 return 0; 1403 } 1404 1405 #-> sub CPAN::instance ; 1406 sub instance { 1407 my($mgr,$class,$id) = @_; 1408 CPAN::Index->reload; 1409 $id ||= ""; 1410 # unsafe meta access, ok? 1411 return $META->{readwrite}{$class}{$id} if exists $META->{readwrite}{$class}{$id}; 1412 $META->{readwrite}{$class}{$id} ||= $class->new(ID => $id); 1413 } 1414 1415 #-> sub CPAN::new ; 1416 sub new { 1417 bless {}, shift; 1418 } 1419 1420 #-> sub CPAN::cleanup ; 1421 sub cleanup { 1422 # warn "cleanup called with arg[@_] End[$CPAN::End] Signal[$Signal]"; 1423 local $SIG{__DIE__} = ''; 1424 my($message) = @_; 1425 my $i = 0; 1426 my $ineval = 0; 1427 my($subroutine); 1428 while ((undef,undef,undef,$subroutine) = caller(++$i)) { 1429 $ineval = 1, last if 1430 $subroutine eq '(eval)'; 1431 } 1432 return if $ineval && !$CPAN::End; 1433 return unless defined $META->{LOCK}; 1434 return unless -f $META->{LOCK}; 1435 $META->savehist; 1436 close $META->{LOCKFH}; 1437 unlink $META->{LOCK}; 1438 # require Carp; 1439 # Carp::cluck("DEBUGGING"); 1440 if ( $CPAN::CONFIG_DIRTY ) { 1441 $CPAN::Frontend->mywarn("Warning: Configuration not saved.\n"); 1442 } 1443 $CPAN::Frontend->myprint("Lockfile removed.\n"); 1444 } 1445 1446 #-> sub CPAN::readhist 1447 sub readhist { 1448 my($self,$term,$histfile) = @_; 1449 my($fh) = FileHandle->new; 1450 open $fh, "<$histfile" or last; 1451 local $/ = "\n"; 1452 while (<$fh>) { 1453 chomp; 1454 $term->AddHistory($_); 1455 } 1456 close $fh; 1457 } 1458 1459 #-> sub CPAN::savehist 1460 sub savehist { 1461 my($self) = @_; 1462 my($histfile,$histsize); 1463 unless ($histfile = $CPAN::Config->{'histfile'}) { 1464 $CPAN::Frontend->mywarn("No history written (no histfile specified).\n"); 1465 return; 1466 } 1467 $histsize = $CPAN::Config->{'histsize'} || 100; 1468 if ($CPAN::term) { 1469 unless ($CPAN::term->can("GetHistory")) { 1470 $CPAN::Frontend->mywarn("Terminal does not support GetHistory.\n"); 1471 return; 1472 } 1473 } else { 1474 return; 1475 } 1476 my @h = $CPAN::term->GetHistory; 1477 splice @h, 0, @h-$histsize if @h>$histsize; 1478 my($fh) = FileHandle->new; 1479 open $fh, ">$histfile" or $CPAN::Frontend->mydie("Couldn't open >$histfile: $!"); 1480 local $\ = local $, = "\n"; 1481 print $fh @h; 1482 close $fh; 1483 } 1484 1485 #-> sub CPAN::is_tested 1486 sub is_tested { 1487 my($self,$what,$when) = @_; 1488 unless ($what) { 1489 Carp::cluck("DEBUG: empty what"); 1490 return; 1491 } 1492 $self->{is_tested}{$what} = $when; 1493 } 1494 1495 #-> sub CPAN::is_installed 1496 # unsets the is_tested flag: as soon as the thing is installed, it is 1497 # not needed in set_perl5lib anymore 1498 sub is_installed { 1499 my($self,$what) = @_; 1500 delete $self->{is_tested}{$what}; 1501 } 1502 1503 sub _list_sorted_descending_is_tested { 1504 my($self) = @_; 1505 sort 1506 { ($self->{is_tested}{$b}||0) <=> ($self->{is_tested}{$a}||0) } 1507 keys %{$self->{is_tested}} 1508 } 1509 1510 #-> sub CPAN::set_perl5lib 1511 sub set_perl5lib { 1512 my($self,$for) = @_; 1513 unless ($for) { 1514 (undef,undef,undef,$for) = caller(1); 1515 $for =~ s/.*://; 1516 } 1517 $self->{is_tested} ||= {}; 1518 return unless %{$self->{is_tested}}; 1519 my $env = $ENV{PERL5LIB}; 1520 $env = $ENV{PERLLIB} unless defined $env; 1521 my @env; 1522 push @env, $env if defined $env and length $env; 1523 #my @dirs = map {("$_/blib/arch", "$_/blib/lib")} keys %{$self->{is_tested}}; 1524 #$CPAN::Frontend->myprint("Prepending @dirs to PERL5LIB.\n"); 1525 1526 my @dirs = map {("$_/blib/arch", "$_/blib/lib")} $self->_list_sorted_descending_is_tested; 1527 if (@dirs < 12) { 1528 $CPAN::Frontend->myprint("Prepending @dirs to PERL5LIB for '$for'\n"); 1529 } elsif (@dirs < 24) { 1530 my @d = map {my $cp = $_; 1531 $cp =~ s/^\Q$CPAN::Config->{build_dir}\E/%BUILDDIR%/; 1532 $cp 1533 } @dirs; 1534 $CPAN::Frontend->myprint("Prepending @d to PERL5LIB; ". 1535 "%BUILDDIR%=$CPAN::Config->{build_dir} ". 1536 "for '$for'\n" 1537 ); 1538 } else { 1539 my $cnt = keys %{$self->{is_tested}}; 1540 $CPAN::Frontend->myprint("Prepending blib/arch and blib/lib of ". 1541 "$cnt build dirs to PERL5LIB; ". 1542 "for '$for'\n" 1543 ); 1544 } 1545 1546 $ENV{PERL5LIB} = join $Config::Config{path_sep}, @dirs, @env; 1547 } 1548 1549 package CPAN::CacheMgr; 1550 use strict; 1551 1552 #-> sub CPAN::CacheMgr::as_string ; 1553 sub as_string { 1554 eval { require Data::Dumper }; 1555 if ($@) { 1556 return shift->SUPER::as_string; 1557 } else { 1558 return Data::Dumper::Dumper(shift); 1559 } 1560 } 1561 1562 #-> sub CPAN::CacheMgr::cachesize ; 1563 sub cachesize { 1564 shift->{DU}; 1565 } 1566 1567 #-> sub CPAN::CacheMgr::tidyup ; 1568 sub tidyup { 1569 my($self) = @_; 1570 return unless $CPAN::META->{LOCK}; 1571 return unless -d $self->{ID}; 1572 my @toremove = grep { $self->{SIZE}{$_}==0 } @{$self->{FIFO}}; 1573 for my $current (0..$#toremove) { 1574 my $toremove = $toremove[$current]; 1575 $CPAN::Frontend->myprint(sprintf( 1576 "DEL(%d/%d): %s \n", 1577 $current+1, 1578 scalar @toremove, 1579 $toremove, 1580 ) 1581 ); 1582 return if $CPAN::Signal; 1583 $self->_clean_cache($toremove); 1584 return if $CPAN::Signal; 1585 } 1586 } 1587 1588 #-> sub CPAN::CacheMgr::dir ; 1589 sub dir { 1590 shift->{ID}; 1591 } 1592 1593 #-> sub CPAN::CacheMgr::entries ; 1594 sub entries { 1595 my($self,$dir) = @_; 1596 return unless defined $dir; 1597 $self->debug("reading dir[$dir]") if $CPAN::DEBUG; 1598 $dir ||= $self->{ID}; 1599 my($cwd) = CPAN::anycwd(); 1600 chdir $dir or Carp::croak("Can't chdir to $dir: $!"); 1601 my $dh = DirHandle->new(File::Spec->curdir) 1602 or Carp::croak("Couldn't opendir $dir: $!"); 1603 my(@entries); 1604 for ($dh->read) { 1605 next if $_ eq "." || $_ eq ".."; 1606 if (-f $_) { 1607 push @entries, File::Spec->catfile($dir,$_); 1608 } elsif (-d _) { 1609 push @entries, File::Spec->catdir($dir,$_); 1610 } else { 1611 $CPAN::Frontend->mywarn("Warning: weird direntry in $dir: $_\n"); 1612 } 1613 } 1614 chdir $cwd or Carp::croak("Can't chdir to $cwd: $!"); 1615 sort { -M $a <=> -M $b} @entries; 1616 } 1617 1618 #-> sub CPAN::CacheMgr::disk_usage ; 1619 sub disk_usage { 1620 my($self,$dir,$fast) = @_; 1621 return if exists $self->{SIZE}{$dir}; 1622 return if $CPAN::Signal; 1623 my($Du) = 0; 1624 if (-e $dir) { 1625 if (-d $dir) { 1626 unless (-x $dir) { 1627 unless (chmod 0755, $dir) { 1628 $CPAN::Frontend->mywarn("I have neither the -x permission nor the ". 1629 "permission to change the permission; cannot ". 1630 "estimate disk usage of '$dir'\n"); 1631 $CPAN::Frontend->mysleep(5); 1632 return; 1633 } 1634 } 1635 } elsif (-f $dir) { 1636 # nothing to say, no matter what the permissions 1637 } 1638 } else { 1639 $CPAN::Frontend->mywarn("File or directory '$dir' has gone, ignoring\n"); 1640 return; 1641 } 1642 if ($fast) { 1643 $Du = 0; # placeholder 1644 } else { 1645 find( 1646 sub { 1647 $File::Find::prune++ if $CPAN::Signal; 1648 return if -l $_; 1649 if ($^O eq 'MacOS') { 1650 require Mac::Files; 1651 my $cat = Mac::Files::FSpGetCatInfo($_); 1652 $Du += $cat->ioFlLgLen() + $cat->ioFlRLgLen() if $cat; 1653 } else { 1654 if (-d _) { 1655 unless (-x _) { 1656 unless (chmod 0755, $_) { 1657 $CPAN::Frontend->mywarn("I have neither the -x permission nor ". 1658 "the permission to change the permission; ". 1659 "can only partially estimate disk usage ". 1660 "of '$_'\n"); 1661 $CPAN::Frontend->mysleep(5); 1662 return; 1663 } 1664 } 1665 } else { 1666 $Du += (-s _); 1667 } 1668 } 1669 }, 1670 $dir 1671 ); 1672 } 1673 return if $CPAN::Signal; 1674 $self->{SIZE}{$dir} = $Du/1024/1024; 1675 unshift @{$self->{FIFO}}, $dir; 1676 $self->debug("measured $dir is $Du") if $CPAN::DEBUG; 1677 $self->{DU} += $Du/1024/1024; 1678 $self->{DU}; 1679 } 1680 1681 #-> sub CPAN::CacheMgr::_clean_cache ; 1682 sub _clean_cache { 1683 my($self,$dir) = @_; 1684 return unless -e $dir; 1685 unless (File::Spec->canonpath(File::Basename::dirname($dir)) 1686 eq File::Spec->canonpath($CPAN::Config->{build_dir})) { 1687 $CPAN::Frontend->mywarn("Directory '$dir' not below $CPAN::Config->{build_dir}, ". 1688 "will not remove\n"); 1689 $CPAN::Frontend->mysleep(5); 1690 return; 1691 } 1692 $self->debug("have to rmtree $dir, will free $self->{SIZE}{$dir}") 1693 if $CPAN::DEBUG; 1694 File::Path::rmtree($dir); 1695 my $id_deleted = 0; 1696 if ($dir !~ /\.yml$/ && -f "$dir.yml") { 1697 my $yaml_module = CPAN::_yaml_module; 1698 if ($CPAN::META->has_inst($yaml_module)) { 1699 my($peek_yaml) = eval { CPAN->_yaml_loadfile("$dir.yml"); }; 1700 if ($@) { 1701 $CPAN::Frontend->mywarn("(parse error on '$dir.yml' removing anyway)"); 1702 unlink "$dir.yml" or 1703 $CPAN::Frontend->mywarn("(Could not unlink '$dir.yml': $!)"); 1704 return; 1705 } elsif (my $id = $peek_yaml->[0]{distribution}{ID}) { 1706 $CPAN::META->delete("CPAN::Distribution", $id); 1707 1708 # XXX we should restore the state NOW, otherise this 1709 # distro does not exist until we read an index. BUG ALERT(?) 1710 1711 # $CPAN::Frontend->mywarn (" +++\n"); 1712 $id_deleted++; 1713 } 1714 } 1715 unlink "$dir.yml"; # may fail 1716 unless ($id_deleted) { 1717 CPAN->debug("no distro found associated with '$dir'"); 1718 } 1719 } 1720 $self->{DU} -= $self->{SIZE}{$dir}; 1721 delete $self->{SIZE}{$dir}; 1722 } 1723 1724 #-> sub CPAN::CacheMgr::new ; 1725 sub new { 1726 my $class = shift; 1727 my $time = time; 1728 my($debug,$t2); 1729 $debug = ""; 1730 my $self = { 1731 ID => $CPAN::Config->{build_dir}, 1732 MAX => $CPAN::Config->{'build_cache'}, 1733 SCAN => $CPAN::Config->{'scan_cache'} || 'atstart', 1734 DU => 0 1735 }; 1736 File::Path::mkpath($self->{ID}); 1737 my $dh = DirHandle->new($self->{ID}); 1738 bless $self, $class; 1739 $self->scan_cache; 1740 $t2 = time; 1741 $debug .= "timing of CacheMgr->new: ".($t2 - $time); 1742 $time = $t2; 1743 CPAN->debug($debug) if $CPAN::DEBUG; 1744 $self; 1745 } 1746 1747 #-> sub CPAN::CacheMgr::scan_cache ; 1748 sub scan_cache { 1749 my $self = shift; 1750 return if $self->{SCAN} eq 'never'; 1751 $CPAN::Frontend->mydie("Unknown scan_cache argument: $self->{SCAN}") 1752 unless $self->{SCAN} eq 'atstart'; 1753 return unless $CPAN::META->{LOCK}; 1754 $CPAN::Frontend->myprint( 1755 sprintf("Scanning cache %s for sizes\n", 1756 $self->{ID})); 1757 my $e; 1758 my @entries = $self->entries($self->{ID}); 1759 my $i = 0; 1760 my $painted = 0; 1761 for $e (@entries) { 1762 my $symbol = "."; 1763 if ($self->{DU} > $self->{MAX}) { 1764 $symbol = "-"; 1765 $self->disk_usage($e,1); 1766 } else { 1767 $self->disk_usage($e); 1768 } 1769 $i++; 1770 while (($painted/76) < ($i/@entries)) { 1771 $CPAN::Frontend->myprint($symbol); 1772 $painted++; 1773 } 1774 return if $CPAN::Signal; 1775 } 1776 $CPAN::Frontend->myprint("DONE\n"); 1777 $self->tidyup; 1778 } 1779 1780 package CPAN::Shell; 1781 use strict; 1782 1783 #-> sub CPAN::Shell::h ; 1784 sub h { 1785 my($class,$about) = @_; 1786 if (defined $about) { 1787 my $help; 1788 if (exists $Help->{$about}) { 1789 if (ref $Help->{$about}) { # aliases 1790 $about = ${$Help->{$about}}; 1791 } 1792 $help = $Help->{$about}; 1793 } else { 1794 $help = "No help available"; 1795 } 1796 $CPAN::Frontend->myprint("$about\: $help\n"); 1797 } else { 1798 my $filler = " " x (80 - 28 - length($CPAN::VERSION)); 1799 $CPAN::Frontend->myprint(qq{ 1800 Display Information $filler (ver $CPAN::VERSION) 1801 command argument description 1802 a,b,d,m WORD or /REGEXP/ about authors, bundles, distributions, modules 1803 i WORD or /REGEXP/ about any of the above 1804 ls AUTHOR or GLOB about files in the author's directory 1805 (with WORD being a module, bundle or author name or a distribution 1806 name of the form AUTHOR/DISTRIBUTION) 1807 1808 Download, Test, Make, Install... 1809 get download clean make clean 1810 make make (implies get) look open subshell in dist directory 1811 test make test (implies make) readme display these README files 1812 install make install (implies test) perldoc display POD documentation 1813 1814 Upgrade 1815 r WORDs or /REGEXP/ or NONE report updates for some/matching/all modules 1816 upgrade WORDs or /REGEXP/ or NONE upgrade some/matching/all modules 1817 1818 Pragmas 1819 force CMD try hard to do command fforce CMD try harder 1820 notest CMD skip testing 1821 1822 Other 1823 h,? display this menu ! perl-code eval a perl command 1824 o conf [opt] set and query options q quit the cpan shell 1825 reload cpan load CPAN.pm again reload index load newer indices 1826 autobundle Snapshot recent latest CPAN uploads}); 1827 } 1828 } 1829 1830 *help = \&h; 1831 1832 #-> sub CPAN::Shell::a ; 1833 sub a { 1834 my($self,@arg) = @_; 1835 # authors are always UPPERCASE 1836 for (@arg) { 1837 $_ = uc $_ unless /=/; 1838 } 1839 $CPAN::Frontend->myprint($self->format_result('Author',@arg)); 1840 } 1841 1842 #-> sub CPAN::Shell::globls ; 1843 sub globls { 1844 my($self,$s,$pragmas) = @_; 1845 # ls is really very different, but we had it once as an ordinary 1846 # command in the Shell (upto rev. 321) and we could not handle 1847 # force well then 1848 my(@accept,@preexpand); 1849 if ($s =~ /[\*\?\/]/) { 1850 if ($CPAN::META->has_inst("Text::Glob")) { 1851 if (my($au,$pathglob) = $s =~ m|(.*?)/(.*)|) { 1852 my $rau = Text::Glob::glob_to_regex(uc $au); 1853 CPAN::Shell->debug("au[$au]pathglob[$pathglob]rau[$rau]") 1854 if $CPAN::DEBUG; 1855 push @preexpand, map { $_->id . "/" . $pathglob } 1856 CPAN::Shell->expand_by_method('CPAN::Author',['id'],"/$rau/"); 1857 } else { 1858 my $rau = Text::Glob::glob_to_regex(uc $s); 1859 push @preexpand, map { $_->id } 1860 CPAN::Shell->expand_by_method('CPAN::Author', 1861 ['id'], 1862 "/$rau/"); 1863 } 1864 } else { 1865 $CPAN::Frontend->mydie("Text::Glob not installed, cannot proceed"); 1866 } 1867 } else { 1868 push @preexpand, uc $s; 1869 } 1870 for (@preexpand) { 1871 unless (/^[A-Z0-9\-]+(\/|$)/i) { 1872 $CPAN::Frontend->mywarn("ls command rejects argument $_: not an author\n"); 1873 next; 1874 } 1875 push @accept, $_; 1876 } 1877 my $silent = @accept>1; 1878 my $last_alpha = ""; 1879 my @results; 1880 for my $a (@accept) { 1881 my($author,$pathglob); 1882 if ($a =~ m|(.*?)/(.*)|) { 1883 my $a2 = $1; 1884 $pathglob = $2; 1885 $author = CPAN::Shell->expand_by_method('CPAN::Author', 1886 ['id'], 1887 $a2) 1888 or $CPAN::Frontend->mydie("No author found for $a2\n"); 1889 } else { 1890 $author = CPAN::Shell->expand_by_method('CPAN::Author', 1891 ['id'], 1892 $a) 1893 or $CPAN::Frontend->mydie("No author found for $a\n"); 1894 } 1895 if ($silent) { 1896 my $alpha = substr $author->id, 0, 1; 1897 my $ad; 1898 if ($alpha eq $last_alpha) { 1899 $ad = ""; 1900 } else { 1901 $ad = "[$alpha]"; 1902 $last_alpha = $alpha; 1903 } 1904 $CPAN::Frontend->myprint($ad); 1905 } 1906 for my $pragma (@$pragmas) { 1907 if ($author->can($pragma)) { 1908 $author->$pragma(); 1909 } 1910 } 1911 push @results, $author->ls($pathglob,$silent); # silent if 1912 # more than one 1913 # author 1914 for my $pragma (@$pragmas) { 1915 my $unpragma = "un$pragma"; 1916 if ($author->can($unpragma)) { 1917 $author->$unpragma(); 1918 } 1919 } 1920 } 1921 @results; 1922 } 1923 1924 #-> sub CPAN::Shell::local_bundles ; 1925 sub local_bundles { 1926 my($self,@which) = @_; 1927 my($incdir,$bdir,$dh); 1928 foreach $incdir ($CPAN::Config->{'cpan_home'},@INC) { 1929 my @bbase = "Bundle"; 1930 while (my $bbase = shift @bbase) { 1931 $bdir = File::Spec->catdir($incdir,split /::/, $bbase); 1932 CPAN->debug("bdir[$bdir]\@bbase[@bbase]") if $CPAN::DEBUG; 1933 if ($dh = DirHandle->new($bdir)) { # may fail 1934 my($entry); 1935 for $entry ($dh->read) { 1936 next if $entry =~ /^\./; 1937 next unless $entry =~ /^\w+(\.pm)?(?!\n)\Z/; 1938 if (-d File::Spec->catdir($bdir,$entry)) { 1939 push @bbase, "$bbase\::$entry"; 1940 } else { 1941 next unless $entry =~ s/\.pm(?!\n)\Z//; 1942 $CPAN::META->instance('CPAN::Bundle',"$bbase\::$entry"); 1943 } 1944 } 1945 } 1946 } 1947 } 1948 } 1949 1950 #-> sub CPAN::Shell::b ; 1951 sub b { 1952 my($self,@which) = @_; 1953 CPAN->debug("which[@which]") if $CPAN::DEBUG; 1954 $self->local_bundles; 1955 $CPAN::Frontend->myprint($self->format_result('Bundle',@which)); 1956 } 1957 1958 #-> sub CPAN::Shell::d ; 1959 sub d { $CPAN::Frontend->myprint(shift->format_result('Distribution',@_));} 1960 1961 #-> sub CPAN::Shell::m ; 1962 sub m { # emacs confused here }; sub mimimimimi { # emacs in sync here 1963 my $self = shift; 1964 $CPAN::Frontend->myprint($self->format_result('Module',@_)); 1965 } 1966 1967 #-> sub CPAN::Shell::i ; 1968 sub i { 1969 my($self) = shift; 1970 my(@args) = @_; 1971 @args = '/./' unless @args; 1972 my(@result); 1973 for my $type (qw/Bundle Distribution Module/) { 1974 push @result, $self->expand($type,@args); 1975 } 1976 # Authors are always uppercase. 1977 push @result, $self->expand("Author", map { uc $_ } @args); 1978 1979 my $result = @result == 1 ? 1980 $result[0]->as_string : 1981 @result == 0 ? 1982 "No objects found of any type for argument @args\n" : 1983 join("", 1984 (map {$_->as_glimpse} @result), 1985 scalar @result, " items found\n", 1986 ); 1987 $CPAN::Frontend->myprint($result); 1988 } 1989 1990 #-> sub CPAN::Shell::o ; 1991 1992 # CPAN::Shell::o and CPAN::HandleConfig::edit are closely related. 'o 1993 # conf' calls through to CPAN::HandleConfig::edit. 'o conf' should 1994 # probably have been called 'set' and 'o debug' maybe 'set debug' or 1995 # 'debug'; 'o conf ARGS' calls ->edit in CPAN/HandleConfig.pm 1996 sub o { 1997 my($self,$o_type,@o_what) = @_; 1998 $o_type ||= ""; 1999 CPAN->debug("o_type[$o_type] o_what[".join(" | ",@o_what)."]\n"); 2000 if ($o_type eq 'conf') { 2001 my($cfilter); 2002 ($cfilter) = $o_what[0] =~ m|^/(.*)/$| if @o_what; 2003 if (!@o_what or $cfilter) { # print all things, "o conf" 2004 $cfilter ||= ""; 2005 my $qrfilter = eval 'qr/$cfilter/'; 2006 my($k,$v); 2007 $CPAN::Frontend->myprint("\$CPAN::Config options from "); 2008 my @from; 2009 if (exists $INC{'CPAN/Config.pm'}) { 2010 push @from, $INC{'CPAN/Config.pm'}; 2011 } 2012 if (exists $INC{'CPAN/MyConfig.pm'}) { 2013 push @from, $INC{'CPAN/MyConfig.pm'}; 2014 } 2015 $CPAN::Frontend->myprint(join " and ", map {"'$_'"} @from); 2016 $CPAN::Frontend->myprint(":\n"); 2017 for $k (sort keys %CPAN::HandleConfig::can) { 2018 next unless $k =~ /$qrfilter/; 2019 $v = $CPAN::HandleConfig::can{$k}; 2020 $CPAN::Frontend->myprint(sprintf " %-18s [%s]\n", $k, $v); 2021 } 2022 $CPAN::Frontend->myprint("\n"); 2023 for $k (sort keys %CPAN::HandleConfig::keys) { 2024 next unless $k =~ /$qrfilter/; 2025 CPAN::HandleConfig->prettyprint($k); 2026 } 2027 $CPAN::Frontend->myprint("\n"); 2028 } else { 2029 if (CPAN::HandleConfig->edit(@o_what)) { 2030 } else { 2031 $CPAN::Frontend->myprint(qq{Type 'o conf' to view all configuration }. 2032 qq{items\n\n}); 2033 } 2034 } 2035 } elsif ($o_type eq 'debug') { 2036 my(%valid); 2037 @o_what = () if defined $o_what[0] && $o_what[0] =~ /help/i; 2038 if (@o_what) { 2039 while (@o_what) { 2040 my($what) = shift @o_what; 2041 if ($what =~ s/^-// && exists $CPAN::DEBUG{$what}) { 2042 $CPAN::DEBUG &= $CPAN::DEBUG ^ $CPAN::DEBUG{$what}; 2043 next; 2044 } 2045 if ( exists $CPAN::DEBUG{$what} ) { 2046 $CPAN::DEBUG |= $CPAN::DEBUG{$what}; 2047 } elsif ($what =~ /^\d/) { 2048 $CPAN::DEBUG = $what; 2049 } elsif (lc $what eq 'all') { 2050 my($max) = 0; 2051 for (values %CPAN::DEBUG) { 2052 $max += $_; 2053 } 2054 $CPAN::DEBUG = $max; 2055 } else { 2056 my($known) = 0; 2057 for (keys %CPAN::DEBUG) { 2058 next unless lc($_) eq lc($what); 2059 $CPAN::DEBUG |= $CPAN::DEBUG{$_}; 2060 $known = 1; 2061 } 2062 $CPAN::Frontend->myprint("unknown argument [$what]\n") 2063 unless $known; 2064 } 2065 } 2066 } else { 2067 my $raw = "Valid options for debug are ". 2068 join(", ",sort(keys %CPAN::DEBUG), 'all'). 2069 qq{ or a number. Completion works on the options. }. 2070 qq{Case is ignored.}; 2071 require Text::Wrap; 2072 $CPAN::Frontend->myprint(Text::Wrap::fill("","",$raw)); 2073 $CPAN::Frontend->myprint("\n\n"); 2074 } 2075 if ($CPAN::DEBUG) { 2076 $CPAN::Frontend->myprint("Options set for debugging ($CPAN::DEBUG):\n"); 2077 my($k,$v); 2078 for $k (sort {$CPAN::DEBUG{$a} <=> $CPAN::DEBUG{$b}} keys %CPAN::DEBUG) { 2079 $v = $CPAN::DEBUG{$k}; 2080 $CPAN::Frontend->myprint(sprintf " %-14s(%s)\n", $k, $v) 2081 if $v & $CPAN::DEBUG; 2082 } 2083 } else { 2084 $CPAN::Frontend->myprint("Debugging turned off completely.\n"); 2085 } 2086 } else { 2087 $CPAN::Frontend->myprint(qq{ 2088 Known options: 2089 conf set or get configuration variables 2090 debug set or get debugging options 2091 }); 2092 } 2093 } 2094 2095 # CPAN::Shell::paintdots_onreload 2096 sub paintdots_onreload { 2097 my($ref) = shift; 2098 sub { 2099 if ( $_[0] =~ /[Ss]ubroutine ([\w:]+) redefined/ ) { 2100 my($subr) = $1; 2101 ++$$ref; 2102 local($|) = 1; 2103 # $CPAN::Frontend->myprint(".($subr)"); 2104 $CPAN::Frontend->myprint("."); 2105 if ($subr =~ /\bshell\b/i) { 2106 # warn "debug[$_[0]]"; 2107 2108 # It would be nice if we could detect that a 2109 # subroutine has actually changed, but for now we 2110 # practically always set the GOTOSHELL global 2111 2112 $CPAN::GOTOSHELL=1; 2113 } 2114 return; 2115 } 2116 warn @_; 2117 }; 2118 } 2119 2120 #-> sub CPAN::Shell::hosts ; 2121 sub hosts { 2122 my($self) = @_; 2123 my $fullstats = CPAN::FTP->_ftp_statistics(); 2124 my $history = $fullstats->{history} || []; 2125 my %S; # statistics 2126 while (my $last = pop @$history) { 2127 my $attempts = $last->{attempts} or next; 2128 my $start; 2129 if (@$attempts) { 2130 $start = $attempts->[-1]{start}; 2131 if ($#$attempts > 0) { 2132 for my $i (0..$#$attempts-1) { 2133 my $url = $attempts->[$i]{url} or next; 2134 $S{no}{$url}++; 2135 } 2136 } 2137 } else { 2138 $start = $last->{start}; 2139 } 2140 next unless $last->{thesiteurl}; # C-C? bad filenames? 2141 $S{start} = $start; 2142 $S{end} ||= $last->{end}; 2143 my $dltime = $last->{end} - $start; 2144 my $dlsize = $last->{filesize} || 0; 2145 my $url = ref $last->{thesiteurl} ? $last->{thesiteurl}->text : $last->{thesiteurl}; 2146 my $s = $S{ok}{$url} ||= {}; 2147 $s->{n}++; 2148 $s->{dlsize} ||= 0; 2149 $s->{dlsize} += $dlsize/1024; 2150 $s->{dltime} ||= 0; 2151 $s->{dltime} += $dltime; 2152 } 2153 my $res; 2154 for my $url (keys %{$S{ok}}) { 2155 next if $S{ok}{$url}{dltime} == 0; # div by zero 2156 push @{$res->{ok}}, [@{$S{ok}{$url}}{qw(n dlsize dltime)}, 2157 $S{ok}{$url}{dlsize}/$S{ok}{$url}{dltime}, 2158 $url, 2159 ]; 2160 } 2161 for my $url (keys %{$S{no}}) { 2162 push @{$res->{no}}, [$S{no}{$url}, 2163 $url, 2164 ]; 2165 } 2166 my $R = ""; # report 2167 if ($S{start} && $S{end}) { 2168 $R .= sprintf "Log starts: %s\n", $S{start} ? scalar(localtime $S{start}) : "unknown"; 2169 $R .= sprintf "Log ends : %s\n", $S{end} ? scalar(localtime $S{end}) : "unknown"; 2170 } 2171 if ($res->{ok} && @{$res->{ok}}) { 2172 $R .= sprintf "\nSuccessful downloads: 2173 N kB secs kB/s url\n"; 2174 my $i = 20; 2175 for (sort { $b->[3] <=> $a->[3] } @{$res->{ok}}) { 2176 $R .= sprintf "%4d %8d %5d %9.1f %s\n", @$_; 2177 last if --$i<=0; 2178 } 2179 } 2180 if ($res->{no} && @{$res->{no}}) { 2181 $R .= sprintf "\nUnsuccessful downloads:\n"; 2182 my $i = 20; 2183 for (sort { $b->[0] <=> $a->[0] } @{$res->{no}}) { 2184 $R .= sprintf "%4d %s\n", @$_; 2185 last if --$i<=0; 2186 } 2187 } 2188 $CPAN::Frontend->myprint($R); 2189 } 2190 2191 #-> sub CPAN::Shell::reload ; 2192 sub reload { 2193 my($self,$command,@arg) = @_; 2194 $command ||= ""; 2195 $self->debug("self[$self]command[$command]arg[@arg]") if $CPAN::DEBUG; 2196 if ($command =~ /^cpan$/i) { 2197 my $redef = 0; 2198 chdir $CPAN::iCwd if $CPAN::iCwd; # may fail 2199 my $failed; 2200 my @relo = ( 2201 "CPAN.pm", 2202 "CPAN/Debug.pm", 2203 "CPAN/FirstTime.pm", 2204 "CPAN/HandleConfig.pm", 2205 "CPAN/Kwalify.pm", 2206 "CPAN/Queue.pm", 2207 "CPAN/Reporter/Config.pm", 2208 "CPAN/Reporter/History.pm", 2209 "CPAN/Reporter.pm", 2210 "CPAN/SQLite.pm", 2211 "CPAN/Tarzip.pm", 2212 "CPAN/Version.pm", 2213 ); 2214 MFILE: for my $f (@relo) { 2215 next unless exists $INC{$f}; 2216 my $p = $f; 2217 $p =~ s/\.pm$//; 2218 $p =~ s|/|::|g; 2219 $CPAN::Frontend->myprint("($p"); 2220 local($SIG{__WARN__}) = paintdots_onreload(\$redef); 2221 $self->_reload_this($f) or $failed++; 2222 my $v = eval "$p\::->VERSION"; 2223 $CPAN::Frontend->myprint("v$v)"); 2224 } 2225 $CPAN::Frontend->myprint("\n$redef subroutines redefined\n"); 2226 if ($failed) { 2227 my $errors = $failed == 1 ? "error" : "errors"; 2228 $CPAN::Frontend->mywarn("\n$failed $errors during reload. You better quit ". 2229 "this session.\n"); 2230 } 2231 } elsif ($command =~ /^index$/i) { 2232 CPAN::Index->force_reload; 2233 } else { 2234 $CPAN::Frontend->myprint(qq{cpan re-evals the CPAN modules 2235 index re-reads the index files\n}); 2236 } 2237 } 2238 2239 # reload means only load again what we have loaded before 2240 #-> sub CPAN::Shell::_reload_this ; 2241 sub _reload_this { 2242 my($self,$f,$args) = @_; 2243 CPAN->debug("f[$f]") if $CPAN::DEBUG; 2244 return 1 unless $INC{$f}; # we never loaded this, so we do not 2245 # reload but say OK 2246 my $pwd = CPAN::anycwd(); 2247 CPAN->debug("pwd[$pwd]") if $CPAN::DEBUG; 2248 my($file); 2249 for my $inc (@INC) { 2250 $file = File::Spec->catfile($inc,split /\//, $f); 2251 last if -f $file; 2252 $file = ""; 2253 } 2254 CPAN->debug("file[$file]") if $CPAN::DEBUG; 2255 my @inc = @INC; 2256 unless ($file && -f $file) { 2257 # this thingie is not in the INC path, maybe CPAN/MyConfig.pm? 2258 $file = $INC{$f}; 2259 unless (CPAN->has_inst("File::Basename")) { 2260 @inc = File::Basename::dirname($file); 2261 } else { 2262 # do we ever need this? 2263 @inc = substr($file,0,-length($f)-1); # bring in back to me! 2264 } 2265 } 2266 CPAN->debug("file[$file]inc[@inc]") if $CPAN::DEBUG; 2267 unless (-f $file) { 2268 $CPAN::Frontend->mywarn("Found no file to reload for '$f'\n"); 2269 return; 2270 } 2271 my $mtime = (stat $file)[9]; 2272 if ($reload->{$f}) { 2273 } elsif ($^T < $mtime) { 2274 # since we started the file has changed, force it to be reloaded 2275 $reload->{$f} = -1; 2276 } else { 2277 $reload->{$f} = $mtime; 2278 } 2279 my $must_reload = $mtime != $reload->{$f}; 2280 $args ||= {}; 2281 $must_reload ||= $args->{reloforce}; # o conf defaults needs this 2282 if ($must_reload) { 2283 my $fh = FileHandle->new($file) or 2284 $CPAN::Frontend->mydie("Could not open $file: $!"); 2285 local($/); 2286 local $^W = 1; 2287 my $content = <$fh>; 2288 CPAN->debug(sprintf("reload file[%s] content[%s...]",$file,substr($content,0,128))) 2289 if $CPAN::DEBUG; 2290 delete $INC{$f}; 2291 local @INC = @inc; 2292 eval "require '$f'"; 2293 if ($@) { 2294 warn $@; 2295 return; 2296 } 2297 $reload->{$f} = $mtime; 2298 } else { 2299 $CPAN::Frontend->myprint("__unchanged__"); 2300 } 2301 return 1; 2302 } 2303 2304 #-> sub CPAN::Shell::mkmyconfig ; 2305 sub mkmyconfig { 2306 my($self, $cpanpm, %args) = @_; 2307 require CPAN::FirstTime; 2308 my $home = CPAN::HandleConfig::home; 2309 $cpanpm = $INC{'CPAN/MyConfig.pm'} || 2310 File::Spec->catfile(split /\//, "$home/.cpan/CPAN/MyConfig.pm"); 2311 File::Path::mkpath(File::Basename::dirname($cpanpm)) unless -e $cpanpm; 2312 CPAN::HandleConfig::require_myconfig_or_config; 2313 $CPAN::Config ||= {}; 2314 $CPAN::Config = { 2315 %$CPAN::Config, 2316 build_dir => undef, 2317 cpan_home => undef, 2318 keep_source_where => undef, 2319 histfile => undef, 2320 }; 2321 CPAN::FirstTime::init($cpanpm, %args); 2322 } 2323 2324 #-> sub CPAN::Shell::_binary_extensions ; 2325 sub _binary_extensions { 2326 my($self) = shift @_; 2327 my(@result,$module,%seen,%need,$headerdone); 2328 for $module ($self->expand('Module','/./')) { 2329 my $file = $module->cpan_file; 2330 next if $file eq "N/A"; 2331 next if $file =~ /^Contact Author/; 2332 my $dist = $CPAN::META->instance('CPAN::Distribution',$file); 2333 next if $dist->isa_perl; 2334 next unless $module->xs_file; 2335 local($|) = 1; 2336 $CPAN::Frontend->myprint("."); 2337 push @result, $module; 2338 } 2339 # print join " | ", @result; 2340 $CPAN::Frontend->myprint("\n"); 2341 return @result; 2342 } 2343 2344 #-> sub CPAN::Shell::recompile ; 2345 sub recompile { 2346 my($self) = shift @_; 2347 my($module,@module,$cpan_file,%dist); 2348 @module = $self->_binary_extensions(); 2349 for $module (@module) { # we force now and compile later, so we 2350 # don't do it twice 2351 $cpan_file = $module->cpan_file; 2352 my $pack = $CPAN::META->instance('CPAN::Distribution',$cpan_file); 2353 $pack->force; 2354 $dist{$cpan_file}++; 2355 } 2356 for $cpan_file (sort keys %dist) { 2357 $CPAN::Frontend->myprint(" CPAN: Recompiling $cpan_file\n\n"); 2358 my $pack = $CPAN::META->instance('CPAN::Distribution',$cpan_file); 2359 $pack->install; 2360 $CPAN::Signal = 0; # it's tempting to reset Signal, so we can 2361 # stop a package from recompiling, 2362 # e.g. IO-1.12 when we have perl5.003_10 2363 } 2364 } 2365 2366 #-> sub CPAN::Shell::scripts ; 2367 sub scripts { 2368 my($self, $arg) = @_; 2369 $CPAN::Frontend->mywarn(">>>> experimental command, currently unsupported <<<<\n\n"); 2370 2371 for my $req (qw( HTML::LinkExtor Sort::Versions List::Util )) { 2372 unless ($CPAN::META->has_inst($req)) { 2373 $CPAN::Frontend->mywarn(" $req not available\n"); 2374 } 2375 } 2376 my $p = HTML::LinkExtor->new(); 2377 my $indexfile = "/home/ftp/pub/PAUSE/scripts/new/index.html"; 2378 unless (-f $indexfile) { 2379 $CPAN::Frontend->mydie("found no indexfile[$indexfile]\n"); 2380 } 2381 $p->parse_file($indexfile); 2382 my @hrefs; 2383 my $qrarg; 2384 if ($arg =~ s|^/(.+)/$|$1|) { 2385 $qrarg = eval 'qr/$arg/'; # hide construct from 5.004 2386 } 2387 for my $l ($p->links) { 2388 my $tag = shift @$l; 2389 next unless $tag eq "a"; 2390 my %att = @$l; 2391 my $href = $att{href}; 2392 next unless $href =~ s|^\.\./authors/id/./../||; 2393 if ($arg) { 2394 if ($qrarg) { 2395 if ($href =~ $qrarg) { 2396 push @hrefs, $href; 2397 } 2398 } else { 2399 if ($href =~ /\Q$arg\E/) { 2400 push @hrefs, $href; 2401 } 2402 } 2403 } else { 2404 push @hrefs, $href; 2405 } 2406 } 2407 # now filter for the latest version if there is more than one of a name 2408 my %stems; 2409 for (sort @hrefs) { 2410 my $href = $_; 2411 s/-v?\d.*//; 2412 my $stem = $_; 2413 $stems{$stem} ||= []; 2414 push @{$stems{$stem}}, $href; 2415 } 2416 for (sort keys %stems) { 2417 my $highest; 2418 if (@{$stems{$_}} > 1) { 2419 $highest = List::Util::reduce { 2420 Sort::Versions::versioncmp($a,$b) > 0 ? $a : $b 2421 } @{$stems{$_}}; 2422 } else { 2423 $highest = $stems{$_}[0]; 2424 } 2425 $CPAN::Frontend->myprint("$highest\n"); 2426 } 2427 } 2428 2429 #-> sub CPAN::Shell::report ; 2430 sub report { 2431 my($self,@args) = @_; 2432 unless ($CPAN::META->has_inst("CPAN::Reporter")) { 2433 $CPAN::Frontend->mydie("CPAN::Reporter not installed; cannot continue"); 2434 } 2435 local $CPAN::Config->{test_report} = 1; 2436 $self->force("test",@args); # force is there so that the test be 2437 # re-run (as documented) 2438 } 2439 2440 # compare with is_tested 2441 #-> sub CPAN::Shell::install_tested 2442 sub install_tested { 2443 my($self,@some) = @_; 2444 $CPAN::Frontend->mywarn("install_tested() must not be called with arguments.\n"), 2445 return if @some; 2446 CPAN::Index->reload; 2447 2448 for my $b (reverse $CPAN::META->_list_sorted_descending_is_tested) { 2449 my $yaml = "$b.yml"; 2450 unless (-f $yaml) { 2451 $CPAN::Frontend->mywarn("No YAML file for $b available, skipping\n"); 2452 next; 2453 } 2454 my $yaml_content = CPAN->_yaml_loadfile($yaml); 2455 my $id = $yaml_content->[0]{distribution}{ID}; 2456 unless ($id) { 2457 $CPAN::Frontend->mywarn("No ID found in '$yaml', skipping\n"); 2458 next; 2459 } 2460 my $do = CPAN::Shell->expandany($id); 2461 unless ($do) { 2462 $CPAN::Frontend->mywarn("Could not expand ID '$id', skipping\n"); 2463 next; 2464 } 2465 unless ($do->{build_dir}) { 2466 $CPAN::Frontend->mywarn("Distro '$id' has no build_dir, skipping\n"); 2467 next; 2468 } 2469 unless ($do->{build_dir} eq $b) { 2470 $CPAN::Frontend->mywarn("Distro '$id' has build_dir '$do->{build_dir}' but expected '$b', skipping\n"); 2471 next; 2472 } 2473 push @some, $do; 2474 } 2475 2476 $CPAN::Frontend->mywarn("No tested distributions found.\n"), 2477 return unless @some; 2478 2479 @some = grep { $_->{make_test} && ! $_->{make_test}->failed } @some; 2480 $CPAN::Frontend->mywarn("No distributions tested with this build of perl found.\n"), 2481 return unless @some; 2482 2483 # @some = grep { not $_->uptodate } @some; 2484 # $CPAN::Frontend->mywarn("No non-uptodate distributions tested with this build of perl found.\n"), 2485 # return unless @some; 2486 2487 CPAN->debug("some[@some]"); 2488 for my $d (@some) { 2489 my $id = $d->can("pretty_id") ? $d->pretty_id : $d->id; 2490 $CPAN::Frontend->myprint("install_tested: Running for $id\n"); 2491 $CPAN::Frontend->mysleep(1); 2492 $self->install($d); 2493 } 2494 } 2495 2496 #-> sub CPAN::Shell::upgrade ; 2497 sub upgrade { 2498 my($self,@args) = @_; 2499 $self->install($self->r(@args)); 2500 } 2501 2502 #-> sub CPAN::Shell::_u_r_common ; 2503 sub _u_r_common { 2504 my($self) = shift @_; 2505 my($what) = shift @_; 2506 CPAN->debug("self[$self] what[$what] args[@_]") if $CPAN::DEBUG; 2507 Carp::croak "Usage: \$obj->_u_r_common(a|r|u)" unless 2508 $what && $what =~ /^[aru]$/; 2509 my(@args) = @_; 2510 @args = '/./' unless @args; 2511 my(@result,$module,%seen,%need,$headerdone, 2512 $version_undefs,$version_zeroes, 2513 @version_undefs,@version_zeroes); 2514 $version_undefs = $version_zeroes = 0; 2515 my $sprintf = "%s%-25s%s %9s %9s %s\n"; 2516 my @expand = $self->expand('Module',@args); 2517 my $expand = scalar @expand; 2518 if (0) { # Looks like noise to me, was very useful for debugging 2519 # for metadata cache 2520 $CPAN::Frontend->myprint(sprintf "%d matches in the database\n", $expand); 2521 } 2522 MODULE: for $module (@expand) { 2523 my $file = $module->cpan_file; 2524 next MODULE unless defined $file; # ?? 2525 $file =~ s!^./../!!; 2526 my($latest) = $module->cpan_version; 2527 my($inst_file) = $module->inst_file; 2528 my($have); 2529 return if $CPAN::Signal; 2530 if ($inst_file) { 2531 if ($what eq "a") { 2532 $have = $module->inst_version; 2533 } elsif ($what eq "r") { 2534 $have = $module->inst_version; 2535 local($^W) = 0; 2536 if ($have eq "undef") { 2537 $version_undefs++; 2538 push @version_undefs, $module->as_glimpse; 2539 } elsif (CPAN::Version->vcmp($have,0)==0) { 2540 $version_zeroes++; 2541 push @version_zeroes, $module->as_glimpse; 2542 } 2543 next MODULE unless CPAN::Version->vgt($latest, $have); 2544 # to be pedantic we should probably say: 2545 # && !($have eq "undef" && $latest ne "undef" && $latest gt ""); 2546 # to catch the case where CPAN has a version 0 and we have a version undef 2547 } elsif ($what eq "u") { 2548 next MODULE; 2549 } 2550 } else { 2551 if ($what eq "a") { 2552 next MODULE; 2553 } elsif ($what eq "r") { 2554 next MODULE; 2555 } elsif ($what eq "u") { 2556 $have = "-"; 2557 } 2558 } 2559 return if $CPAN::Signal; # this is sometimes lengthy 2560 $seen{$file} ||= 0; 2561 if ($what eq "a") { 2562 push @result, sprintf "%s %s\n", $module->id, $have; 2563 } elsif ($what eq "r") { 2564 push @result, $module->id; 2565 next MODULE if $seen{$file}++; 2566 } elsif ($what eq "u") { 2567 push @result, $module->id; 2568 next MODULE if $seen{$file}++; 2569 next MODULE if $file =~ /^Contact/; 2570 } 2571 unless ($headerdone++) { 2572 $CPAN::Frontend->myprint("\n"); 2573 $CPAN::Frontend->myprint(sprintf( 2574 $sprintf, 2575 "", 2576 "Package namespace", 2577 "", 2578 "installed", 2579 "latest", 2580 "in CPAN file" 2581 )); 2582 } 2583 my $color_on = ""; 2584 my $color_off = ""; 2585 if ( 2586 $COLOR_REGISTERED 2587 && 2588 $CPAN::META->has_inst("Term::ANSIColor") 2589 && 2590 $module->description 2591 ) { 2592 $color_on = Term::ANSIColor::color("green"); 2593 $color_off = Term::ANSIColor::color("reset"); 2594 } 2595 $CPAN::Frontend->myprint(sprintf $sprintf, 2596 $color_on, 2597 $module->id, 2598 $color_off, 2599 $have, 2600 $latest, 2601 $file); 2602 $need{$module->id}++; 2603 } 2604 unless (%need) { 2605 if ($what eq "u") { 2606 $CPAN::Frontend->myprint("No modules found for @args\n"); 2607 } elsif ($what eq "r") { 2608 $CPAN::Frontend->myprint("All modules are up to date for @args\n"); 2609 } 2610 } 2611 if ($what eq "r") { 2612 if ($version_zeroes) { 2613 my $s_has = $version_zeroes > 1 ? "s have" : " has"; 2614 $CPAN::Frontend->myprint(qq{$version_zeroes installed module$s_has }. 2615 qq{a version number of 0\n}); 2616 if ($CPAN::Config->{show_zero_versions}) { 2617 local $" = "\t"; 2618 $CPAN::Frontend->myprint(qq{ they are\n\t@version_zeroes\n}); 2619 $CPAN::Frontend->myprint(qq{(use 'o conf show_zero_versions 0' }. 2620 qq{to hide them)\n}); 2621 } else { 2622 $CPAN::Frontend->myprint(qq{(use 'o conf show_zero_versions 1' }. 2623 qq{to show them)\n}); 2624 } 2625 } 2626 if ($version_undefs) { 2627 my $s_has = $version_undefs > 1 ? "s have" : " has"; 2628 $CPAN::Frontend->myprint(qq{$version_undefs installed module$s_has no }. 2629 qq{parseable version number\n}); 2630 if ($CPAN::Config->{show_unparsable_versions}) { 2631 local $" = "\t"; 2632 $CPAN::Frontend->myprint(qq{ they are\n\t@version_undefs\n}); 2633 $CPAN::Frontend->myprint(qq{(use 'o conf show_unparsable_versions 0' }. 2634 qq{to hide them)\n}); 2635 } else { 2636 $CPAN::Frontend->myprint(qq{(use 'o conf show_unparsable_versions 1' }. 2637 qq{to show them)\n}); 2638 } 2639 } 2640 } 2641 @result; 2642 } 2643 2644 #-> sub CPAN::Shell::r ; 2645 sub r { 2646 shift->_u_r_common("r",@_); 2647 } 2648 2649 #-> sub CPAN::Shell::u ; 2650 sub u { 2651 shift->_u_r_common("u",@_); 2652 } 2653 2654 #-> sub CPAN::Shell::failed ; 2655 sub failed { 2656 my($self,$only_id,$silent) = @_; 2657 my @failed; 2658 DIST: for my $d ($CPAN::META->all_objects("CPAN::Distribution")) { 2659 my $failed = ""; 2660 NAY: for my $nosayer ( # order matters! 2661 "unwrapped", 2662 "writemakefile", 2663 "signature_verify", 2664 "make", 2665 "make_test", 2666 "install", 2667 "make_clean", 2668 ) { 2669 next unless exists $d->{$nosayer}; 2670 next unless defined $d->{$nosayer}; 2671 next unless ( 2672 UNIVERSAL::can($d->{$nosayer},"failed") ? 2673 $d->{$nosayer}->failed : 2674 $d->{$nosayer} =~ /^NO/ 2675 ); 2676 next NAY if $only_id && $only_id != ( 2677 UNIVERSAL::can($d->{$nosayer},"commandid") 2678 ? 2679 $d->{$nosayer}->commandid 2680 : 2681 $CPAN::CurrentCommandId 2682 ); 2683 $failed = $nosayer; 2684 last; 2685 } 2686 next DIST unless $failed; 2687 my $id = $d->id; 2688 $id =~ s|^./../||; 2689 #$print .= sprintf( 2690 # " %-45s: %s %s\n", 2691 push @failed, 2692 ( 2693 UNIVERSAL::can($d->{$failed},"failed") ? 2694 [ 2695 $d->{$failed}->commandid, 2696 $id, 2697 $failed, 2698 $d->{$failed}->text, 2699 $d->{$failed}{TIME}||0, 2700 ] : 2701 [ 2702 1, 2703 $id, 2704 $failed, 2705 $d->{$failed}, 2706 0, 2707 ] 2708 ); 2709 } 2710 my $scope; 2711 if ($only_id) { 2712 $scope = "this command"; 2713 } elsif ($CPAN::Index::HAVE_REANIMATED) { 2714 $scope = "this or a previous session"; 2715 # it might be nice to have a section for previous session and 2716 # a second for this 2717 } else { 2718 $scope = "this session"; 2719 } 2720 if (@failed) { 2721 my $print; 2722 my $debug = 0; 2723 if ($debug) { 2724 $print = join "", 2725 map { sprintf "%5d %-45s: %s %s\n", @$_ } 2726 sort { $a->[0] <=> $b->[0] } @failed; 2727 } else { 2728 $print = join "", 2729 map { sprintf " %-45s: %s %s\n", @$_[1..3] } 2730 sort { 2731 $a->[0] <=> $b->[0] 2732 || 2733 $a->[4] <=> $b->[4] 2734 } @failed; 2735 } 2736 $CPAN::Frontend->myprint("Failed during $scope:\n$print"); 2737 } elsif (!$only_id || !$silent) { 2738 $CPAN::Frontend->myprint("Nothing failed in $scope\n"); 2739 } 2740 } 2741 2742 # XXX intentionally undocumented because completely bogus, unportable, 2743 # useless, etc. 2744 2745 #-> sub CPAN::Shell::status ; 2746 sub status { 2747 my($self) = @_; 2748 require Devel::Size; 2749 my $ps = FileHandle->new; 2750 open $ps, "/proc/$$/status"; 2751 my $vm = 0; 2752 while (<$ps>) { 2753 next unless /VmSize:\s+(\d+)/; 2754 $vm = $1; 2755 last; 2756 } 2757 $CPAN::Frontend->mywarn(sprintf( 2758 "%-27s %6d\n%-27s %6d\n", 2759 "vm", 2760 $vm, 2761 "CPAN::META", 2762 Devel::Size::total_size($CPAN::META)/1024, 2763 )); 2764 for my $k (sort keys %$CPAN::META) { 2765 next unless substr($k,0,4) eq "read"; 2766 warn sprintf " %-26s %6d\n", $k, Devel::Size::total_size($CPAN::META->{$k})/1024; 2767 for my $k2 (sort keys %{$CPAN::META->{$k}}) { 2768 warn sprintf " %-25s %6d (keys: %6d)\n", 2769 $k2, 2770 Devel::Size::total_size($CPAN::META->{$k}{$k2})/1024, 2771 scalar keys %{$CPAN::META->{$k}{$k2}}; 2772 } 2773 } 2774 } 2775 2776 # compare with install_tested 2777 #-> sub CPAN::Shell::is_tested 2778 sub is_tested { 2779 my($self) = @_; 2780 CPAN::Index->reload; 2781 for my $b (reverse $CPAN::META->_list_sorted_descending_is_tested) { 2782 my $time; 2783 if ($CPAN::META->{is_tested}{$b}) { 2784 $time = scalar(localtime $CPAN::META->{is_tested}{$b}); 2785 } else { 2786 $time = scalar localtime; 2787 $time =~ s/\S/?/g; 2788 } 2789 $CPAN::Frontend->myprint(sprintf "%s %s\n", $time, $b); 2790 } 2791 } 2792 2793 #-> sub CPAN::Shell::autobundle ; 2794 sub autobundle { 2795 my($self) = shift; 2796 CPAN::HandleConfig->load unless $CPAN::Config_loaded++; 2797 my(@bundle) = $self->_u_r_common("a",@_); 2798 my($todir) = File::Spec->catdir($CPAN::Config->{'cpan_home'},"Bundle"); 2799 File::Path::mkpath($todir); 2800 unless (-d $todir) { 2801 $CPAN::Frontend->myprint("Couldn't mkdir $todir for some reason\n"); 2802 return; 2803 } 2804 my($y,$m,$d) = (localtime)[5,4,3]; 2805 $y+=1900; 2806 $m++; 2807 my($c) = 0; 2808 my($me) = sprintf "Snapshot_%04d_%02d_%02d_%02d", $y, $m, $d, $c; 2809 my($to) = File::Spec->catfile($todir,"$me.pm"); 2810 while (-f $to) { 2811 $me = sprintf "Snapshot_%04d_%02d_%02d_%02d", $y, $m, $d, ++$c; 2812 $to = File::Spec->catfile($todir,"$me.pm"); 2813 } 2814 my($fh) = FileHandle->new(">$to") or Carp::croak "Can't open >$to: $!"; 2815 $fh->print( 2816 "package Bundle::$me;\n\n", 2817 "\$VERSION = '0.01';\n\n", 2818 "1;\n\n", 2819 "__END__\n\n", 2820 "=head1 NAME\n\n", 2821 "Bundle::$me - Snapshot of installation on ", 2822 $Config::Config{'myhostname'}, 2823 " on ", 2824 scalar(localtime), 2825 "\n\n=head1 SYNOPSIS\n\n", 2826 "perl -MCPAN -e 'install Bundle::$me'\n\n", 2827 "=head1 CONTENTS\n\n", 2828 join("\n", @bundle), 2829 "\n\n=head1 CONFIGURATION\n\n", 2830 Config->myconfig, 2831 "\n\n=head1 AUTHOR\n\n", 2832 "This Bundle has been generated automatically ", 2833 "by the autobundle routine in CPAN.pm.\n", 2834 ); 2835 $fh->close; 2836 $CPAN::Frontend->myprint("\nWrote bundle file 2837 $to\n\n"); 2838 } 2839 2840 #-> sub CPAN::Shell::expandany ; 2841 sub expandany { 2842 my($self,$s) = @_; 2843 CPAN->debug("s[$s]") if $CPAN::DEBUG; 2844 if ($s =~ m|/| or substr($s,-1,1) eq ".") { # looks like a file or a directory 2845 $s = CPAN::Distribution->normalize($s); 2846 return $CPAN::META->instance('CPAN::Distribution',$s); 2847 # Distributions spring into existence, not expand 2848 } elsif ($s =~ m|^Bundle::|) { 2849 $self->local_bundles; # scanning so late for bundles seems 2850 # both attractive and crumpy: always 2851 # current state but easy to forget 2852 # somewhere 2853 return $self->expand('Bundle',$s); 2854 } else { 2855 return $self->expand('Module',$s) 2856 if $CPAN::META->exists('CPAN::Module',$s); 2857 } 2858 return; 2859 } 2860 2861 #-> sub CPAN::Shell::expand ; 2862 sub expand { 2863 my $self = shift; 2864 my($type,@args) = @_; 2865 CPAN->debug("type[$type]args[@args]") if $CPAN::DEBUG; 2866 my $class = "CPAN::$type"; 2867 my $methods = ['id']; 2868 for my $meth (qw(name)) { 2869 next unless $class->can($meth); 2870 push @$methods, $meth; 2871 } 2872 $self->expand_by_method($class,$methods,@args); 2873 } 2874 2875 #-> sub CPAN::Shell::expand_by_method ; 2876 sub expand_by_method { 2877 my $self = shift; 2878 my($class,$methods,@args) = @_; 2879 my($arg,@m); 2880 for $arg (@args) { 2881 my($regex,$command); 2882 if ($arg =~ m|^/(.*)/$|) { 2883 $regex = $1; 2884 # FIXME: there seem to be some ='s in the author data, which trigger 2885 # a failure here. This needs to be contemplated. 2886 # } elsif ($arg =~ m/=/) { 2887 # $command = 1; 2888 } 2889 my $obj; 2890 CPAN->debug(sprintf "class[%s]regex[%s]command[%s]", 2891 $class, 2892 defined $regex ? $regex : "UNDEFINED", 2893 defined $command ? $command : "UNDEFINED", 2894 ) if $CPAN::DEBUG; 2895 if (defined $regex) { 2896 if (CPAN::_sqlite_running) { 2897 $CPAN::SQLite->search($class, $regex); 2898 } 2899 for $obj ( 2900 $CPAN::META->all_objects($class) 2901 ) { 2902 unless ($obj && UNIVERSAL::can($obj,"id") && $obj->id) { 2903 # BUG, we got an empty object somewhere 2904 require Data::Dumper; 2905 CPAN->debug(sprintf( 2906 "Bug in CPAN: Empty id on obj[%s][%s]", 2907 $obj, 2908 Data::Dumper::Dumper($obj) 2909 )) if $CPAN::DEBUG; 2910 next; 2911 } 2912 for my $method (@$methods) { 2913 my $match = eval {$obj->$method() =~ /$regex/i}; 2914 if ($@) { 2915 my($err) = $@ =~ /^(.+) at .+? line \d+\.$/; 2916 $err ||= $@; # if we were too restrictive above 2917 $CPAN::Frontend->mydie("$err\n"); 2918 } elsif ($match) { 2919 push @m, $obj; 2920 last; 2921 } 2922 } 2923 } 2924 } elsif ($command) { 2925 die "equal sign in command disabled (immature interface), ". 2926 "you can set 2927 ! \$CPAN::Shell::ADVANCED_QUERY=1 2928 to enable it. But please note, this is HIGHLY EXPERIMENTAL code 2929 that may go away anytime.\n" 2930 unless $ADVANCED_QUERY; 2931 my($method,$criterion) = $arg =~ /(.+?)=(.+)/; 2932 my($matchcrit) = $criterion =~ m/^~(.+)/; 2933 for my $self ( 2934 sort 2935 {$a->id cmp $b->id} 2936 $CPAN::META->all_objects($class) 2937 ) { 2938 my $lhs = $self->$method() or next; # () for 5.00503 2939 if ($matchcrit) { 2940 push @m, $self if $lhs =~ m/$matchcrit/; 2941 } else { 2942 push @m, $self if $lhs eq $criterion; 2943 } 2944 } 2945 } else { 2946 my($xarg) = $arg; 2947 if ( $class eq 'CPAN::Bundle' ) { 2948 $xarg =~ s/^(Bundle::)?(.*)/Bundle::$2/; 2949 } elsif ($class eq "CPAN::Distribution") { 2950 $xarg = CPAN::Distribution->normalize($arg); 2951 } else { 2952 $xarg =~ s/:+/::/g; 2953 } 2954 if ($CPAN::META->exists($class,$xarg)) { 2955 $obj = $CPAN::META->instance($class,$xarg); 2956 } elsif ($CPAN::META->exists($class,$arg)) { 2957 $obj = $CPAN::META->instance($class,$arg); 2958 } else { 2959 next; 2960 } 2961 push @m, $obj; 2962 } 2963 } 2964 @m = sort {$a->id cmp $b->id} @m; 2965 if ( $CPAN::DEBUG ) { 2966 my $wantarray = wantarray; 2967 my $join_m = join ",", map {$_->id} @m; 2968 $self->debug("wantarray[$wantarray]join_m[$join_m]"); 2969 } 2970 return wantarray ? @m : $m[0]; 2971 } 2972 2973 #-> sub CPAN::Shell::format_result ; 2974 sub format_result { 2975 my($self) = shift; 2976 my($type,@args) = @_; 2977 @args = '/./' unless @args; 2978 my(@result) = $self->expand($type,@args); 2979 my $result = @result == 1 ? 2980 $result[0]->as_string : 2981 @result == 0 ? 2982 "No objects of type $type found for argument @args\n" : 2983 join("", 2984 (map {$_->as_glimpse} @result), 2985 scalar @result, " items found\n", 2986 ); 2987 $result; 2988 } 2989 2990 #-> sub CPAN::Shell::report_fh ; 2991 { 2992 my $installation_report_fh; 2993 my $previously_noticed = 0; 2994 2995 sub report_fh { 2996 return $installation_report_fh if $installation_report_fh; 2997 if ($CPAN::META->has_usable("File::Temp")) { 2998 $installation_report_fh 2999 = File::Temp->new( 3000 dir => File::Spec->tmpdir, 3001 template => 'cpan_install_XXXX', 3002 suffix => '.txt', 3003 unlink => 0, 3004 ); 3005 } 3006 unless ( $installation_report_fh ) { 3007 warn("Couldn't open installation report file; " . 3008 "no report file will be generated." 3009 ) unless $previously_noticed++; 3010 } 3011 } 3012 } 3013 3014 3015 # The only reason for this method is currently to have a reliable 3016 # debugging utility that reveals which output is going through which 3017 # channel. No, I don't like the colors ;-) 3018 3019 # to turn colordebugging on, write 3020 # cpan> o conf colorize_output 1 3021 3022 #-> sub CPAN::Shell::print_ornamented ; 3023 { 3024 my $print_ornamented_have_warned = 0; 3025 sub colorize_output { 3026 my $colorize_output = $CPAN::Config->{colorize_output}; 3027 if ($colorize_output && !$CPAN::META->has_inst("Term::ANSIColor")) { 3028 unless ($print_ornamented_have_warned++) { 3029 # no myprint/mywarn within myprint/mywarn! 3030 warn "Colorize_output is set to true but Term::ANSIColor is not 3031 installed. To activate colorized output, please install Term::ANSIColor.\n\n"; 3032 } 3033 $colorize_output = 0; 3034 } 3035 return $colorize_output; 3036 } 3037 } 3038 3039 3040 #-> sub CPAN::Shell::print_ornamented ; 3041 sub print_ornamented { 3042 my($self,$what,$ornament) = @_; 3043 return unless defined $what; 3044 3045 local $| = 1; # Flush immediately 3046 if ( $CPAN::Be_Silent ) { 3047 print {report_fh()} $what; 3048 return; 3049 } 3050 my $swhat = "$what"; # stringify if it is an object 3051 if ($CPAN::Config->{term_is_latin}) { 3052 # note: deprecated, need to switch to $LANG and $LC_* 3053 # courtesy jhi: 3054 $swhat 3055 =~ s{([\xC0-\xDF])([\x80-\xBF])}{chr(ord($1)<<6&0xC0|ord($2)&0x3F)}eg; #}; 3056 } 3057 if ($self->colorize_output) { 3058 if ( $CPAN::DEBUG && $swhat =~ /^Debug\(/ ) { 3059 # if you want to have this configurable, please file a bugreport 3060 $ornament = $CPAN::Config->{colorize_debug} || "black on_cyan"; 3061 } 3062 my $color_on = eval { Term::ANSIColor::color($ornament) } || ""; 3063 if ($@) { 3064 print "Term::ANSIColor rejects color[$ornament]: $@\n 3065 Please choose a different color (Hint: try 'o conf init /color/')\n"; 3066 } 3067 # GGOLDBACH/Test-GreaterVersion-0.008 broke wthout this 3068 # $trailer construct. We want the newline be the last thing if 3069 # there is a newline at the end ensuring that the next line is 3070 # empty for other players 3071 my $trailer = ""; 3072 $trailer = $1 if $swhat =~ s/([\r\n]+)\z//; 3073 print $color_on, 3074 $swhat, 3075 Term::ANSIColor::color("reset"), 3076 $trailer; 3077 } else { 3078 print $swhat; 3079 } 3080 } 3081 3082 #-> sub CPAN::Shell::myprint ; 3083 3084 # where is myprint/mywarn/Frontend/etc. documented? Where to use what? 3085 # I think, we send everything to STDOUT and use print for normal/good 3086 # news and warn for news that need more attention. Yes, this is our 3087 # working contract for now. 3088 sub myprint { 3089 my($self,$what) = @_; 3090 $self->print_ornamented($what, 3091 $CPAN::Config->{colorize_print}||'bold blue on_white', 3092 ); 3093 } 3094 3095 sub optprint { 3096 my($self,$category,$what) = @_; 3097 my $vname = $category . "_verbosity"; 3098 CPAN::HandleConfig->load unless $CPAN::Config_loaded++; 3099 if (!$CPAN::Config->{$vname} 3100 || $CPAN::Config->{$vname} =~ /^v/ 3101 ) { 3102 $CPAN::Frontend->myprint($what); 3103 } 3104 } 3105 3106 #-> sub CPAN::Shell::myexit ; 3107 sub myexit { 3108 my($self,$what) = @_; 3109 $self->myprint($what); 3110 exit; 3111 } 3112 3113 #-> sub CPAN::Shell::mywarn ; 3114 sub mywarn { 3115 my($self,$what) = @_; 3116 $self->print_ornamented($what, $CPAN::Config->{colorize_warn}||'bold red on_white'); 3117 } 3118 3119 # only to be used for shell commands 3120 #-> sub CPAN::Shell::mydie ; 3121 sub mydie { 3122 my($self,$what) = @_; 3123 $self->mywarn($what); 3124 3125 # If it is the shell, we want the following die to be silent, 3126 # but if it is not the shell, we would need a 'die $what'. We need 3127 # to take care that only shell commands use mydie. Is this 3128 # possible? 3129 3130 die "\n"; 3131 } 3132 3133 # sub CPAN::Shell::colorable_makemaker_prompt ; 3134 sub colorable_makemaker_prompt { 3135 my($foo,$bar) = @_; 3136 if (CPAN::Shell->colorize_output) { 3137 my $ornament = $CPAN::Config->{colorize_print}||'bold blue on_white'; 3138 my $color_on = eval { Term::ANSIColor::color($ornament); } || ""; 3139 print $color_on; 3140 } 3141 my $ans = ExtUtils::MakeMaker::prompt($foo,$bar); 3142 if (CPAN::Shell->colorize_output) { 3143 print Term::ANSIColor::color('reset'); 3144 } 3145 return $ans; 3146 } 3147 3148 # use this only for unrecoverable errors! 3149 #-> sub CPAN::Shell::unrecoverable_error ; 3150 sub unrecoverable_error { 3151 my($self,$what) = @_; 3152 my @lines = split /\n/, $what; 3153 my $longest = 0; 3154 for my $l (@lines) { 3155 $longest = length $l if length $l > $longest; 3156 } 3157 $longest = 62 if $longest > 62; 3158 for my $l (@lines) { 3159 if ($l =~ /^\s*$/) { 3160 $l = "\n"; 3161 next; 3162 } 3163 $l = "==> $l"; 3164 if (length $l < 66) { 3165 $l = pack "A66 A*", $l, "<=="; 3166 } 3167 $l .= "\n"; 3168 } 3169 unshift @lines, "\n"; 3170 $self->mydie(join "", @lines); 3171 } 3172 3173 #-> sub CPAN::Shell::mysleep ; 3174 sub mysleep { 3175 my($self, $sleep) = @_; 3176 if (CPAN->has_inst("Time::HiRes")) { 3177 Time::HiRes::sleep($sleep); 3178 } else { 3179 sleep($sleep < 1 ? 1 : int($sleep + 0.5)); 3180 } 3181 } 3182 3183 #-> sub CPAN::Shell::setup_output ; 3184 sub setup_output { 3185 return if -t STDOUT; 3186 my $odef = select STDERR; 3187 $| = 1; 3188 select STDOUT; 3189 $| = 1; 3190 select $odef; 3191 } 3192 3193 #-> sub CPAN::Shell::rematein ; 3194 # RE-adme||MA-ke||TE-st||IN-stall : nearly everything runs through here 3195 sub rematein { 3196 my $self = shift; 3197 my($meth,@some) = @_; 3198 my @pragma; 3199 while($meth =~ /^(ff?orce|notest)$/) { 3200 push @pragma, $meth; 3201 $meth = shift @some or 3202 $CPAN::Frontend->mydie("Pragma $pragma[-1] used without method: ". 3203 "cannot continue"); 3204 } 3205 setup_output(); 3206 CPAN->debug("pragma[@pragma]meth[$meth]some[@some]") if $CPAN::DEBUG; 3207 3208 # Here is the place to set "test_count" on all involved parties to 3209 # 0. We then can pass this counter on to the involved 3210 # distributions and those can refuse to test if test_count > X. In 3211 # the first stab at it we could use a 1 for "X". 3212 3213 # But when do I reset the distributions to start with 0 again? 3214 # Jost suggested to have a random or cycling interaction ID that 3215 # we pass through. But the ID is something that is just left lying 3216 # around in addition to the counter, so I'd prefer to set the 3217 # counter to 0 now, and repeat at the end of the loop. But what 3218 # about dependencies? They appear later and are not reset, they 3219 # enter the queue but not its copy. How do they get a sensible 3220 # test_count? 3221 3222 # With configure_requires, "get" is vulnerable in recursion. 3223 3224 my $needs_recursion_protection = "get|make|test|install"; 3225 3226 # construct the queue 3227 my($s,@s,@qcopy); 3228 STHING: foreach $s (@some) { 3229 my $obj; 3230 if (ref $s) { 3231 CPAN->debug("s is an object[$s]") if $CPAN::DEBUG; 3232 $obj = $s; 3233 } elsif ($s =~ m|[\$\@\%]|) { # looks like a perl variable 3234 } elsif ($s =~ m|^/|) { # looks like a regexp 3235 if (substr($s,-1,1) eq ".") { 3236 $obj = CPAN::Shell->expandany($s); 3237 } else { 3238 $CPAN::Frontend->mywarn("Sorry, $meth with a regular expression is ". 3239 "not supported.\nRejecting argument '$s'\n"); 3240 $CPAN::Frontend->mysleep(2); 3241 next; 3242 } 3243 } elsif ($meth eq "ls") { 3244 $self->globls($s,\@pragma); 3245 next STHING; 3246 } else { 3247 CPAN->debug("calling expandany [$s]") if $CPAN::DEBUG; 3248 $obj = CPAN::Shell->expandany($s); 3249 } 3250 if (0) { 3251 } elsif (ref $obj) { 3252 if ($meth =~ /^($needs_recursion_protection)$/) { 3253 # it would be silly to check for recursion for look or dump 3254 # (we are in CPAN::Shell::rematein) 3255 CPAN->debug("Going to test against recursion") if $CPAN::DEBUG; 3256 eval { $obj->color_cmd_tmps(0,1); }; 3257 if ($@) { 3258 if (ref $@ 3259 and $@->isa("CPAN::Exception::RecursiveDependency")) { 3260 $CPAN::Frontend->mywarn($@); 3261 } else { 3262 if (0) { 3263 require Carp; 3264 Carp::confess(sprintf "DEBUG: \$\@[%s]ref[%s]", $@, ref $@); 3265 } 3266 die; 3267 } 3268 } 3269 } 3270 CPAN::Queue->queue_item(qmod => $obj->id, reqtype => "c"); 3271 push @qcopy, $obj; 3272 } elsif ($CPAN::META->exists('CPAN::Author',uc($s))) { 3273 $obj = $CPAN::META->instance('CPAN::Author',uc($s)); 3274 if ($meth =~ /^(dump|ls|reports)$/) { 3275 $obj->$meth(); 3276 } else { 3277 $CPAN::Frontend->mywarn( 3278 join "", 3279 "Don't be silly, you can't $meth ", 3280 $obj->fullname, 3281 " ;-)\n" 3282 ); 3283 $CPAN::Frontend->mysleep(2); 3284 } 3285 } elsif ($s =~ m|[\$\@\%]| && $meth eq "dump") { 3286 CPAN::InfoObj->dump($s); 3287 } else { 3288 $CPAN::Frontend 3289 ->mywarn(qq{Warning: Cannot $meth $s, }. 3290 qq{don't know what it is. 3291 Try the command 3292 3293 i /$s/ 3294 3295 to find objects with matching identifiers. 3296 }); 3297 $CPAN::Frontend->mysleep(2); 3298 } 3299 } 3300 3301 # queuerunner (please be warned: when I started to change the 3302 # queue to hold objects instead of names, I made one or two 3303 # mistakes and never found which. I reverted back instead) 3304 while (my $q = CPAN::Queue->first) { 3305 my $obj; 3306 my $s = $q->as_string; 3307 my $reqtype = $q->reqtype || ""; 3308 $obj = CPAN::Shell->expandany($s); 3309 unless ($obj) { 3310 # don't know how this can happen, maybe we should panic, 3311 # but maybe we get a solution from the first user who hits 3312 # this unfortunate exception? 3313 $CPAN::Frontend->mywarn("Warning: Could not expand string '$s' ". 3314 "to an object. Skipping.\n"); 3315 $CPAN::Frontend->mysleep(5); 3316 CPAN::Queue->delete_first($s); 3317 next; 3318 } 3319 $obj->{reqtype} ||= ""; 3320 { 3321 # force debugging because CPAN::SQLite somehow delivers us 3322 # an empty object; 3323 3324 # local $CPAN::DEBUG = 1024; # Shell; probably fixed now 3325 3326 CPAN->debug("s[$s]obj-reqtype[$obj->{reqtype}]". 3327 "q-reqtype[$reqtype]") if $CPAN::DEBUG; 3328 } 3329 if ($obj->{reqtype}) { 3330 if ($obj->{reqtype} eq "b" && $reqtype =~ /^[rc]$/) { 3331 $obj->{reqtype} = $reqtype; 3332 if ( 3333 exists $obj->{install} 3334 && 3335 ( 3336 UNIVERSAL::can($obj->{install},"failed") ? 3337 $obj->{install}->failed : 3338 $obj->{install} =~ /^NO/ 3339 ) 3340 ) { 3341 delete $obj->{install}; 3342 $CPAN::Frontend->mywarn 3343 ("Promoting $obj->{ID} from 'build_requires' to 'requires'"); 3344 } 3345 } 3346 } else { 3347 $obj->{reqtype} = $reqtype; 3348 } 3349 3350 for my $pragma (@pragma) { 3351 if ($pragma 3352 && 3353 $obj->can($pragma)) { 3354 $obj->$pragma($meth); 3355 } 3356 } 3357 if (UNIVERSAL::can($obj, 'called_for')) { 3358 $obj->called_for($s); 3359 } 3360 CPAN->debug(qq{pragma[@pragma]meth[$meth]}. 3361 qq{ID[$obj->{ID}]}) if $CPAN::DEBUG; 3362 3363 push @qcopy, $obj; 3364 if ($meth =~ /^(report)$/) { # they came here with a pragma? 3365 $self->$meth($obj); 3366 } elsif (! UNIVERSAL::can($obj,$meth)) { 3367 # Must never happen 3368 my $serialized = ""; 3369 if (0) { 3370 } elsif ($CPAN::META->has_inst("YAML::Syck")) { 3371 $serialized = YAML::Syck::Dump($obj); 3372 } elsif ($CPAN::META->has_inst("YAML")) { 3373 $serialized = YAML::Dump($obj); 3374 } elsif ($CPAN::META->has_inst("Data::Dumper")) { 3375 $serialized = Data::Dumper::Dumper($obj); 3376 } else { 3377 require overload; 3378 $serialized = overload::StrVal($obj); 3379 } 3380 CPAN->debug("Going to panic. meth[$meth]s[$s]") if $CPAN::DEBUG; 3381 $CPAN::Frontend->mydie("Panic: obj[$serialized] cannot meth[$meth]"); 3382 } elsif ($obj->$meth()) { 3383 CPAN::Queue->delete($s); 3384 CPAN->debug("From queue deleted. meth[$meth]s[$s]") if $CPAN::DEBUG; 3385 } else { 3386 CPAN->debug("Failed. pragma[@pragma]meth[$meth]") if $CPAN::DEBUG; 3387 } 3388 3389 $obj->undelay; 3390 for my $pragma (@pragma) { 3391 my $unpragma = "un$pragma"; 3392 if ($obj->can($unpragma)) { 3393 $obj->$unpragma(); 3394 } 3395 } 3396 CPAN::Queue->delete_first($s); 3397 } 3398 if ($meth =~ /^($needs_recursion_protection)$/) { 3399 for my $obj (@qcopy) { 3400 $obj->color_cmd_tmps(0,0); 3401 } 3402 } 3403 } 3404 3405 #-> sub CPAN::Shell::recent ; 3406 sub recent { 3407 my($self) = @_; 3408 if ($CPAN::META->has_inst("XML::LibXML")) { 3409 my $url = $CPAN::Defaultrecent; 3410 $CPAN::Frontend->myprint("Going to fetch '$url'\n"); 3411 unless ($CPAN::META->has_usable("LWP")) { 3412 $CPAN::Frontend->mydie("LWP not installed; cannot continue"); 3413 } 3414 CPAN::LWP::UserAgent->config; 3415 my $Ua; 3416 eval { $Ua = CPAN::LWP::UserAgent->new; }; 3417 if ($@) { 3418 $CPAN::Frontend->mydie("CPAN::LWP::UserAgent->new dies with $@\n"); 3419 } 3420 my $resp = $Ua->get($url); 3421 unless ($resp->is_success) { 3422 $CPAN::Frontend->mydie(sprintf "Could not download '%s': %s\n", $url, $resp->code); 3423 } 3424 $CPAN::Frontend->myprint("DONE\n\n"); 3425 my $xml = XML::LibXML->new->parse_string($resp->content); 3426 if (0) { 3427 my $s = $xml->serialize(2); 3428 $s =~ s/\n\s*\n/\n/g; 3429 $CPAN::Frontend->myprint($s); 3430 return; 3431 } 3432 my @distros; 3433 if ($url =~ /winnipeg/) { 3434 my $pubdate = $xml->findvalue("/rss/channel/pubDate"); 3435 $CPAN::Frontend->myprint(" pubDate: $pubdate\n\n"); 3436 for my $eitem ($xml->findnodes("/rss/channel/item")) { 3437 my $distro = $eitem->findvalue("enclosure/\@url"); 3438 $distro =~ s|.*?/authors/id/./../||; 3439 my $size = $eitem->findvalue("enclosure/\@length"); 3440 my $desc = $eitem->findvalue("description"); 3441 $desc =~ s/.+? - //; 3442 $CPAN::Frontend->myprint("$distro [$size b]\n $desc\n"); 3443 push @distros, $distro; 3444 } 3445 } elsif ($url =~ /search.*uploads.rdf/) { 3446 # xmlns:rdf="http://www.w3.org/1999/02/22-rdf-syntax-ns#" 3447 # xmlns="http://purl.org/rss/1.0/" 3448 # xmlns:taxo="http://purl.org/rss/1.0/modules/taxonomy/" 3449 # xmlns:dc="http://purl.org/dc/elements/1.1/" 3450 # xmlns:syn="http://purl.org/rss/1.0/modules/syndication/" 3451 # xmlns:admin="http://webns.net/mvcb/" 3452 3453 3454 my $dc_date = $xml->findvalue("//*[local-name(.) = 'RDF']/*[local-name(.) = 'channel']/*[local-name(.) = 'date']"); 3455 $CPAN::Frontend->myprint(" dc:date: $dc_date\n\n"); 3456 my $finish_eitem = 0; 3457 local $SIG{INT} = sub { $finish_eitem = 1 }; 3458 EITEM: for my $eitem ($xml->findnodes("//*[local-name(.) = 'RDF']/*[local-name(.) = 'item']")) { 3459 my $distro = $eitem->findvalue("\@rdf:about"); 3460 $distro =~ s|.*~||; # remove up to the tilde before the name 3461 $distro =~ s|/$||; # remove trailing slash 3462 $distro =~ s|([^/]+)|\U$1\E|; # upcase the name 3463 my $author = uc $1 or die "distro[$distro] without author, cannot continue"; 3464 my $desc = $eitem->findvalue("*[local-name(.) = 'description']"); 3465 my $i = 0; 3466 SUBDIRTEST: while () { 3467 last SUBDIRTEST if ++$i >= 6; # half a dozen must do! 3468 if (my @ret = $self->globls("$distro*")) { 3469 @ret = grep {$_->[2] !~ /meta/} @ret; 3470 @ret = grep {length $_->[2]} @ret; 3471 if (@ret) { 3472 $distro = "$author/$ret[0][2]"; 3473 last SUBDIRTEST; 3474 } 3475 } 3476 $distro =~ s|/|/*/|; # allow it to reside in a subdirectory 3477 } 3478 3479 next EITEM if $distro =~ m|\*|; # did not find the thing 3480 $CPAN::Frontend->myprint("____$desc\n"); 3481 push @distros, $distro; 3482 last EITEM if $finish_eitem; 3483 } 3484 } 3485 return \@distros; 3486 } else { 3487 # deprecated old version 3488 $CPAN::Frontend->mydie("no XML::LibXML installed, cannot continue\n"); 3489 } 3490 } 3491 3492 #-> sub CPAN::Shell::smoke ; 3493 sub smoke { 3494 my($self) = @_; 3495 my $distros = $self->recent; 3496 DISTRO: for my $distro (@$distros) { 3497 $CPAN::Frontend->myprint(sprintf "Going to download and test '$distro'\n"); 3498 { 3499 my $skip = 0; 3500 local $SIG{INT} = sub { $skip = 1 }; 3501 for (0..9) { 3502 $CPAN::Frontend->myprint(sprintf "\r%2d (Hit ^C to skip)", 10-$_); 3503 sleep 1; 3504 if ($skip) { 3505 $CPAN::Frontend->myprint(" skipped\n"); 3506 next DISTRO; 3507 } 3508 } 3509 } 3510 $CPAN::Frontend->myprint("\r \n"); # leave the dirty line with a newline 3511 $self->test($distro); 3512 } 3513 } 3514 3515 { 3516 # set up the dispatching methods 3517 no strict "refs"; 3518 for my $command (qw( 3519 clean 3520 cvs_import 3521 dump 3522 force 3523 fforce 3524 get 3525 install 3526 look 3527 ls 3528 make 3529 notest 3530 perldoc 3531 readme 3532 reports 3533 test 3534 )) { 3535 *$command = sub { shift->rematein($command, @_); }; 3536 } 3537 } 3538 3539 package CPAN::LWP::UserAgent; 3540 use strict; 3541 3542 sub config { 3543 return if $SETUPDONE; 3544 if ($CPAN::META->has_usable('LWP::UserAgent')) { 3545 require LWP::UserAgent; 3546 @ISA = qw(Exporter LWP::UserAgent); 3547 $SETUPDONE++; 3548 } else { 3549 $CPAN::Frontend->mywarn(" LWP::UserAgent not available\n"); 3550 } 3551 } 3552 3553 sub get_basic_credentials { 3554 my($self, $realm, $uri, $proxy) = @_; 3555 if ($USER && $PASSWD) { 3556 return ($USER, $PASSWD); 3557 } 3558 if ( $proxy ) { 3559 ($USER,$PASSWD) = $self->get_proxy_credentials(); 3560 } else { 3561 ($USER,$PASSWD) = $self->get_non_proxy_credentials(); 3562 } 3563 return($USER,$PASSWD); 3564 } 3565 3566 sub get_proxy_credentials { 3567 my $self = shift; 3568 my ($user, $password); 3569 if ( defined $CPAN::Config->{proxy_user} && 3570 defined $CPAN::Config->{proxy_pass}) { 3571 $user = $CPAN::Config->{proxy_user}; 3572 $password = $CPAN::Config->{proxy_pass}; 3573 return ($user, $password); 3574 } 3575 my $username_prompt = "\nProxy authentication needed! 3576 (Note: to permanently configure username and password run 3577 o conf proxy_user your_username 3578 o conf proxy_pass your_password 3579 )\nUsername:"; 3580 ($user, $password) = 3581 _get_username_and_password_from_user($username_prompt); 3582 return ($user,$password); 3583 } 3584 3585 sub get_non_proxy_credentials { 3586 my $self = shift; 3587 my ($user,$password); 3588 if ( defined $CPAN::Config->{username} && 3589 defined $CPAN::Config->{password}) { 3590 $user = $CPAN::Config->{username}; 3591 $password = $CPAN::Config->{password}; 3592 return ($user, $password); 3593 } 3594 my $username_prompt = "\nAuthentication needed! 3595 (Note: to permanently configure username and password run 3596 o conf username your_username 3597 o conf password your_password 3598 )\nUsername:"; 3599 3600 ($user, $password) = 3601 _get_username_and_password_from_user($username_prompt); 3602 return ($user,$password); 3603 } 3604 3605 sub _get_username_and_password_from_user { 3606 my $username_message = shift; 3607 my ($username,$password); 3608 3609 ExtUtils::MakeMaker->import(qw(prompt)); 3610 $username = prompt($username_message); 3611 if ($CPAN::META->has_inst("Term::ReadKey")) { 3612 Term::ReadKey::ReadMode("noecho"); 3613 } 3614 else { 3615 $CPAN::Frontend->mywarn( 3616 "Warning: Term::ReadKey seems not to be available, your password will be echoed to the terminal!\n" 3617 ); 3618 } 3619 $password = prompt("Password:"); 3620 3621 if ($CPAN::META->has_inst("Term::ReadKey")) { 3622 Term::ReadKey::ReadMode("restore"); 3623 } 3624 $CPAN::Frontend->myprint("\n\n"); 3625 return ($username,$password); 3626 } 3627 3628 # mirror(): Its purpose is to deal with proxy authentication. When we 3629 # call SUPER::mirror, we relly call the mirror method in 3630 # LWP::UserAgent. LWP::UserAgent will then call 3631 # $self->get_basic_credentials or some equivalent and this will be 3632 # $self->dispatched to our own get_basic_credentials method. 3633 3634 # Our own get_basic_credentials sets $USER and $PASSWD, two globals. 3635 3636 # 407 stands for HTTP_PROXY_AUTHENTICATION_REQUIRED. Which means 3637 # although we have gone through our get_basic_credentials, the proxy 3638 # server refuses to connect. This could be a case where the username or 3639 # password has changed in the meantime, so I'm trying once again without 3640 # $USER and $PASSWD to give the get_basic_credentials routine another 3641 # chance to set $USER and $PASSWD. 3642 3643 # mirror(): Its purpose is to deal with proxy authentication. When we 3644 # call SUPER::mirror, we relly call the mirror method in 3645 # LWP::UserAgent. LWP::UserAgent will then call 3646 # $self->get_basic_credentials or some equivalent and this will be 3647 # $self->dispatched to our own get_basic_credentials method. 3648 3649 # Our own get_basic_credentials sets $USER and $PASSWD, two globals. 3650 3651 # 407 stands for HTTP_PROXY_AUTHENTICATION_REQUIRED. Which means 3652 # although we have gone through our get_basic_credentials, the proxy 3653 # server refuses to connect. This could be a case where the username or 3654 # password has changed in the meantime, so I'm trying once again without 3655 # $USER and $PASSWD to give the get_basic_credentials routine another 3656 # chance to set $USER and $PASSWD. 3657 3658 sub mirror { 3659 my($self,$url,$aslocal) = @_; 3660 my $result = $self->SUPER::mirror($url,$aslocal); 3661 if ($result->code == 407) { 3662 undef $USER; 3663 undef $PASSWD; 3664 $result = $self->SUPER::mirror($url,$aslocal); 3665 } 3666 $result; 3667 } 3668 3669 package CPAN::FTP; 3670 use strict; 3671 3672 #-> sub CPAN::FTP::ftp_statistics 3673 # if they want to rewrite, they need to pass in a filehandle 3674 sub _ftp_statistics { 3675 my($self,$fh) = @_; 3676 my $locktype = $fh ? LOCK_EX : LOCK_SH; 3677 $fh ||= FileHandle->new; 3678 my $file = File::Spec->catfile($CPAN::Config->{cpan_home},"FTPstats.yml"); 3679 open $fh, "+>>$file" or $CPAN::Frontend->mydie("Could not open '$file': $!"); 3680 my $sleep = 1; 3681 my $waitstart; 3682 while (!CPAN::_flock($fh, $locktype|LOCK_NB)) { 3683 $waitstart ||= localtime(); 3684 if ($sleep>3) { 3685 $CPAN::Frontend->mywarn("Waiting for a read lock on '$file' (since $waitstart)\n"); 3686 } 3687 $CPAN::Frontend->mysleep($sleep); 3688 if ($sleep <= 3) { 3689 $sleep+=0.33; 3690 } elsif ($sleep <=6) { 3691 $sleep+=0.11; 3692 } 3693 } 3694 my $stats = eval { CPAN->_yaml_loadfile($file); }; 3695 if ($@) { 3696 if (ref $@) { 3697 if (ref $@ eq "CPAN::Exception::yaml_not_installed") { 3698 $CPAN::Frontend->myprint("Warning (usually harmless): $@"); 3699 return; 3700 } elsif (ref $@ eq "CPAN::Exception::yaml_process_error") { 3701 $CPAN::Frontend->mydie($@); 3702 } 3703 } else { 3704 $CPAN::Frontend->mydie($@); 3705 } 3706 } 3707 return $stats->[0]; 3708 } 3709 3710 #-> sub CPAN::FTP::_mytime 3711 sub _mytime () { 3712 if (CPAN->has_inst("Time::HiRes")) { 3713 return Time::HiRes::time(); 3714 } else { 3715 return time; 3716 } 3717 } 3718 3719 #-> sub CPAN::FTP::_new_stats 3720 sub _new_stats { 3721 my($self,$file) = @_; 3722 my $ret = { 3723 file => $file, 3724 attempts => [], 3725 start => _mytime, 3726 }; 3727 $ret; 3728 } 3729 3730 #-> sub CPAN::FTP::_add_to_statistics 3731 sub _add_to_statistics { 3732 my($self,$stats) = @_; 3733 my $yaml_module = CPAN::_yaml_module; 3734 $self->debug("yaml_module[$yaml_module]") if $CPAN::DEBUG; 3735 if ($CPAN::META->has_inst($yaml_module)) { 3736 $stats->{thesiteurl} = $ThesiteURL; 3737 if (CPAN->has_inst("Time::HiRes")) { 3738 $stats->{end} = Time::HiRes::time(); 3739 } else { 3740 $stats->{end} = time; 3741 } 3742 my $fh = FileHandle->new; 3743 my $time = time; 3744 my $sdebug = 0; 3745 my @debug; 3746 @debug = $time if $sdebug; 3747 my $fullstats = $self->_ftp_statistics($fh); 3748 close $fh; 3749 $fullstats->{history} ||= []; 3750 push @debug, scalar @{$fullstats->{history}} if $sdebug; 3751 push @debug, time if $sdebug; 3752 push @{$fullstats->{history}}, $stats; 3753 # arbitrary hardcoded constants until somebody demands to have 3754 # them settable; YAML.pm 0.62 is unacceptably slow with 999; 3755 # YAML::Syck 0.82 has no noticable performance problem with 999; 3756 while ( 3757 @{$fullstats->{history}} > 99 3758 || $time - $fullstats->{history}[0]{start} > 14*86400 3759 ) { 3760 shift @{$fullstats->{history}} 3761 } 3762 push @debug, scalar @{$fullstats->{history}} if $sdebug; 3763 push @debug, time if $sdebug; 3764 push @debug, scalar localtime($fullstats->{history}[0]{start}) if $sdebug; 3765 # need no eval because if this fails, it is serious 3766 my $sfile = File::Spec->catfile($CPAN::Config->{cpan_home},"FTPstats.yml"); 3767 CPAN->_yaml_dumpfile("$sfile.$$",$fullstats); 3768 if ( $sdebug ) { 3769 local $CPAN::DEBUG = 512; # FTP 3770 push @debug, time; 3771 CPAN->debug(sprintf("DEBUG history: before_read[%d]before[%d]at[%d]". 3772 "after[%d]at[%d]oldest[%s]dumped backat[%d]", 3773 @debug, 3774 )); 3775 } 3776 # Win32 cannot rename a file to an existing filename 3777 unlink($sfile) if ($^O eq 'MSWin32'); 3778 rename "$sfile.$$", $sfile 3779 or $CPAN::Frontend->mydie("Could not rename '$sfile.$$' to '$sfile': $!\n"); 3780 } 3781 } 3782 3783 # if file is CHECKSUMS, suggest the place where we got the file to be 3784 # checked from, maybe only for young files? 3785 #-> sub CPAN::FTP::_recommend_url_for 3786 sub _recommend_url_for { 3787 my($self, $file) = @_; 3788 my $urllist = $self->_get_urllist; 3789 if ($file =~ s|/CHECKSUMS(.gz)?$||) { 3790 my $fullstats = $self->_ftp_statistics(); 3791 my $history = $fullstats->{history} || []; 3792 while (my $last = pop @$history) { 3793 last if $last->{end} - time > 3600; # only young results are interesting 3794 next unless $last->{file}; # dirname of nothing dies! 3795 next unless $file eq File::Basename::dirname($last->{file}); 3796 return $last->{thesiteurl}; 3797 } 3798 } 3799 if ($CPAN::Config->{randomize_urllist} 3800 && 3801 rand(1) < $CPAN::Config->{randomize_urllist} 3802 ) { 3803 $urllist->[int rand scalar @$urllist]; 3804 } else { 3805 return (); 3806 } 3807 } 3808 3809 #-> sub CPAN::FTP::_get_urllist 3810 sub _get_urllist { 3811 my($self) = @_; 3812 $CPAN::Config->{urllist} ||= []; 3813 unless (ref $CPAN::Config->{urllist} eq 'ARRAY') { 3814 $CPAN::Frontend->mywarn("Malformed urllist; ignoring. Configuration file corrupt?\n"); 3815 $CPAN::Config->{urllist} = []; 3816 } 3817 my @urllist = grep { defined $_ and length $_ } @{$CPAN::Config->{urllist}}; 3818 for my $u (@urllist) { 3819 CPAN->debug("u[$u]") if $CPAN::DEBUG; 3820 if (UNIVERSAL::can($u,"text")) { 3821 $u->{TEXT} .= "/" unless substr($u->{TEXT},-1) eq "/"; 3822 } else { 3823 $u .= "/" unless substr($u,-1) eq "/"; 3824 $u = CPAN::URL->new(TEXT => $u, FROM => "USER"); 3825 } 3826 } 3827 \@urllist; 3828 } 3829 3830 #-> sub CPAN::FTP::ftp_get ; 3831 sub ftp_get { 3832 my($class,$host,$dir,$file,$target) = @_; 3833 $class->debug( 3834 qq[Going to fetch file [$file] from dir [$dir] 3835 on host [$host] as local [$target]\n] 3836 ) if $CPAN::DEBUG; 3837 my $ftp = Net::FTP->new($host); 3838 unless ($ftp) { 3839 $CPAN::Frontend->mywarn(" Could not connect to host '$host' with Net::FTP\n"); 3840 return; 3841 } 3842 return 0 unless defined $ftp; 3843 $ftp->debug(1) if $CPAN::DEBUG{'FTP'} & $CPAN::DEBUG; 3844 $class->debug(qq[Going to login("anonymous","$Config::Config{cf_email}")]); 3845 unless ( $ftp->login("anonymous",$Config::Config{'cf_email'}) ) { 3846 my $msg = $ftp->message; 3847 $CPAN::Frontend->mywarn(" Couldn't login on $host: $msg"); 3848 return; 3849 } 3850 unless ( $ftp->cwd($dir) ) { 3851 my $msg = $ftp->message; 3852 $CPAN::Frontend->mywarn(" Couldn't cwd $dir: $msg"); 3853 return; 3854 } 3855 $ftp->binary; 3856 $class->debug(qq[Going to ->get("$file","$target")\n]) if $CPAN::DEBUG; 3857 unless ( $ftp->get($file,$target) ) { 3858 my $msg = $ftp->message; 3859 $CPAN::Frontend->mywarn(" Couldn't fetch $file from $host: $msg"); 3860 return; 3861 } 3862 $ftp->quit; # it's ok if this fails 3863 return 1; 3864 } 3865 3866 # If more accuracy is wanted/needed, Chris Leach sent me this patch... 3867 3868 # > *** /install/perl/live/lib/CPAN.pm- Wed Sep 24 13:08:48 1997 3869 # > --- /tmp/cp Wed Sep 24 13:26:40 1997 3870 # > *************** 3871 # > *** 1562,1567 **** 3872 # > --- 1562,1580 ---- 3873 # > return 1 if substr($url,0,4) eq "file"; 3874 # > return 1 unless $url =~ m|://([^/]+)|; 3875 # > my $host = $1; 3876 # > + my $proxy = $CPAN::Config->{'http_proxy'} || $ENV{'http_proxy'}; 3877 # > + if ($proxy) { 3878 # > + $proxy =~ m|://([^/:]+)|; 3879 # > + $proxy = $1; 3880 # > + my $noproxy = $CPAN::Config->{'no_proxy'} || $ENV{'no_proxy'}; 3881 # > + if ($noproxy) { 3882 # > + if ($host !~ /$noproxy$/) { 3883 # > + $host = $proxy; 3884 # > + } 3885 # > + } else { 3886 # > + $host = $proxy; 3887 # > + } 3888 # > + } 3889 # > require Net::Ping; 3890 # > return 1 unless $Net::Ping::VERSION >= 2; 3891 # > my $p; 3892 3893 3894 #-> sub CPAN::FTP::localize ; 3895 sub localize { 3896 my($self,$file,$aslocal,$force) = @_; 3897 $force ||= 0; 3898 Carp::croak "Usage: ->localize(cpan_file,as_local_file[,$force])" 3899 unless defined $aslocal; 3900 $self->debug("file[$file] aslocal[$aslocal] force[$force]") 3901 if $CPAN::DEBUG; 3902 3903 if ($^O eq 'MacOS') { 3904 # Comment by AK on 2000-09-03: Uniq short filenames would be 3905 # available in CHECKSUMS file 3906 my($name, $path) = File::Basename::fileparse($aslocal, ''); 3907 if (length($name) > 31) { 3908 $name =~ s/( 3909 \.( 3910 readme(\.(gz|Z))? | 3911 (tar\.)?(gz|Z) | 3912 tgz | 3913 zip | 3914 pm\.(gz|Z) 3915 ) 3916 )$//x; 3917 my $suf = $1; 3918 my $size = 31 - length($suf); 3919 while (length($name) > $size) { 3920 chop $name; 3921 } 3922 $name .= $suf; 3923 $aslocal = File::Spec->catfile($path, $name); 3924 } 3925 } 3926 3927 if (-f $aslocal && -r _ && !($force & 1)) { 3928 my $size; 3929 if ($size = -s $aslocal) { 3930 $self->debug("aslocal[$aslocal]size[$size]") if $CPAN::DEBUG; 3931 return $aslocal; 3932 } else { 3933 # empty file from a previous unsuccessful attempt to download it 3934 unlink $aslocal or 3935 $CPAN::Frontend->mydie("Found a zero-length '$aslocal' that I ". 3936 "could not remove."); 3937 } 3938 } 3939 my($maybe_restore) = 0; 3940 if (-f $aslocal) { 3941 rename $aslocal, "$aslocal.bak$$"; 3942 $maybe_restore++; 3943 } 3944 3945 my($aslocal_dir) = File::Basename::dirname($aslocal); 3946 $self->mymkpath($aslocal_dir); # too early for file URLs / RT #28438 3947 # Inheritance is not easier to manage than a few if/else branches 3948 if ($CPAN::META->has_usable('LWP::UserAgent')) { 3949 unless ($Ua) { 3950 CPAN::LWP::UserAgent->config; 3951 eval {$Ua = CPAN::LWP::UserAgent->new;}; # Why is has_usable still not fit enough? 3952 if ($@) { 3953 $CPAN::Frontend->mywarn("CPAN::LWP::UserAgent->new dies with $@\n") 3954 if $CPAN::DEBUG; 3955 } else { 3956 my($var); 3957 $Ua->proxy('ftp', $var) 3958 if $var = $CPAN::Config->{ftp_proxy} || $ENV{ftp_proxy}; 3959 $Ua->proxy('http', $var) 3960 if $var = $CPAN::Config->{http_proxy} || $ENV{http_proxy}; 3961 $Ua->no_proxy($var) 3962 if $var = $CPAN::Config->{no_proxy} || $ENV{no_proxy}; 3963 } 3964 } 3965 } 3966 for my $prx (qw(ftp_proxy http_proxy no_proxy)) { 3967 $ENV{$prx} = $CPAN::Config->{$prx} if $CPAN::Config->{$prx}; 3968 } 3969 3970 # Try the list of urls for each single object. We keep a record 3971 # where we did get a file from 3972 my(@reordered,$last); 3973 my $ccurllist = $self->_get_urllist; 3974 $last = $#$ccurllist; 3975 if ($force & 2) { # local cpans probably out of date, don't reorder 3976 @reordered = (0..$last); 3977 } else { 3978 @reordered = 3979 sort { 3980 (substr($ccurllist->[$b],0,4) eq "file") 3981 <=> 3982 (substr($ccurllist->[$a],0,4) eq "file") 3983 or 3984 defined($ThesiteURL) 3985 and 3986 ($ccurllist->[$b] eq $ThesiteURL) 3987 <=> 3988 ($ccurllist->[$a] eq $ThesiteURL) 3989 } 0..$last; 3990 } 3991 my(@levels); 3992 $Themethod ||= ""; 3993 $self->debug("Themethod[$Themethod]reordered[@reordered]") if $CPAN::DEBUG; 3994 my @all_levels = ( 3995 ["dleasy", "file"], 3996 ["dleasy"], 3997 ["dlhard"], 3998 ["dlhardest"], 3999 ["dleasy", "http","defaultsites"], 4000 ["dlhard", "http","defaultsites"], 4001 ["dleasy", "ftp", "defaultsites"], 4002 ["dlhard", "ftp", "defaultsites"], 4003 ["dlhardest","", "defaultsites"], 4004 ); 4005 if ($Themethod) { 4006 @levels = grep {$_->[0] eq $Themethod} @all_levels; 4007 push @levels, grep {$_->[0] ne $Themethod} @all_levels; 4008 } else { 4009 @levels = @all_levels; 4010 } 4011 @levels = qw/dleasy/ if $^O eq 'MacOS'; 4012 my($levelno); 4013 local $ENV{FTP_PASSIVE} = 4014 exists $CPAN::Config->{ftp_passive} ? 4015 $CPAN::Config->{ftp_passive} : 1; 4016 my $ret; 4017 my $stats = $self->_new_stats($file); 4018 LEVEL: for $levelno (0..$#levels) { 4019 my $level_tuple = $levels[$levelno]; 4020 my($level,$scheme,$sitetag) = @$level_tuple; 4021 my $defaultsites = $sitetag && $sitetag eq "defaultsites"; 4022 my @urllist; 4023 if ($defaultsites) { 4024 unless (defined $connect_to_internet_ok) { 4025 $CPAN::Frontend->myprint(sprintf qq{ 4026 I would like to connect to one of the following sites to get '%s': 4027 4028 %s 4029 }, 4030 $file, 4031 join("",map { " ".$_->text."\n" } @CPAN::Defaultsites), 4032 ); 4033 my $answer = CPAN::Shell::colorable_makemaker_prompt("Is it OK to try to connect to the Internet?", "yes"); 4034 if ($answer =~ /^y/i) { 4035 $connect_to_internet_ok = 1; 4036 } else { 4037 $connect_to_internet_ok = 0; 4038 } 4039 } 4040 if ($connect_to_internet_ok) { 4041 @urllist = @CPAN::Defaultsites; 4042 } else { 4043 @urllist = (); 4044 } 4045 } else { 4046 my @host_seq = $level =~ /dleasy/ ? 4047 @reordered : 0..$last; # reordered has file and $Thesiteurl first 4048 @urllist = map { $ccurllist->[$_] } @host_seq; 4049 } 4050 $self->debug("synth. urllist[@urllist]") if $CPAN::DEBUG; 4051 my $aslocal_tempfile = $aslocal . ".tmp" . $$; 4052 if (my $recommend = $self->_recommend_url_for($file)) { 4053 @urllist = grep { $_ ne $recommend } @urllist; 4054 unshift @urllist, $recommend; 4055 } 4056 $self->debug("synth. urllist[@urllist]") if $CPAN::DEBUG; 4057 $ret = $self->hostdlxxx($level,$scheme,\@urllist,$file,$aslocal_tempfile,$stats); 4058 if ($ret) { 4059 CPAN->debug("ret[$ret]aslocal[$aslocal]") if $CPAN::DEBUG; 4060 if ($ret eq $aslocal_tempfile) { 4061 # if we got it exactly as we asked for, only then we 4062 # want to rename 4063 rename $aslocal_tempfile, $aslocal 4064 or $CPAN::Frontend->mydie("Error while trying to rename ". 4065 "'$ret' to '$aslocal': $!"); 4066 $ret = $aslocal; 4067 } 4068 $Themethod = $level; 4069 my $now = time; 4070 # utime $now, $now, $aslocal; # too bad, if we do that, we 4071 # might alter a local mirror 4072 $self->debug("level[$level]") if $CPAN::DEBUG; 4073 last LEVEL; 4074 } else { 4075 unlink $aslocal_tempfile; 4076 last if $CPAN::Signal; # need to cleanup 4077 } 4078 } 4079 if ($ret) { 4080 $stats->{filesize} = -s $ret; 4081 } 4082 $self->debug("before _add_to_statistics") if $CPAN::DEBUG; 4083 $self->_add_to_statistics($stats); 4084 $self->debug("after _add_to_statistics") if $CPAN::DEBUG; 4085 if ($ret) { 4086 unlink "$aslocal.bak$$"; 4087 return $ret; 4088 } 4089 unless ($CPAN::Signal) { 4090 my(@mess); 4091 local $" = " "; 4092 if (@{$CPAN::Config->{urllist}}) { 4093 push @mess, 4094 qq{Please check, if the URLs I found in your configuration file \(}. 4095 join(", ", @{$CPAN::Config->{urllist}}). 4096 qq{\) are valid.}; 4097 } else { 4098 push @mess, qq{Your urllist is empty!}; 4099 } 4100 push @mess, qq{The urllist can be edited.}, 4101 qq{E.g. with 'o conf urllist push ftp://myurl/'}; 4102 $CPAN::Frontend->mywarn(Text::Wrap::wrap("","","@mess"). "\n\n"); 4103 $CPAN::Frontend->mywarn("Could not fetch $file\n"); 4104 $CPAN::Frontend->mysleep(2); 4105 } 4106 if ($maybe_restore) { 4107 rename "$aslocal.bak$$", $aslocal; 4108 $CPAN::Frontend->myprint("Trying to get away with old file:\n" . 4109 $self->ls($aslocal)); 4110 return $aslocal; 4111 } 4112 return; 4113 } 4114 4115 sub mymkpath { 4116 my($self, $aslocal_dir) = @_; 4117 File::Path::mkpath($aslocal_dir); 4118 $CPAN::Frontend->mywarn(qq{Warning: You are not allowed to write into }. 4119 qq{directory "$aslocal_dir". 4120 I\'ll continue, but if you encounter problems, they may be due 4121 to insufficient permissions.\n}) unless -w $aslocal_dir; 4122 } 4123 4124 sub hostdlxxx { 4125 my $self = shift; 4126 my $level = shift; 4127 my $scheme = shift; 4128 my $h = shift; 4129 $h = [ grep /^\Q$scheme\E:/, @$h ] if $scheme; 4130 my $method = "host$level"; 4131 $self->$method($h, @_); 4132 } 4133 4134 sub _set_attempt { 4135 my($self,$stats,$method,$url) = @_; 4136 push @{$stats->{attempts}}, { 4137 method => $method, 4138 start => _mytime, 4139 url => $url, 4140 }; 4141 } 4142 4143 # package CPAN::FTP; 4144 sub hostdleasy { 4145 my($self,$host_seq,$file,$aslocal,$stats) = @_; 4146 my($ro_url); 4147 HOSTEASY: for $ro_url (@$host_seq) { 4148 $self->_set_attempt($stats,"dleasy",$ro_url); 4149 my $url .= "$ro_url$file"; 4150 $self->debug("localizing perlish[$url]") if $CPAN::DEBUG; 4151 if ($url =~ /^file:/) { 4152 my $l; 4153 if ($CPAN::META->has_inst('URI::URL')) { 4154 my $u = URI::URL->new($url); 4155 $l = $u->path; 4156 } else { # works only on Unix, is poorly constructed, but 4157 # hopefully better than nothing. 4158 # RFC 1738 says fileurl BNF is 4159 # fileurl = "file://" [ host | "localhost" ] "/" fpath 4160 # Thanks to "Mark D. Baushke" <mdb@cisco.com> for 4161 # the code 4162 ($l = $url) =~ s|^file://[^/]*/|/|; # discard the host part 4163 $l =~ s|^file:||; # assume they 4164 # meant 4165 # file://localhost 4166 $l =~ s|^/||s 4167 if ! -f $l && $l =~ m|^/\w:|; # e.g. /P: 4168 } 4169 $self->debug("local file[$l]") if $CPAN::DEBUG; 4170 if ( -f $l && -r _) { 4171 $ThesiteURL = $ro_url; 4172 return $l; 4173 } 4174 if ($l =~ /(.+)\.gz$/) { 4175 my $ungz = $1; 4176 if ( -f $ungz && -r _) { 4177 $ThesiteURL = $ro_url; 4178 return $ungz; 4179 } 4180 } 4181 # Maybe mirror has compressed it? 4182 if (-f "$l.gz") { 4183 $self->debug("found compressed $l.gz") if $CPAN::DEBUG; 4184 eval { CPAN::Tarzip->new("$l.gz")->gunzip($aslocal) }; 4185 if ( -f $aslocal) { 4186 $ThesiteURL = $ro_url; 4187 return $aslocal; 4188 } 4189 } 4190 $CPAN::Frontend->mywarn("Could not find '$l'\n"); 4191 } 4192 $self->debug("it was not a file URL") if $CPAN::DEBUG; 4193 if ($CPAN::META->has_usable('LWP')) { 4194 $CPAN::Frontend->myprint("Fetching with LWP: 4195 $url 4196 "); 4197 unless ($Ua) { 4198 CPAN::LWP::UserAgent->config; 4199 eval { $Ua = CPAN::LWP::UserAgent->new; }; 4200 if ($@) { 4201 $CPAN::Frontend->mywarn("CPAN::LWP::UserAgent->new dies with $@\n"); 4202 } 4203 } 4204 my $res = $Ua->mirror($url, $aslocal); 4205 if ($res->is_success) { 4206 $ThesiteURL = $ro_url; 4207 my $now = time; 4208 utime $now, $now, $aslocal; # download time is more 4209 # important than upload 4210 # time 4211 return $aslocal; 4212 } elsif ($url !~ /\.gz(?!\n)\Z/) { 4213 my $gzurl = "$url.gz"; 4214 $CPAN::Frontend->myprint("Fetching with LWP: 4215 $gzurl 4216 "); 4217 $res = $Ua->mirror($gzurl, "$aslocal.gz"); 4218 if ($res->is_success) { 4219 if (eval {CPAN::Tarzip->new("$aslocal.gz")->gunzip($aslocal)}) { 4220 $ThesiteURL = $ro_url; 4221 return $aslocal; 4222 } 4223 } 4224 } else { 4225 $CPAN::Frontend->myprint(sprintf( 4226 "LWP failed with code[%s] message[%s]\n", 4227 $res->code, 4228 $res->message, 4229 )); 4230 # Alan Burlison informed me that in firewall environments 4231 # Net::FTP can still succeed where LWP fails. So we do not 4232 # skip Net::FTP anymore when LWP is available. 4233 } 4234 } else { 4235 $CPAN::Frontend->mywarn(" LWP not available\n"); 4236 } 4237 return if $CPAN::Signal; 4238 if ($url =~ m|^ftp://(.*?)/(.*)/(.*)|) { 4239 # that's the nice and easy way thanks to Graham 4240 $self->debug("recognized ftp") if $CPAN::DEBUG; 4241 my($host,$dir,$getfile) = ($1,$2,$3); 4242 if ($CPAN::META->has_usable('Net::FTP')) { 4243 $dir =~ s|/+|/|g; 4244 $CPAN::Frontend->myprint("Fetching with Net::FTP: 4245 $url 4246 "); 4247 $self->debug("getfile[$getfile]dir[$dir]host[$host]" . 4248 "aslocal[$aslocal]") if $CPAN::DEBUG; 4249 if (CPAN::FTP->ftp_get($host,$dir,$getfile,$aslocal)) { 4250 $ThesiteURL = $ro_url; 4251 return $aslocal; 4252 } 4253 if ($aslocal !~ /\.gz(?!\n)\Z/) { 4254 my $gz = "$aslocal.gz"; 4255 $CPAN::Frontend->myprint("Fetching with Net::FTP 4256 $url.gz 4257 "); 4258 if (CPAN::FTP->ftp_get($host, 4259 $dir, 4260 "$getfile.gz", 4261 $gz) && 4262 eval{CPAN::Tarzip->new($gz)->gunzip($aslocal)} 4263 ) { 4264 $ThesiteURL = $ro_url; 4265 return $aslocal; 4266 } 4267 } 4268 # next HOSTEASY; 4269 } else { 4270 CPAN->debug("Net::FTP does not count as usable atm") if $CPAN::DEBUG; 4271 } 4272 } 4273 if ( 4274 UNIVERSAL::can($ro_url,"text") 4275 and 4276 $ro_url->{FROM} eq "USER" 4277 ) { 4278 ##address #17973: default URLs should not try to override 4279 ##user-defined URLs just because LWP is not available 4280 my $ret = $self->hostdlhard([$ro_url],$file,$aslocal,$stats); 4281 return $ret if $ret; 4282 } 4283 return if $CPAN::Signal; 4284 } 4285 } 4286 4287 # package CPAN::FTP; 4288 sub hostdlhard { 4289 my($self,$host_seq,$file,$aslocal,$stats) = @_; 4290 4291 # Came back if Net::FTP couldn't establish connection (or 4292 # failed otherwise) Maybe they are behind a firewall, but they 4293 # gave us a socksified (or other) ftp program... 4294 4295 my($ro_url); 4296 my($devnull) = $CPAN::Config->{devnull} || ""; 4297 # < /dev/null "; 4298 my($aslocal_dir) = File::Basename::dirname($aslocal); 4299 File::Path::mkpath($aslocal_dir); 4300 HOSTHARD: for $ro_url (@$host_seq) { 4301 $self->_set_attempt($stats,"dlhard",$ro_url); 4302 my $url = "$ro_url$file"; 4303 my($proto,$host,$dir,$getfile); 4304 4305 # Courtesy Mark Conty mark_conty@cargill.com change from 4306 # if ($url =~ m|^ftp://(.*?)/(.*)/(.*)|) { 4307 # to 4308 if ($url =~ m|^([^:]+)://(.*?)/(.*)/(.*)|) { 4309 # proto not yet used 4310 ($proto,$host,$dir,$getfile) = ($1,$2,$3,$4); 4311 } else { 4312 next HOSTHARD; # who said, we could ftp anything except ftp? 4313 } 4314 next HOSTHARD if $proto eq "file"; # file URLs would have had 4315 # success above. Likely a bogus URL 4316 4317 $self->debug("localizing funkyftpwise[$url]") if $CPAN::DEBUG; 4318 4319 # Try the most capable first and leave ncftp* for last as it only 4320 # does FTP. 4321 DLPRG: for my $f (qw(curl wget lynx ncftpget ncftp)) { 4322 my $funkyftp = CPAN::HandleConfig->safe_quote($CPAN::Config->{$f}); 4323 next unless defined $funkyftp; 4324 next if $funkyftp =~ /^\s*$/; 4325 4326 my($asl_ungz, $asl_gz); 4327 ($asl_ungz = $aslocal) =~ s/\.gz//; 4328 $asl_gz = "$asl_ungz.gz"; 4329 4330 my($src_switch) = ""; 4331 my($chdir) = ""; 4332 my($stdout_redir) = " > $asl_ungz"; 4333 if ($f eq "lynx") { 4334 $src_switch = " -source"; 4335 } elsif ($f eq "ncftp") { 4336 $src_switch = " -c"; 4337 } elsif ($f eq "wget") { 4338 $src_switch = " -O $asl_ungz"; 4339 $stdout_redir = ""; 4340 } elsif ($f eq 'curl') { 4341 $src_switch = ' -L -f -s -S --netrc-optional'; 4342 } 4343 4344 if ($f eq "ncftpget") { 4345 $chdir = "cd $aslocal_dir && "; 4346 $stdout_redir = ""; 4347 } 4348 $CPAN::Frontend->myprint( 4349 qq[ 4350 Trying with "$funkyftp$src_switch" to get 4351 $url 4352 ]); 4353 my($system) = 4354 "$chdir$funkyftp$src_switch \"$url\" $devnull$stdout_redir"; 4355 $self->debug("system[$system]") if $CPAN::DEBUG; 4356 my($wstatus) = system($system); 4357 if ($f eq "lynx") { 4358 # lynx returns 0 when it fails somewhere 4359 if (-s $asl_ungz) { 4360 my $content = do { local *FH; 4361 open FH, $asl_ungz or die; 4362 local $/; 4363 <FH> }; 4364 if ($content =~ /^<.*(<title>[45]|Error [45])/si) { 4365 $CPAN::Frontend->mywarn(qq{ 4366 No success, the file that lynx has downloaded looks like an error message: 4367 $content 4368 }); 4369 $CPAN::Frontend->mysleep(1); 4370 next DLPRG; 4371 } 4372 } else { 4373 $CPAN::Frontend->myprint(qq{ 4374 No success, the file that lynx has downloaded is an empty file. 4375 }); 4376 next DLPRG; 4377 } 4378 } 4379 if ($wstatus == 0) { 4380 if (-s $aslocal) { 4381 # Looks good 4382 } elsif ($asl_ungz ne $aslocal) { 4383 # test gzip integrity 4384 if (eval{CPAN::Tarzip->new($asl_ungz)->gtest}) { 4385 # e.g. foo.tar is gzipped --> foo.tar.gz 4386 rename $asl_ungz, $aslocal; 4387 } else { 4388 eval{CPAN::Tarzip->new($asl_gz)->gzip($asl_ungz)}; 4389 } 4390 } 4391 $ThesiteURL = $ro_url; 4392 return $aslocal; 4393 } elsif ($url !~ /\.gz(?!\n)\Z/) { 4394 unlink $asl_ungz if 4395 -f $asl_ungz && -s _ == 0; 4396 my $gz = "$aslocal.gz"; 4397 my $gzurl = "$url.gz"; 4398 $CPAN::Frontend->myprint( 4399 qq[ 4400 Trying with "$funkyftp$src_switch" to get 4401 $url.gz 4402 ]); 4403 my($system) = "$funkyftp$src_switch \"$url.gz\" $devnull > $asl_gz"; 4404 $self->debug("system[$system]") if $CPAN::DEBUG; 4405 my($wstatus); 4406 if (($wstatus = system($system)) == 0 4407 && 4408 -s $asl_gz 4409 ) { 4410 # test gzip integrity 4411 my $ct = eval{CPAN::Tarzip->new($asl_gz)}; 4412 if ($ct && $ct->gtest) { 4413 $ct->gunzip($aslocal); 4414 } else { 4415 # somebody uncompressed file for us? 4416 rename $asl_ungz, $aslocal; 4417 } 4418 $ThesiteURL = $ro_url; 4419 return $aslocal; 4420 } else { 4421 unlink $asl_gz if -f $asl_gz; 4422 } 4423 } else { 4424 my $estatus = $wstatus >> 8; 4425 my $size = -f $aslocal ? 4426 ", left\n$aslocal with size ".-s _ : 4427 "\nWarning: expected file [$aslocal] doesn't exist"; 4428 $CPAN::Frontend->myprint(qq{ 4429 System call "$system" 4430 returned status $estatus (wstat $wstatus)$size 4431 }); 4432 } 4433 return if $CPAN::Signal; 4434 } # transfer programs 4435 } # host 4436 } 4437 4438 # package CPAN::FTP; 4439 sub hostdlhardest { 4440 my($self,$host_seq,$file,$aslocal,$stats) = @_; 4441 4442 return unless @$host_seq; 4443 my($ro_url); 4444 my($aslocal_dir) = File::Basename::dirname($aslocal); 4445 File::Path::mkpath($aslocal_dir); 4446 my $ftpbin = $CPAN::Config->{ftp}; 4447 unless ($ftpbin && length $ftpbin && MM->maybe_command($ftpbin)) { 4448 $CPAN::Frontend->myprint("No external ftp command available\n\n"); 4449 return; 4450 } 4451 $CPAN::Frontend->mywarn(qq{ 4452 As a last ressort we now switch to the external ftp command '$ftpbin' 4453 to get '$aslocal'. 4454 4455 Doing so often leads to problems that are hard to diagnose. 4456 4457 If you're victim of such problems, please consider unsetting the ftp 4458 config variable with 4459 4460 o conf ftp "" 4461 o conf commit 4462 4463 }); 4464 $CPAN::Frontend->mysleep(2); 4465 HOSTHARDEST: for $ro_url (@$host_seq) { 4466 $self->_set_attempt($stats,"dlhardest",$ro_url); 4467 my $url = "$ro_url$file"; 4468 $self->debug("localizing ftpwise[$url]") if $CPAN::DEBUG; 4469 unless ($url =~ m|^ftp://(.*?)/(.*)/(.*)|) { 4470 next; 4471 } 4472 my($host,$dir,$getfile) = ($1,$2,$3); 4473 my $timestamp = 0; 4474 my($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime, 4475 $ctime</