| [ 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,$blksize,$blocks) = stat($aslocal); 4476 $timestamp = $mtime ||= 0; 4477 my($netrc) = CPAN::FTP::netrc->new; 4478 my($netrcfile) = $netrc->netrc; 4479 my($verbose) = $CPAN::DEBUG{'FTP'} & $CPAN::DEBUG ? " -v" : ""; 4480 my $targetfile = File::Basename::basename($aslocal); 4481 my(@dialog); 4482 push( 4483 @dialog, 4484 "lcd $aslocal_dir", 4485 "cd /", 4486 map("cd $_", split /\//, $dir), # RFC 1738 4487 "bin", 4488 "get $getfile $targetfile", 4489 "quit" 4490 ); 4491 if (! $netrcfile) { 4492 CPAN->debug("No ~/.netrc file found") if $CPAN::DEBUG; 4493 } elsif ($netrc->hasdefault || $netrc->contains($host)) { 4494 CPAN->debug(sprintf("hasdef[%d]cont($host)[%d]", 4495 $netrc->hasdefault, 4496 $netrc->contains($host))) if $CPAN::DEBUG; 4497 if ($netrc->protected) { 4498 my $dialog = join "", map { " $_\n" } @dialog; 4499 my $netrc_explain; 4500 if ($netrc->contains($host)) { 4501 $netrc_explain = "Relying that your .netrc entry for '$host' ". 4502 "manages the login"; 4503 } else { 4504 $netrc_explain = "Relying that your default .netrc entry ". 4505 "manages the login"; 4506 } 4507 $CPAN::Frontend->myprint(qq{ 4508 Trying with external ftp to get 4509 $url 4510 $netrc_explain 4511 Going to send the dialog 4512 $dialog 4513 } 4514 ); 4515 $self->talk_ftp("$ftpbin$verbose $host", 4516 @dialog); 4517 ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size, 4518 $atime,$mtime,$ctime,$blksize,$blocks) = stat($aslocal); 4519 $mtime ||= 0; 4520 if ($mtime > $timestamp) { 4521 $CPAN::Frontend->myprint("GOT $aslocal\n"); 4522 $ThesiteURL = $ro_url; 4523 return $aslocal; 4524 } else { 4525 $CPAN::Frontend->myprint("Hmm... Still failed!\n"); 4526 } 4527 return if $CPAN::Signal; 4528 } else { 4529 $CPAN::Frontend->mywarn(qq{Your $netrcfile is not }. 4530 qq{correctly protected.\n}); 4531 } 4532 } else { 4533 $CPAN::Frontend->mywarn("Your ~/.netrc neither contains $host 4534 nor does it have a default entry\n"); 4535 } 4536 4537 # OK, they don't have a valid ~/.netrc. Use 'ftp -n' 4538 # then and login manually to host, using e-mail as 4539 # password. 4540 $CPAN::Frontend->myprint(qq{Issuing "$ftpbin$verbose -n"\n}); 4541 unshift( 4542 @dialog, 4543 "open $host", 4544 "user anonymous $Config::Config{'cf_email'}" 4545 ); 4546 my $dialog = join "", map { " $_\n" } @dialog; 4547 $CPAN::Frontend->myprint(qq{ 4548 Trying with external ftp to get 4549 $url 4550 Going to send the dialog 4551 $dialog 4552 } 4553 ); 4554 $self->talk_ftp("$ftpbin$verbose -n", @dialog); 4555 ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size, 4556 $atime,$mtime,$ctime,$blksize,$blocks) = stat($aslocal); 4557 $mtime ||= 0; 4558 if ($mtime > $timestamp) { 4559 $CPAN::Frontend->myprint("GOT $aslocal\n"); 4560 $ThesiteURL = $ro_url; 4561 return $aslocal; 4562 } else { 4563 $CPAN::Frontend->myprint("Bad luck... Still failed!\n"); 4564 } 4565 return if $CPAN::Signal; 4566 $CPAN::Frontend->mywarn("Can't access URL $url.\n\n"); 4567 $CPAN::Frontend->mysleep(2); 4568 } # host 4569 } 4570 4571 # package CPAN::FTP; 4572 sub talk_ftp { 4573 my($self,$command,@dialog) = @_; 4574 my $fh = FileHandle->new; 4575 $fh->open("|$command") or die "Couldn't open ftp: $!"; 4576 foreach (@dialog) { $fh->print("$_\n") } 4577 $fh->close; # Wait for process to complete 4578 my $wstatus = $?; 4579 my $estatus = $wstatus >> 8; 4580 $CPAN::Frontend->myprint(qq{ 4581 Subprocess "|$command" 4582 returned status $estatus (wstat $wstatus) 4583 }) if $wstatus; 4584 } 4585 4586 # find2perl needs modularization, too, all the following is stolen 4587 # from there 4588 # CPAN::FTP::ls 4589 sub ls { 4590 my($self,$name) = @_; 4591 my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$sizemm, 4592 $atime,$mtime,$ctime,$blksize,$blocks) = lstat($name); 4593 4594 my($perms,%user,%group); 4595 my $pname = $name; 4596 4597 if ($blocks) { 4598 $blocks = int(($blocks + 1) / 2); 4599 } 4600 else { 4601 $blocks = int(($sizemm + 1023) / 1024); 4602 } 4603 4604 if (-f _) { $perms = '-'; } 4605 elsif (-d _) { $perms = 'd'; } 4606 elsif (-c _) { $perms = 'c'; $sizemm = &sizemm; } 4607 elsif (-b _) { $perms = 'b'; $sizemm = &sizemm; } 4608 elsif (-p _) { $perms = 'p'; } 4609 elsif (-S _) { $perms = 's'; } 4610 else { $perms = 'l'; $pname .= ' -> ' . readlink($_); } 4611 4612 my(@rwx) = ('---','--x','-w-','-wx','r--','r-x','rw-','rwx'); 4613 my(@moname) = qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec); 4614 my $tmpmode = $mode; 4615 my $tmp = $rwx[$tmpmode & 7]; 4616 $tmpmode >>= 3; 4617 $tmp = $rwx[$tmpmode & 7] . $tmp; 4618 $tmpmode >>= 3; 4619 $tmp = $rwx[$tmpmode & 7] . $tmp; 4620 substr($tmp,2,1) =~ tr/-x/Ss/ if -u _; 4621 substr($tmp,5,1) =~ tr/-x/Ss/ if -g _; 4622 substr($tmp,8,1) =~ tr/-x/Tt/ if -k _; 4623 $perms .= $tmp; 4624 4625 my $user = $user{$uid} || $uid; # too lazy to implement lookup 4626 my $group = $group{$gid} || $gid; 4627 4628 my($sec,$min,$hour,$mday,$mon,$year) = localtime($mtime); 4629 my($timeyear); 4630 my($moname) = $moname[$mon]; 4631 if (-M _ > 365.25 / 2) { 4632 $timeyear = $year + 1900; 4633 } 4634 else { 4635 $timeyear = sprintf("%02d:%02d", $hour, $min); 4636 } 4637 4638 sprintf "%5lu %4ld %-10s %2d %-8s %-8s %8s %s %2d %5s %s\n", 4639 $ino, 4640 $blocks, 4641 $perms, 4642 $nlink, 4643 $user, 4644 $group, 4645 $sizemm, 4646 $moname, 4647 $mday, 4648 $timeyear, 4649 $pname; 4650 } 4651 4652 package CPAN::FTP::netrc; 4653 use strict; 4654 4655 # package CPAN::FTP::netrc; 4656 sub new { 4657 my($class) = @_; 4658 my $home = CPAN::HandleConfig::home; 4659 my $file = File::Spec->catfile($home,".netrc"); 4660 4661 my($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size, 4662 $atime,$mtime,$ctime,$blksize,$blocks) 4663 = stat($file); 4664 $mode ||= 0; 4665 my $protected = 0; 4666 4667 my($fh,@machines,$hasdefault); 4668 $hasdefault = 0; 4669 $fh = FileHandle->new or die "Could not create a filehandle"; 4670 4671 if($fh->open($file)) { 4672 $protected = ($mode & 077) == 0; 4673 local($/) = ""; 4674 NETRC: while (<$fh>) { 4675 my(@tokens) = split " ", $_; 4676 TOKEN: while (@tokens) { 4677 my($t) = shift @tokens; 4678 if ($t eq "default") { 4679 $hasdefault++; 4680 last NETRC; 4681 } 4682 last TOKEN if $t eq "macdef"; 4683 if ($t eq "machine") { 4684 push @machines, shift @tokens; 4685 } 4686 } 4687 } 4688 } else { 4689 $file = $hasdefault = $protected = ""; 4690 } 4691 4692 bless { 4693 'mach' => [@machines], 4694 'netrc' => $file, 4695 'hasdefault' => $hasdefault, 4696 'protected' => $protected, 4697 }, $class; 4698 } 4699 4700 # CPAN::FTP::netrc::hasdefault; 4701 sub hasdefault { shift->{'hasdefault'} } 4702 sub netrc { shift->{'netrc'} } 4703 sub protected { shift->{'protected'} } 4704 sub contains { 4705 my($self,$mach) = @_; 4706 for ( @{$self->{'mach'}} ) { 4707 return 1 if $_ eq $mach; 4708 } 4709 return 0; 4710 } 4711 4712 package CPAN::Complete; 4713 use strict; 4714 4715 sub gnu_cpl { 4716 my($text, $line, $start, $end) = @_; 4717 my(@perlret) = cpl($text, $line, $start); 4718 # find longest common match. Can anybody show me how to peruse 4719 # T::R::Gnu to have this done automatically? Seems expensive. 4720 return () unless @perlret; 4721 my($newtext) = $text; 4722 for (my $i = length($text)+1;;$i++) { 4723 last unless length($perlret[0]) && length($perlret[0]) >= $i; 4724 my $try = substr($perlret[0],0,$i); 4725 my @tries = grep {substr($_,0,$i) eq $try} @perlret; 4726 # warn "try[$try]tries[@tries]"; 4727 if (@tries == @perlret) { 4728 $newtext = $try; 4729 } else { 4730 last; 4731 } 4732 } 4733 ($newtext,@perlret); 4734 } 4735 4736 #-> sub CPAN::Complete::cpl ; 4737 sub cpl { 4738 my($word,$line,$pos) = @_; 4739 $word ||= ""; 4740 $line ||= ""; 4741 $pos ||= 0; 4742 CPAN->debug("word [$word] line[$line] pos[$pos]") if $CPAN::DEBUG; 4743 $line =~ s/^\s*//; 4744 if ($line =~ s/^((?:notest|f?force)\s*)//) { 4745 $pos -= length($1); 4746 } 4747 my @return; 4748 if ($pos == 0 || $line =~ /^(?:h(?:elp)?|\?)\s/) { 4749 @return = grep /^\Q$word\E/, @CPAN::Complete::COMMANDS; 4750 } elsif ( $line !~ /^[\!abcdghimorutl]/ ) { 4751 @return = (); 4752 } elsif ($line =~ /^(a|ls)\s/) { 4753 @return = cplx('CPAN::Author',uc($word)); 4754 } elsif ($line =~ /^b\s/) { 4755 CPAN::Shell->local_bundles; 4756 @return = cplx('CPAN::Bundle',$word); 4757 } elsif ($line =~ /^d\s/) { 4758 @return = cplx('CPAN::Distribution',$word); 4759 } elsif ($line =~ m/^( 4760 [mru]|make|clean|dump|get|test|install|readme|look|cvs_import|perldoc|recent 4761 )\s/x ) { 4762 if ($word =~ /^Bundle::/) { 4763 CPAN::Shell->local_bundles; 4764 } 4765 @return = (cplx('CPAN::Module',$word),cplx('CPAN::Bundle',$word)); 4766 } elsif ($line =~ /^i\s/) { 4767 @return = cpl_any($word); 4768 } elsif ($line =~ /^reload\s/) { 4769 @return = cpl_reload($word,$line,$pos); 4770 } elsif ($line =~ /^o\s/) { 4771 @return = cpl_option($word,$line,$pos); 4772 } elsif ($line =~ m/^\S+\s/ ) { 4773 # fallback for future commands and what we have forgotten above 4774 @return = (cplx('CPAN::Module',$word),cplx('CPAN::Bundle',$word)); 4775 } else { 4776 @return = (); 4777 } 4778 return @return; 4779 } 4780 4781 #-> sub CPAN::Complete::cplx ; 4782 sub cplx { 4783 my($class, $word) = @_; 4784 if (CPAN::_sqlite_running) { 4785 $CPAN::SQLite->search($class, "^\Q$word\E"); 4786 } 4787 sort grep /^\Q$word\E/, map { $_->id } $CPAN::META->all_objects($class); 4788 } 4789 4790 #-> sub CPAN::Complete::cpl_any ; 4791 sub cpl_any { 4792 my($word) = shift; 4793 return ( 4794 cplx('CPAN::Author',$word), 4795 cplx('CPAN::Bundle',$word), 4796 cplx('CPAN::Distribution',$word), 4797 cplx('CPAN::Module',$word), 4798 ); 4799 } 4800 4801 #-> sub CPAN::Complete::cpl_reload ; 4802 sub cpl_reload { 4803 my($word,$line,$pos) = @_; 4804 $word ||= ""; 4805 my(@words) = split " ", $line; 4806 CPAN->debug("word[$word] line[$line] pos[$pos]") if $CPAN::DEBUG; 4807 my(@ok) = qw(cpan index); 4808 return @ok if @words == 1; 4809 return grep /^\Q$word\E/, @ok if @words == 2 && $word; 4810 } 4811 4812 #-> sub CPAN::Complete::cpl_option ; 4813 sub cpl_option { 4814 my($word,$line,$pos) = @_; 4815 $word ||= ""; 4816 my(@words) = split " ", $line; 4817 CPAN->debug("word[$word] line[$line] pos[$pos]") if $CPAN::DEBUG; 4818 my(@ok) = qw(conf debug); 4819 return @ok if @words == 1; 4820 return grep /^\Q$word\E/, @ok if @words == 2 && length($word); 4821 if (0) { 4822 } elsif ($words[1] eq 'index') { 4823 return (); 4824 } elsif ($words[1] eq 'conf') { 4825 return CPAN::HandleConfig::cpl(@_); 4826 } elsif ($words[1] eq 'debug') { 4827 return sort grep /^\Q$word\E/i, 4828 sort keys %CPAN::DEBUG, 'all'; 4829 } 4830 } 4831 4832 package CPAN::Index; 4833 use strict; 4834 4835 #-> sub CPAN::Index::force_reload ; 4836 sub force_reload { 4837 my($class) = @_; 4838 $CPAN::Index::LAST_TIME = 0; 4839 $class->reload(1); 4840 } 4841 4842 #-> sub CPAN::Index::reload ; 4843 sub reload { 4844 my($self,$force) = @_; 4845 my $time = time; 4846 4847 # XXX check if a newer one is available. (We currently read it 4848 # from time to time) 4849 for ($CPAN::Config->{index_expire}) { 4850 $_ = 0.001 unless $_ && $_ > 0.001; 4851 } 4852 unless (1 || $CPAN::Have_warned->{readmetadatacache}++) { 4853 # debug here when CPAN doesn't seem to read the Metadata 4854 require Carp; 4855 Carp::cluck("META-PROTOCOL[$CPAN::META->{PROTOCOL}]"); 4856 } 4857 unless ($CPAN::META->{PROTOCOL}) { 4858 $self->read_metadata_cache; 4859 $CPAN::META->{PROTOCOL} ||= "1.0"; 4860 } 4861 if ( $CPAN::META->{PROTOCOL} < PROTOCOL ) { 4862 # warn "Setting last_time to 0"; 4863 $LAST_TIME = 0; # No warning necessary 4864 } 4865 if ($LAST_TIME + $CPAN::Config->{index_expire}*86400 > $time 4866 and ! $force) { 4867 # called too often 4868 # CPAN->debug("LAST_TIME[$LAST_TIME]index_expire[$CPAN::Config->{index_expire}]time[$time]"); 4869 } elsif (0) { 4870 # IFF we are developing, it helps to wipe out the memory 4871 # between reloads, otherwise it is not what a user expects. 4872 undef $CPAN::META; # Neue Gruendlichkeit since v1.52(r1.274) 4873 $CPAN::META = CPAN->new; 4874 } else { 4875 my($debug,$t2); 4876 local $LAST_TIME = $time; 4877 local $CPAN::META->{PROTOCOL} = PROTOCOL; 4878 4879 my $needshort = $^O eq "dos"; 4880 4881 $self->rd_authindex($self 4882 ->reload_x( 4883 "authors/01mailrc.txt.gz", 4884 $needshort ? 4885 File::Spec->catfile('authors', '01mailrc.gz') : 4886 File::Spec->catfile('authors', '01mailrc.txt.gz'), 4887 $force)); 4888 $t2 = time; 4889 $debug = "timing reading 01[".($t2 - $time)."]"; 4890 $time = $t2; 4891 return if $CPAN::Signal; # this is sometimes lengthy 4892 $self->rd_modpacks($self 4893 ->reload_x( 4894 "modules/02packages.details.txt.gz", 4895 $needshort ? 4896 File::Spec->catfile('modules', '02packag.gz') : 4897 File::Spec->catfile('modules', '02packages.details.txt.gz'), 4898 $force)); 4899 $t2 = time; 4900 $debug .= "02[".($t2 - $time)."]"; 4901 $time = $t2; 4902 return if $CPAN::Signal; # this is sometimes lengthy 4903 $self->rd_modlist($self 4904 ->reload_x( 4905 "modules/03modlist.data.gz", 4906 $needshort ? 4907 File::Spec->catfile('modules', '03mlist.gz') : 4908 File::Spec->catfile('modules', '03modlist.data.gz'), 4909 $force)); 4910 $self->write_metadata_cache; 4911 $t2 = time; 4912 $debug .= "03[".($t2 - $time)."]"; 4913 $time = $t2; 4914 CPAN->debug($debug) if $CPAN::DEBUG; 4915 } 4916 if ($CPAN::Config->{build_dir_reuse}) { 4917 $self->reanimate_build_dir; 4918 } 4919 if (CPAN::_sqlite_running) { 4920 $CPAN::SQLite->reload(time => $time, force => $force) 4921 if not $LAST_TIME; 4922 } 4923 $LAST_TIME = $time; 4924 $CPAN::META->{PROTOCOL} = PROTOCOL; 4925 } 4926 4927 #-> sub CPAN::Index::reanimate_build_dir ; 4928 sub reanimate_build_dir { 4929 my($self) = @_; 4930 unless ($CPAN::META->has_inst($CPAN::Config->{yaml_module}||"YAML")) { 4931 return; 4932 } 4933 return if $HAVE_REANIMATED++; 4934 my $d = $CPAN::Config->{build_dir}; 4935 my $dh = DirHandle->new; 4936 opendir $dh, $d or return; # does not exist 4937 my $dirent; 4938 my $i = 0; 4939 my $painted = 0; 4940 my $restored = 0; 4941 $CPAN::Frontend->myprint("Going to read $CPAN::Config->{build_dir}/\n"); 4942 my @candidates = map { $_->[0] } 4943 sort { $b->[1] <=> $a->[1] } 4944 map { [ $_, -M File::Spec->catfile($d,$_) ] } 4945 grep {/\.yml$/} readdir $dh; 4946 DISTRO: for $i (0..$#candidates) { 4947 my $dirent = $candidates[$i]; 4948 my $y = eval {CPAN->_yaml_loadfile(File::Spec->catfile($d,$dirent))}; 4949 if ($@) { 4950 warn "Error while parsing file '$dirent'; error: '$@'"; 4951 next DISTRO; 4952 } 4953 my $c = $y->[0]; 4954 if ($c && CPAN->_perl_fingerprint($c->{perl})) { 4955 my $key = $c->{distribution}{ID}; 4956 for my $k (keys %{$c->{distribution}}) { 4957 if ($c->{distribution}{$k} 4958 && ref $c->{distribution}{$k} 4959 && UNIVERSAL::isa($c->{distribution}{$k},"CPAN::Distrostatus")) { 4960 $c->{distribution}{$k}{COMMANDID} = $i - @candidates; 4961 } 4962 } 4963 4964 #we tried to restore only if element already 4965 #exists; but then we do not work with metadata 4966 #turned off. 4967 my $do 4968 = $CPAN::META->{readwrite}{'CPAN::Distribution'}{$key} 4969 = $c->{distribution}; 4970 for my $skipper (qw( 4971 badtestcnt 4972 configure_requires_later 4973 configure_requires_later_for 4974 force_update 4975 later 4976 later_for 4977 notest 4978 should_report 4979 sponsored_mods 4980 )) { 4981 delete $do->{$skipper}; 4982 } 4983 # $DB::single = 1; 4984 if ($do->{make_test} 4985 && $do->{build_dir} 4986 && !(UNIVERSAL::can($do->{make_test},"failed") ? 4987 $do->{make_test}->failed : 4988 $do->{make_test} =~ /^YES/ 4989 ) 4990 && ( 4991 !$do->{install} 4992 || 4993 $do->{install}->failed 4994 ) 4995 ) { 4996 $CPAN::META->is_tested($do->{build_dir},$do->{make_test}{TIME}); 4997 } 4998 $restored++; 4999 } 5000 $i++; 5001 while (($painted/76) < ($i/@candidates)) { 5002 $CPAN::Frontend->myprint("."); 5003 $painted++; 5004 } 5005 } 5006 $CPAN::Frontend->myprint(sprintf( 5007 "DONE\nFound %s old build%s, restored the state of %s\n", 5008 @candidates ? sprintf("%d",scalar @candidates) : "no", 5009 @candidates==1 ? "" : "s", 5010 $restored || "none", 5011 )); 5012 } 5013 5014 5015 #-> sub CPAN::Index::reload_x ; 5016 sub reload_x { 5017 my($cl,$wanted,$localname,$force) = @_; 5018 $force |= 2; # means we're dealing with an index here 5019 CPAN::HandleConfig->load; # we should guarantee loading wherever 5020 # we rely on Config XXX 5021 $localname ||= $wanted; 5022 my $abs_wanted = File::Spec->catfile($CPAN::Config->{'keep_source_where'}, 5023 $localname); 5024 if ( 5025 -f $abs_wanted && 5026 -M $abs_wanted < $CPAN::Config->{'index_expire'} && 5027 !($force & 1) 5028 ) { 5029 my $s = $CPAN::Config->{'index_expire'} == 1 ? "" : "s"; 5030 $cl->debug(qq{$abs_wanted younger than $CPAN::Config->{'index_expire'} }. 5031 qq{day$s. I\'ll use that.}); 5032 return $abs_wanted; 5033 } else { 5034 $force |= 1; # means we're quite serious about it. 5035 } 5036 return CPAN::FTP->localize($wanted,$abs_wanted,$force); 5037 } 5038 5039 #-> sub CPAN::Index::rd_authindex ; 5040 sub rd_authindex { 5041 my($cl, $index_target) = @_; 5042 return unless defined $index_target; 5043 return if CPAN::_sqlite_running; 5044 my @lines; 5045 $CPAN::Frontend->myprint("Going to read $index_target\n"); 5046 local(*FH); 5047 tie *FH, 'CPAN::Tarzip', $index_target; 5048 local($/) = "\n"; 5049 local($_); 5050 push @lines, split /\012/ while <FH>; 5051 my $i = 0; 5052 my $painted = 0; 5053 foreach (@lines) { 5054 my($userid,$fullname,$email) = 5055 m/alias\s+(\S+)\s+\"([^\"\<]*)\s+\<(.*)\>\"/; 5056 $fullname ||= $email; 5057 if ($userid && $fullname && $email) { 5058 my $userobj = $CPAN::META->instance('CPAN::Author',$userid); 5059 $userobj->set('FULLNAME' => $fullname, 'EMAIL' => $email); 5060 } else { 5061 CPAN->debug(sprintf "line[%s]", $_) if $CPAN::DEBUG; 5062 } 5063 $i++; 5064 while (($painted/76) < ($i/@lines)) { 5065 $CPAN::Frontend->myprint("."); 5066 $painted++; 5067 } 5068 return if $CPAN::Signal; 5069 } 5070 $CPAN::Frontend->myprint("DONE\n"); 5071 } 5072 5073 sub userid { 5074 my($self,$dist) = @_; 5075 $dist = $self->{'id'} unless defined $dist; 5076 my($ret) = $dist =~ m|(?:\w/\w\w/)?([^/]+)/|; 5077 $ret; 5078 } 5079 5080 #-> sub CPAN::Index::rd_modpacks ; 5081 sub rd_modpacks { 5082 my($self, $index_target) = @_; 5083 return unless defined $index_target; 5084 return if CPAN::_sqlite_running; 5085 $CPAN::Frontend->myprint("Going to read $index_target\n"); 5086 my $fh = CPAN::Tarzip->TIEHANDLE($index_target); 5087 local $_; 5088 CPAN->debug(sprintf "start[%d]", time) if $CPAN::DEBUG; 5089 my $slurp = ""; 5090 my $chunk; 5091 while (my $bytes = $fh->READ(\$chunk,8192)) { 5092 $slurp.=$chunk; 5093 } 5094 my @lines = split /\012/, $slurp; 5095 CPAN->debug(sprintf "end[%d]", time) if $CPAN::DEBUG; 5096 undef $fh; 5097 # read header 5098 my($line_count,$last_updated); 5099 while (@lines) { 5100 my $shift = shift(@lines); 5101 last if $shift =~ /^\s*$/; 5102 $shift =~ /^Line-Count:\s+(\d+)/ and $line_count = $1; 5103 $shift =~ /^Last-Updated:\s+(.+)/ and $last_updated = $1; 5104 } 5105 CPAN->debug("line_count[$line_count]last_updated[$last_updated]") if $CPAN::DEBUG; 5106 if (not defined $line_count) { 5107 5108 $CPAN::Frontend->mywarn(qq{Warning: Your $index_target does not contain a Line-Count header. 5109 Please check the validity of the index file by comparing it to more 5110 than one CPAN mirror. I'll continue but problems seem likely to 5111 happen.\a 5112 }); 5113 5114 $CPAN::Frontend->mysleep(5); 5115 } elsif ($line_count != scalar @lines) { 5116 5117 $CPAN::Frontend->mywarn(sprintf qq{Warning: Your %s 5118 contains a Line-Count header of %d but I see %d lines there. Please 5119 check the validity of the index file by comparing it to more than one 5120 CPAN mirror. I'll continue but problems seem likely to happen.\a\n}, 5121 $index_target, $line_count, scalar(@lines)); 5122 5123 } 5124 if (not defined $last_updated) { 5125 5126 $CPAN::Frontend->mywarn(qq{Warning: Your $index_target does not contain a Last-Updated header. 5127 Please check the validity of the index file by comparing it to more 5128 than one CPAN mirror. I'll continue but problems seem likely to 5129 happen.\a 5130 }); 5131 5132 $CPAN::Frontend->mysleep(5); 5133 } else { 5134 5135 $CPAN::Frontend 5136 ->myprint(sprintf qq{ Database was generated on %s\n}, 5137 $last_updated); 5138 $DATE_OF_02 = $last_updated; 5139 5140 my $age = time; 5141 if ($CPAN::META->has_inst('HTTP::Date')) { 5142 require HTTP::Date; 5143 $age -= HTTP::Date::str2time($last_updated); 5144 } else { 5145 $CPAN::Frontend->mywarn(" HTTP::Date not available\n"); 5146 require Time::Local; 5147 my(@d) = $last_updated =~ / (\d+) (\w+) (\d+) (\d+):(\d+):(\d+) /; 5148 $d[1] = index("Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec", $d[1])/4; 5149 $age -= $d[1]>=0 ? Time::Local::timegm(@d[5,4,3,0,1,2]) : 0; 5150 } 5151 $age /= 3600*24; 5152 if ($age > 30) { 5153 5154 $CPAN::Frontend 5155 ->mywarn(sprintf 5156 qq{Warning: This index file is %d days old. 5157 Please check the host you chose as your CPAN mirror for staleness. 5158 I'll continue but problems seem likely to happen.\a\n}, 5159 $age); 5160 5161 } elsif ($age < -1) { 5162 5163 $CPAN::Frontend 5164 ->mywarn(sprintf 5165 qq{Warning: Your system date is %d days behind this index file! 5166 System time: %s 5167 Timestamp index file: %s 5168 Please fix your system time, problems with the make command expected.\n}, 5169 -$age, 5170 scalar gmtime, 5171 $DATE_OF_02, 5172 ); 5173 5174 } 5175 } 5176 5177 5178 # A necessity since we have metadata_cache: delete what isn't 5179 # there anymore 5180 my $secondtime = $CPAN::META->exists("CPAN::Module","CPAN"); 5181 CPAN->debug("secondtime[$secondtime]") if $CPAN::DEBUG; 5182 my(%exists); 5183 my $i = 0; 5184 my $painted = 0; 5185 foreach (@lines) { 5186 # before 1.56 we split into 3 and discarded the rest. From 5187 # 1.57 we assign remaining text to $comment thus allowing to 5188 # influence isa_perl 5189 my($mod,$version,$dist,$comment) = split " ", $_, 4; 5190 my($bundle,$id,$userid); 5191 5192 if ($mod eq 'CPAN' && 5193 ! ( 5194 CPAN::Queue->exists('Bundle::CPAN') || 5195 CPAN::Queue->exists('CPAN') 5196 ) 5197 ) { 5198 local($^W)= 0; 5199 if ($version > $CPAN::VERSION) { 5200 $CPAN::Frontend->mywarn(qq{ 5201 New CPAN.pm version (v$version) available. 5202 [Currently running version is v$CPAN::VERSION] 5203 You might want to try 5204 install CPAN 5205 reload cpan 5206 to both upgrade CPAN.pm and run the new version without leaving 5207 the current session. 5208 5209 }); #}); 5210 $CPAN::Frontend->mysleep(2); 5211 $CPAN::Frontend->myprint(qq{\n}); 5212 } 5213 last if $CPAN::Signal; 5214 } elsif ($mod =~ /^Bundle::(.*)/) { 5215 $bundle = $1; 5216 } 5217 5218 if ($bundle) { 5219 $id = $CPAN::META->instance('CPAN::Bundle',$mod); 5220 # Let's make it a module too, because bundles have so much 5221 # in common with modules. 5222 5223 # Changed in 1.57_63: seems like memory bloat now without 5224 # any value, so commented out 5225 5226 # $CPAN::META->instance('CPAN::Module',$mod); 5227 5228 } else { 5229 5230 # instantiate a module object 5231 $id = $CPAN::META->instance('CPAN::Module',$mod); 5232 5233 } 5234 5235 # Although CPAN prohibits same name with different version the 5236 # indexer may have changed the version for the same distro 5237 # since the last time ("Force Reindexing" feature) 5238 if ($id->cpan_file ne $dist 5239 || 5240 $id->cpan_version ne $version 5241 ) { 5242 $userid = $id->userid || $self->userid($dist); 5243 $id->set( 5244 'CPAN_USERID' => $userid, 5245 'CPAN_VERSION' => $version, 5246 'CPAN_FILE' => $dist, 5247 ); 5248 } 5249 5250 # instantiate a distribution object 5251 if ($CPAN::META->exists('CPAN::Distribution',$dist)) { 5252 # we do not need CONTAINSMODS unless we do something with 5253 # this dist, so we better produce it on demand. 5254 5255 ## my $obj = $CPAN::META->instance( 5256 ## 'CPAN::Distribution' => $dist 5257 ## ); 5258 ## $obj->{CONTAINSMODS}{$mod} = undef; # experimental 5259 } else { 5260 $CPAN::META->instance( 5261 'CPAN::Distribution' => $dist 5262 )->set( 5263 'CPAN_USERID' => $userid, 5264 'CPAN_COMMENT' => $comment, 5265 ); 5266 } 5267 if ($secondtime) { 5268 for my $name ($mod,$dist) { 5269 # $self->debug("exists name[$name]") if $CPAN::DEBUG; 5270 $exists{$name} = undef; 5271 } 5272 } 5273 $i++; 5274 while (($painted/76) < ($i/@lines)) { 5275 $CPAN::Frontend->myprint("."); 5276 $painted++; 5277 } 5278 return if $CPAN::Signal; 5279 } 5280 $CPAN::Frontend->myprint("DONE\n"); 5281 if ($secondtime) { 5282 for my $class (qw(CPAN::Module CPAN::Bundle CPAN::Distribution)) { 5283 for my $o ($CPAN::META->all_objects($class)) { 5284 next if exists $exists{$o->{ID}}; 5285 $CPAN::META->delete($class,$o->{ID}); 5286 # CPAN->debug("deleting ID[$o->{ID}] in class[$class]") 5287 # if $CPAN::DEBUG; 5288 } 5289 } 5290 } 5291 } 5292 5293 #-> sub CPAN::Index::rd_modlist ; 5294 sub rd_modlist { 5295 my($cl,$index_target) = @_; 5296 return unless defined $index_target; 5297 return if CPAN::_sqlite_running; 5298 $CPAN::Frontend->myprint("Going to read $index_target\n"); 5299 my $fh = CPAN::Tarzip->TIEHANDLE($index_target); 5300 local $_; 5301 my $slurp = ""; 5302 my $chunk; 5303 while (my $bytes = $fh->READ(\$chunk,8192)) { 5304 $slurp.=$chunk; 5305 } 5306 my @eval2 = split /\012/, $slurp; 5307 5308 while (@eval2) { 5309 my $shift = shift(@eval2); 5310 if ($shift =~ /^Date:\s+(.*)/) { 5311 if ($DATE_OF_03 eq $1) { 5312 $CPAN::Frontend->myprint("Unchanged.\n"); 5313 return; 5314 } 5315 ($DATE_OF_03) = $1; 5316 } 5317 last if $shift =~ /^\s*$/; 5318 } 5319 push @eval2, q{CPAN::Modulelist->data;}; 5320 local($^W) = 0; 5321 my($comp) = Safe->new("CPAN::Safe1"); 5322 my($eval2) = join("\n", @eval2); 5323 CPAN->debug(sprintf "length of eval2[%d]", length $eval2) if $CPAN::DEBUG; 5324 my $ret = $comp->reval($eval2); 5325 Carp::confess($@) if $@; 5326 return if $CPAN::Signal; 5327 my $i = 0; 5328 my $until = keys(%$ret); 5329 my $painted = 0; 5330 CPAN->debug(sprintf "until[%d]", $until) if $CPAN::DEBUG; 5331 for (keys %$ret) { 5332 my $obj = $CPAN::META->instance("CPAN::Module",$_); 5333 delete $ret->{$_}{modid}; # not needed here, maybe elsewhere 5334 $obj->set(%{$ret->{$_}}); 5335 $i++; 5336 while (($painted/76) < ($i/$until)) { 5337 $CPAN::Frontend->myprint("."); 5338 $painted++; 5339 } 5340 return if $CPAN::Signal; 5341 } 5342 $CPAN::Frontend->myprint("DONE\n"); 5343 } 5344 5345 #-> sub CPAN::Index::write_metadata_cache ; 5346 sub write_metadata_cache { 5347 my($self) = @_; 5348 return unless $CPAN::Config->{'cache_metadata'}; 5349 return if CPAN::_sqlite_running; 5350 return unless $CPAN::META->has_usable("Storable"); 5351 my $cache; 5352 foreach my $k (qw(CPAN::Bundle CPAN::Author CPAN::Module 5353 CPAN::Distribution)) { 5354 $cache->{$k} = $CPAN::META->{readonly}{$k}; # unsafe meta access, ok 5355 } 5356 my $metadata_file = File::Spec->catfile($CPAN::Config->{cpan_home},"Metadata"); 5357 $cache->{last_time} = $LAST_TIME; 5358 $cache->{DATE_OF_02} = $DATE_OF_02; 5359 $cache->{PROTOCOL} = PROTOCOL; 5360 $CPAN::Frontend->myprint("Going to write $metadata_file\n"); 5361 eval { Storable::nstore($cache, $metadata_file) }; 5362 $CPAN::Frontend->mywarn($@) if $@; # ?? missing "\n" after $@ in mywarn ?? 5363 } 5364 5365 #-> sub CPAN::Index::read_metadata_cache ; 5366 sub read_metadata_cache { 5367 my($self) = @_; 5368 return unless $CPAN::Config->{'cache_metadata'}; 5369 return if CPAN::_sqlite_running; 5370 return unless $CPAN::META->has_usable("Storable"); 5371 my $metadata_file = File::Spec->catfile($CPAN::Config->{cpan_home},"Metadata"); 5372 return unless -r $metadata_file and -f $metadata_file; 5373 $CPAN::Frontend->myprint("Going to read $metadata_file\n"); 5374 my $cache; 5375 eval { $cache = Storable::retrieve($metadata_file) }; 5376 $CPAN::Frontend->mywarn($@) if $@; # ?? missing "\n" after $@ in mywarn ?? 5377 if (!$cache || !UNIVERSAL::isa($cache, 'HASH')) { 5378 $LAST_TIME = 0; 5379 return; 5380 } 5381 if (exists $cache->{PROTOCOL}) { 5382 if (PROTOCOL > $cache->{PROTOCOL}) { 5383 $CPAN::Frontend->mywarn(sprintf("Ignoring Metadata cache written ". 5384 "with protocol v%s, requiring v%s\n", 5385 $cache->{PROTOCOL}, 5386 PROTOCOL) 5387 ); 5388 return; 5389 } 5390 } else { 5391 $CPAN::Frontend->mywarn("Ignoring Metadata cache written ". 5392 "with protocol v1.0\n"); 5393 return; 5394 } 5395 my $clcnt = 0; 5396 my $idcnt = 0; 5397 while(my($class,$v) = each %$cache) { 5398 next unless $class =~ /^CPAN::/; 5399 $CPAN::META->{readonly}{$class} = $v; # unsafe meta access, ok 5400 while (my($id,$ro) = each %$v) { 5401 $CPAN::META->{readwrite}{$class}{$id} ||= 5402 $class->new(ID=>$id, RO=>$ro); 5403 $idcnt++; 5404 } 5405 $clcnt++; 5406 } 5407 unless ($clcnt) { # sanity check 5408 $CPAN::Frontend->myprint("Warning: Found no data in $metadata_file\n"); 5409 return; 5410 } 5411 if ($idcnt < 1000) { 5412 $CPAN::Frontend->myprint("Warning: Found only $idcnt objects ". 5413 "in $metadata_file\n"); 5414 return; 5415 } 5416 $CPAN::META->{PROTOCOL} ||= 5417 $cache->{PROTOCOL}; # reading does not up or downgrade, but it 5418 # does initialize to some protocol 5419 $LAST_TIME = $cache->{last_time}; 5420 $DATE_OF_02 = $cache->{DATE_OF_02}; 5421 $CPAN::Frontend->myprint(" Database was generated on $DATE_OF_02\n") 5422 if defined $DATE_OF_02; # An old cache may not contain DATE_OF_02 5423 return; 5424 } 5425 5426 package CPAN::InfoObj; 5427 use strict; 5428 5429 sub ro { 5430 my $self = shift; 5431 exists $self->{RO} and return $self->{RO}; 5432 } 5433 5434 #-> sub CPAN::InfoObj::cpan_userid 5435 sub cpan_userid { 5436 my $self = shift; 5437 my $ro = $self->ro; 5438 if ($ro) { 5439 return $ro->{CPAN_USERID} || "N/A"; 5440 } else { 5441 $self->debug("ID[$self->{ID}]"); 5442 # N/A for bundles found locally 5443 return "N/A"; 5444 } 5445 } 5446 5447 sub id { shift->{ID}; } 5448 5449 #-> sub CPAN::InfoObj::new ; 5450 sub new { 5451 my $this = bless {}, shift; 5452 %$this = @_; 5453 $this 5454 } 5455 5456 # The set method may only be used by code that reads index data or 5457 # otherwise "objective" data from the outside world. All session 5458 # related material may do anything else with instance variables but 5459 # must not touch the hash under the RO attribute. The reason is that 5460 # the RO hash gets written to Metadata file and is thus persistent. 5461 5462 #-> sub CPAN::InfoObj::safe_chdir ; 5463 sub safe_chdir { 5464 my($self,$todir) = @_; 5465 # we die if we cannot chdir and we are debuggable 5466 Carp::confess("safe_chdir called without todir argument") 5467 unless defined $todir and length $todir; 5468 if (chdir $todir) { 5469 $self->debug(sprintf "changed directory to %s", CPAN::anycwd()) 5470 if $CPAN::DEBUG; 5471 } else { 5472 if (-e $todir) { 5473 unless (-x $todir) { 5474 unless (chmod 0755, $todir) { 5475 my $cwd = CPAN::anycwd(); 5476 $CPAN::Frontend->mywarn("I have neither the -x permission nor the ". 5477 "permission to change the permission; cannot ". 5478 "chdir to '$todir'\n"); 5479 $CPAN::Frontend->mysleep(5); 5480 $CPAN::Frontend->mydie(qq{Could not chdir from cwd[$cwd] }. 5481 qq{to todir[$todir]: $!}); 5482 } 5483 } 5484 } else { 5485 $CPAN::Frontend->mydie("Directory '$todir' has gone. Cannot continue.\n"); 5486 } 5487 if (chdir $todir) { 5488 $self->debug(sprintf "changed directory to %s", CPAN::anycwd()) 5489 if $CPAN::DEBUG; 5490 } else { 5491 my $cwd = CPAN::anycwd(); 5492 $CPAN::Frontend->mydie(qq{Could not chdir from cwd[$cwd] }. 5493 qq{to todir[$todir] (a chmod has been issued): $!}); 5494 } 5495 } 5496 } 5497 5498 #-> sub CPAN::InfoObj::set ; 5499 sub set { 5500 my($self,%att) = @_; 5501 my $class = ref $self; 5502 5503 # This must be ||=, not ||, because only if we write an empty 5504 # reference, only then the set method will write into the readonly 5505 # area. But for Distributions that spring into existence, maybe 5506 # because of a typo, we do not like it that they are written into 5507 # the readonly area and made permanent (at least for a while) and 5508 # that is why we do not "allow" other places to call ->set. 5509 unless ($self->id) { 5510 CPAN->debug("Bug? Empty ID, rejecting"); 5511 return; 5512 } 5513 my $ro = $self->{RO} = 5514 $CPAN::META->{readonly}{$class}{$self->id} ||= {}; 5515 5516 while (my($k,$v) = each %att) { 5517 $ro->{$k} = $v; 5518 } 5519 } 5520 5521 #-> sub CPAN::InfoObj::as_glimpse ; 5522 sub as_glimpse { 5523 my($self) = @_; 5524 my(@m); 5525 my $class = ref($self); 5526 $class =~ s/^CPAN:://; 5527 my $id = $self->can("pretty_id") ? $self->pretty_id : $self->{ID}; 5528 push @m, sprintf "%-15s %s\n", $class, $id; 5529 join "", @m; 5530 } 5531 5532 #-> sub CPAN::InfoObj::as_string ; 5533 sub as_string { 5534 my($self) = @_; 5535 my(@m); 5536 my $class = ref($self); 5537 $class =~ s/^CPAN:://; 5538 push @m, $class, " id = $self->{ID}\n"; 5539 my $ro; 5540 unless ($ro = $self->ro) { 5541 if (substr($self->{ID},-1,1) eq ".") { # directory 5542 $ro = +{}; 5543 } else { 5544 $CPAN::Frontend->mywarn("Unknown object $self->{ID}\n"); 5545 $CPAN::Frontend->mysleep(5); 5546 return; 5547 } 5548 } 5549 for (sort keys %$ro) { 5550 # next if m/^(ID|RO)$/; 5551 my $extra = ""; 5552 if ($_ eq "CPAN_USERID") { 5553 $extra .= " ("; 5554 $extra .= $self->fullname; 5555 my $email; # old perls! 5556 if ($email = $CPAN::META->instance("CPAN::Author", 5557 $self->cpan_userid 5558 )->email) { 5559 $extra .= " <$email>"; 5560 } else { 5561 $extra .= " <no email>"; 5562 } 5563 $extra .= ")"; 5564 } elsif ($_ eq "FULLNAME") { # potential UTF-8 conversion 5565 push @m, sprintf " %-12s %s\n", $_, $self->fullname; 5566 next; 5567 } 5568 next unless defined $ro->{$_}; 5569 push @m, sprintf " %-12s %s%s\n", $_, $ro->{$_}, $extra; 5570 } 5571 KEY: for (sort keys %$self) { 5572 next if m/^(ID|RO)$/; 5573 unless (defined $self->{$_}) { 5574 delete $self->{$_}; 5575 next KEY; 5576 } 5577 if (ref($self->{$_}) eq "ARRAY") { 5578 push @m, sprintf " %-12s %s\n", $_, "@{$self->{$_}}"; 5579 } elsif (ref($self->{$_}) eq "HASH") { 5580 my $value; 5581 if (/^CONTAINSMODS$/) { 5582 $value = join(" ",sort keys %{$self->{$_}}); 5583 } elsif (/^prereq_pm$/) { 5584 my @value; 5585 my $v = $self->{$_}; 5586 for my $x (sort keys %$v) { 5587 my @svalue; 5588 for my $y (sort keys %{$v->{$x}}) { 5589 push @svalue, "$y=>$v->{$x}{$y}"; 5590 } 5591 push @value, "$x\:" . join ",", @svalue if @svalue; 5592 } 5593 $value = join ";", @value; 5594 } else { 5595 $value = $self->{$_}; 5596 } 5597 push @m, sprintf( 5598 " %-12s %s\n", 5599 $_, 5600 $value, 5601 ); 5602 } else { 5603 push @m, sprintf " %-12s %s\n", $_, $self->{$_}; 5604 } 5605 } 5606 join "", @m, "\n"; 5607 } 5608 5609 #-> sub CPAN::InfoObj::fullname ; 5610 sub fullname { 5611 my($self) = @_; 5612 $CPAN::META->instance("CPAN::Author",$self->cpan_userid)->fullname; 5613 } 5614 5615 #-> sub CPAN::InfoObj::dump ; 5616 sub dump { 5617 my($self, $what) = @_; 5618 unless ($CPAN::META->has_inst("Data::Dumper")) { 5619 $CPAN::Frontend->mydie("dump command requires Data::Dumper installed"); 5620 } 5621 local $Data::Dumper::Sortkeys; 5622 $Data::Dumper::Sortkeys = 1; 5623 my $out = Data::Dumper::Dumper($what ? eval $what : $self); 5624 if (length $out > 100000) { 5625 my $fh_pager = FileHandle->new; 5626 local($SIG{PIPE}) = "IGNORE"; 5627 my $pager = $CPAN::Config->{'pager'} || "cat"; 5628 $fh_pager->open("|$pager") 5629 or die "Could not open pager $pager\: $!"; 5630 $fh_pager->print($out); 5631 close $fh_pager; 5632 } else { 5633 $CPAN::Frontend->myprint($out); 5634 } 5635 } 5636 5637 package CPAN::Author; 5638 use strict; 5639 5640 #-> sub CPAN::Author::force 5641 sub force { 5642 my $self = shift; 5643 $self->{force}++; 5644 } 5645 5646 #-> sub CPAN::Author::force 5647 sub unforce { 5648 my $self = shift; 5649 delete $self->{force}; 5650 } 5651 5652 #-> sub CPAN::Author::id 5653 sub id { 5654 my $self = shift; 5655 my $id = $self->{ID}; 5656 $CPAN::Frontend->mydie("Illegal author id[$id]") unless $id =~ /^[A-Z]/; 5657 $id; 5658 } 5659 5660 #-> sub CPAN::Author::as_glimpse ; 5661 sub as_glimpse { 5662 my($self) = @_; 5663 my(@m); 5664 my $class = ref($self); 5665 $class =~ s/^CPAN:://; 5666 push @m, sprintf(qq{%-15s %s ("%s" <%s>)\n}, 5667 $class, 5668 $self->{ID}, 5669 $self->fullname, 5670 $self->email); 5671 join "", @m; 5672 } 5673 5674 #-> sub CPAN::Author::fullname ; 5675 sub fullname { 5676 shift->ro->{FULLNAME}; 5677 } 5678 *name = \&fullname; 5679 5680 #-> sub CPAN::Author::email ; 5681 sub email { shift->ro->{EMAIL}; } 5682 5683 #-> sub CPAN::Author::ls ; 5684 sub ls { 5685 my $self = shift; 5686 my $glob = shift || ""; 5687 my $silent = shift || 0; 5688 my $id = $self->id; 5689 5690 # adapted from CPAN::Distribution::verifyCHECKSUM ; 5691 my(@csf); # chksumfile 5692 @csf = $self->id =~ /(.)(.)(.*)/; 5693 $csf[1] = join "", @csf[0,1]; 5694 $csf[2] = join "", @csf[1,2]; # ("A","AN","ANDK") 5695 my(@dl); 5696 @dl = $self->dir_listing([$csf[0],"CHECKSUMS"], 0, 1); 5697 unless (grep {$_->[2] eq $csf[1]} @dl) { 5698 $CPAN::Frontend->myprint("Directory $csf[1]/ does not exist\n") unless $silent ; 5699 return; 5700 } 5701 @dl = $self->dir_listing([@csf[0,1],"CHECKSUMS"], 0, 1); 5702 unless (grep {$_->[2] eq $csf[2]} @dl) { 5703 $CPAN::Frontend->myprint("Directory $id/ does not exist\n") unless $silent; 5704 return; 5705 } 5706 @dl = $self->dir_listing([@csf,"CHECKSUMS"], 1, 1); 5707 if ($glob) { 5708 if ($CPAN::META->has_inst("Text::Glob")) { 5709 my $rglob = Text::Glob::glob_to_regex($glob); 5710 @dl = grep { $_->[2] =~ /$rglob/ } @dl; 5711 } else { 5712 $CPAN::Frontend->mydie("Text::Glob not installed, cannot proceed"); 5713 } 5714 } 5715 unless ($silent >= 2) { 5716 $CPAN::Frontend->myprint(join "", map { 5717 sprintf("%8d %10s %s/%s\n", $_->[0], $_->[1], $id, $_->[2]) 5718 } sort { $a->[2] cmp $b->[2] } @dl); 5719 } 5720 @dl; 5721 } 5722 5723 # returns an array of arrays, the latter contain (size,mtime,filename) 5724 #-> sub CPAN::Author::dir_listing ; 5725 sub dir_listing { 5726 my $self = shift; 5727 my $chksumfile = shift; 5728 my $recursive = shift; 5729 my $may_ftp = shift; 5730 5731 my $lc_want = 5732 File::Spec->catfile($CPAN::Config->{keep_source_where}, 5733 "authors", "id", @$chksumfile); 5734 5735 my $fh; 5736 5737 # Purge and refetch old (pre-PGP) CHECKSUMS; they are a security 5738 # hazard. (Without GPG installed they are not that much better, 5739 # though.) 5740 $fh = FileHandle->new; 5741 if (open($fh, $lc_want)) { 5742 my $line = <$fh>; close $fh; 5743 unlink($lc_want) unless $line =~ /PGP/; 5744 } 5745 5746 local($") = "/"; 5747 # connect "force" argument with "index_expire". 5748 my $force = $self->{force}; 5749 if (my @stat = stat $lc_want) { 5750 $force ||= $stat[9] + $CPAN::Config->{index_expire}*86400 <= time; 5751 } 5752 my $lc_file; 5753 if ($may_ftp) { 5754 $lc_file = CPAN::FTP->localize( 5755 "authors/id/@$chksumfile", 5756 $lc_want, 5757 $force, 5758 ); 5759 unless ($lc_file) { 5760 $CPAN::Frontend->myprint("Trying $lc_want.gz\n"); 5761 $chksumfile->[-1] .= ".gz"; 5762 $lc_file = CPAN::FTP->localize("authors/id/@$chksumfile", 5763 "$lc_want.gz",1); 5764 if ($lc_file) { 5765 $lc_file =~ s{\.gz(?!\n)\Z}{}; #}; 5766 eval{CPAN::Tarzip->new("$lc_file.gz")->gunzip($lc_file)}; 5767 } else { 5768 return; 5769 } 5770 } 5771 } else { 5772 $lc_file = $lc_want; 5773 # we *could* second-guess and if the user has a file: URL, 5774 # then we could look there. But on the other hand, if they do 5775 # have a file: URL, wy did they choose to set 5776 # $CPAN::Config->{show_upload_date} to false? 5777 } 5778 5779 # adapted from CPAN::Distribution::CHECKSUM_check_file ; 5780 $fh = FileHandle->new; 5781 my($cksum); 5782 if (open $fh, $lc_file) { 5783 local($/); 5784 my $eval = <$fh>; 5785 $eval =~ s/\015?\012/\n/g; 5786 close $fh; 5787 my($comp) = Safe->new(); 5788 $cksum = $comp->reval($eval); 5789 if ($@) { 5790 rename $lc_file, "$lc_file.bad"; 5791 Carp::confess($@) if $@; 5792 } 5793 } elsif ($may_ftp) { 5794 Carp::carp "Could not open '$lc_file' for reading."; 5795 } else { 5796 # Maybe should warn: "You may want to set show_upload_date to a true value" 5797 return; 5798 } 5799 my(@result,$f); 5800 for $f (sort keys %$cksum) { 5801 if (exists $cksum->{$f}{isdir}) { 5802 if ($recursive) { 5803 my(@dir) = @$chksumfile; 5804 pop @dir; 5805 push @dir, $f, "CHECKSUMS"; 5806 push @result, map { 5807 [$_->[0], $_->[1], "$f/$_->[2]"] 5808 } $self->dir_listing(\@dir,1,$may_ftp); 5809 } else { 5810 push @result, [ 0, "-", $f ]; 5811 } 5812 } else { 5813 push @result, [ 5814 ($cksum->{$f}{"size"}||0), 5815 $cksum->{$f}{"mtime"}||"---", 5816 $f 5817 ]; 5818 } 5819 } 5820 @result; 5821 } 5822 5823 #-> sub CPAN::Author::reports 5824 sub reports { 5825 $CPAN::Frontend->mywarn("reports on authors not implemented. 5826 Please file a bugreport if you need this.\n"); 5827 } 5828 5829 package CPAN::Distribution; 5830 use strict; 5831 5832 # Accessors 5833 sub cpan_comment { 5834 my $self = shift; 5835 my $ro = $self->ro or return; 5836 $ro->{CPAN_COMMENT} 5837 } 5838 5839 #-> CPAN::Distribution::undelay 5840 sub undelay { 5841 my $self = shift; 5842 for my $delayer ( 5843 "configure_requires_later", 5844 "configure_requires_later_for", 5845 "later", 5846 "later_for", 5847 ) { 5848 delete $self->{$delayer}; 5849 } 5850 } 5851 5852 #-> CPAN::Distribution::is_dot_dist 5853 sub is_dot_dist { 5854 my($self) = @_; 5855 return substr($self->id,-1,1) eq "."; 5856 } 5857 5858 # add the A/AN/ stuff 5859 #-> CPAN::Distribution::normalize 5860 sub normalize { 5861 my($self,$s) = @_; 5862 $s = $self->id unless defined $s; 5863 if (substr($s,-1,1) eq ".") { 5864 # using a global because we are sometimes called as static method 5865 if (!$CPAN::META->{LOCK} 5866 && !$CPAN::Have_warned->{"$s is unlocked"}++ 5867 ) { 5868 $CPAN::Frontend->mywarn("You are visiting the local directory 5869 '$s' 5870 without lock, take care that concurrent processes do not do likewise.\n"); 5871 $CPAN::Frontend->mysleep(1); 5872 } 5873 if ($s eq ".") { 5874 $s = "$CPAN::iCwd/."; 5875 } elsif (File::Spec->file_name_is_absolute($s)) { 5876 } elsif (File::Spec->can("rel2abs")) { 5877 $s = File::Spec->rel2abs($s); 5878 } else { 5879 $CPAN::Frontend->mydie("Your File::Spec is too old, please upgrade File::Spec"); 5880 } 5881 CPAN->debug("s[$s]") if $CPAN::DEBUG; 5882 unless ($CPAN::META->exists("CPAN::Distribution", $s)) { 5883 for ($CPAN::META->instance("CPAN::Distribution", $s)) { 5884 $_->{build_dir} = $s; 5885 $_->{archived} = "local_directory"; 5886 $_->{unwrapped} = CPAN::Distrostatus->new("YES -- local_directory"); 5887 } 5888 } 5889 } elsif ( 5890 $s =~ tr|/|| == 1 5891 or 5892 $s !~ m|[A-Z]/[A-Z-]{2}/[A-Z-]{2,}/| 5893 ) { 5894 return $s if $s =~ m:^N/A|^Contact Author: ; 5895 $s =~ s|^(.)(.)([^/]*/)(.+)$|$1/$1$2/$1$2$3$4| or 5896 $CPAN::Frontend->mywarn("Strange distribution name [$s]\n"); 5897 CPAN->debug("s[$s]") if $CPAN::DEBUG; 5898 } 5899 $s; 5900 } 5901 5902 #-> sub CPAN::Distribution::author ; 5903 sub author { 5904 my($self) = @_; 5905 my($authorid); 5906 if (substr($self->id,-1,1) eq ".") { 5907 $authorid = "LOCAL"; 5908 } else { 5909 ($authorid) = $self->pretty_id =~ /^([\w\-]+)/; 5910 } 5911 CPAN::Shell->expand("Author",$authorid); 5912 } 5913 5914 # tries to get the yaml from CPAN instead of the distro itself: 5915 # EXPERIMENTAL, UNDOCUMENTED AND UNTESTED, for Tels 5916 sub fast_yaml { 5917 my($self) = @_; 5918 my $meta = $self->pretty_id; 5919 $meta =~ s/\.(tar.gz|tgz|zip|tar.bz2)/.meta/; 5920 my(@ls) = CPAN::Shell->globls($meta); 5921 my $norm = $self->normalize($meta); 5922 5923 my($local_file); 5924 my($local_wanted) = 5925 File::Spec->catfile( 5926 $CPAN::Config->{keep_source_where}, 5927 "authors", 5928 "id", 5929 split(/\//,$norm) 5930 ); 5931 $self->debug("Doing localize") if $CPAN::DEBUG; 5932 unless ($local_file = 5933 CPAN::FTP->localize("authors/id/$norm", 5934 $local_wanted)) { 5935 $CPAN::Frontend->mydie("Giving up on downloading yaml file '$local_wanted'\n"); 5936 } 5937 my $yaml = CPAN->_yaml_loadfile($local_file)->[0]; 5938 } 5939 5940 #-> sub CPAN::Distribution::cpan_userid 5941 sub cpan_userid { 5942 my $self = shift; 5943 if ($self->{ID} =~ m{[A-Z]/[A-Z\-]{2}/([A-Z\-]+)/}) { 5944 return $1; 5945 } 5946 return $self->SUPER::cpan_userid; 5947 } 5948 5949 #-> sub CPAN::Distribution::pretty_id 5950 sub pretty_id { 5951 my $self = shift; 5952 my $id = $self->id; 5953 return $id unless $id =~ m|^./../|; 5954 substr($id,5); 5955 } 5956 5957 #-> sub CPAN::Distribution::base_id 5958 sub base_id { 5959 my $self = shift; 5960 my $id = $self->pretty_id(); 5961 my $base_id = File::Basename::basename($id); 5962 $base_id =~ s{\.(?:tar\.(bz2|gz|Z)|t(?:gz|bz)|zip)$}{}i; 5963 return $base_id; 5964 } 5965 5966 # mark as dirty/clean for the sake of recursion detection. $color=1 5967 # means "in use", $color=0 means "not in use anymore". $color=2 means 5968 # we have determined prereqs now and thus insist on passing this 5969 # through (at least) once again. 5970 5971 #-> sub CPAN::Distribution::color_cmd_tmps ; 5972 sub color_cmd_tmps { 5973 my($self) = shift; 5974 my($depth) = shift || 0; 5975 my($color) = shift || 0; 5976 my($ancestors) = shift || []; 5977 # a distribution needs to recurse into its prereq_pms 5978 5979 return if exists $self->{incommandcolor} 5980 && $color==1 5981 && $self->{incommandcolor}==$color; 5982 if ($depth>=$CPAN::MAX_RECURSION) { 5983 die(CPAN::Exception::RecursiveDependency->new($ancestors)); 5984 } 5985 # warn "color_cmd_tmps $depth $color " . $self->id; # sleep 1; 5986 my $prereq_pm = $self->prereq_pm; 5987 if (defined $prereq_pm) { 5988 PREREQ: for my $pre (keys %{$prereq_pm->{requires}||{}}, 5989 keys %{$prereq_pm->{build_requires}||{}}) { 5990 next PREREQ if $pre eq "perl"; 5991 my $premo; 5992 unless ($premo = CPAN::Shell->expand("Module",$pre)) { 5993 $CPAN::Frontend->mywarn("prerequisite module[$pre] not known\n"); 5994 $CPAN::Frontend->mysleep(2); 5995 next PREREQ; 5996 } 5997 $premo->color_cmd_tmps($depth+1,$color,[@$ancestors, $self->id]); 5998 } 5999 } 6000 if ($color==0) { 6001 delete $self->{sponsored_mods}; 6002 6003 # as we are at the end of a command, we'll give up this 6004 # reminder of a broken test. Other commands may test this guy 6005 # again. Maybe 'badtestcnt' should be renamed to 6006 # 'make_test_failed_within_command'? 6007 delete $self->{badtestcnt}; 6008 } 6009 $self->{incommandcolor} = $color; 6010 } 6011 6012 #-> sub CPAN::Distribution::as_string ; 6013 sub as_string { 6014 my $self = shift; 6015 $self->containsmods; 6016 $self->upload_date; 6017 $self->SUPER::as_string(@_); 6018 } 6019 6020 #-> sub CPAN::Distribution::containsmods ; 6021 sub containsmods { 6022 my $self = shift; 6023 return keys %{$self->{CONTAINSMODS}} if exists $self->{CONTAINSMODS}; 6024 my $dist_id = $self->{ID}; 6025 for my $mod ($CPAN::META->all_objects("CPAN::Module")) { 6026 my $mod_file = $mod->cpan_file or next; 6027 my $mod_id = $mod->{ID} or next; 6028 # warn "mod_file[$mod_file] dist_id[$dist_id] mod_id[$mod_id]"; 6029 # sleep 1; 6030 if ($CPAN::Signal) { 6031 delete $self->{CONTAINSMODS}; 6032 return; 6033 } 6034 $self->{CONTAINSMODS}{$mod_id} = undef if $mod_file eq $dist_id; 6035 } 6036 keys %{$self->{CONTAINSMODS}||={}}; 6037 } 6038 6039 #-> sub CPAN::Distribution::upload_date ; 6040 sub upload_date { 6041 my $self = shift; 6042 return $self->{UPLOAD_DATE} if exists $self->{UPLOAD_DATE}; 6043 my(@local_wanted) = split(/\//,$self->id); 6044 my $filename = pop @local_wanted; 6045 push @local_wanted, "CHECKSUMS"; 6046 my $author = CPAN::Shell->expand("Author",$self->cpan_userid); 6047 return unless $author; 6048 my @dl = $author->dir_listing(\@local_wanted,0,$CPAN::Config->{show_upload_date}); 6049 return unless @dl; 6050 my($dirent) = grep { $_->[2] eq $filename } @dl; 6051 # warn sprintf "dirent[%s]id[%s]", $dirent, $self->id; 6052 return unless $dirent->[1]; 6053 return $self->{UPLOAD_DATE} = $dirent->[1]; 6054 } 6055 6056 #-> sub CPAN::Distribution::uptodate ; 6057 sub uptodate { 6058 my($self) = @_; 6059 my $c; 6060 foreach $c ($self->containsmods) { 6061 my $obj = CPAN::Shell->expandany($c); 6062 unless ($obj->uptodate) { 6063 my $id = $self->pretty_id; 6064 $self->debug("$id not uptodate due to $c") if $CPAN::DEBUG; 6065 return 0; 6066 } 6067 } 6068 return 1; 6069 } 6070 6071 #-> sub CPAN::Distribution::called_for ; 6072 sub called_for { 6073 my($self,$id) = @_; 6074 $self->{CALLED_FOR} = $id if defined $id; 6075 return $self->{CALLED_FOR}; 6076 } 6077 6078 #-> sub CPAN::Distribution::get ; 6079 sub get { 6080 my($self) = @_; 6081 $self->debug("checking goto id[$self->{ID}]") if $CPAN::DEBUG; 6082 if (my $goto = $self->prefs->{goto}) { 6083 $CPAN::Frontend->mywarn 6084 (sprintf( 6085 "delegating to '%s' as specified in prefs file '%s' doc %d\n", 6086 $goto, 6087 $self->{prefs_file}, 6088 $self->{prefs_file_doc}, 6089 )); 6090 return $self->goto($goto); 6091 } 6092 local $ENV{PERL5LIB} = defined($ENV{PERL5LIB}) 6093 ? $ENV{PERL5LIB} 6094 : ($ENV{PERLLIB} || ""); 6095 6096 $CPAN::META->set_perl5lib; 6097 local $ENV{MAKEFLAGS}; # protect us from outer make calls 6098 6099 EXCUSE: { 6100 my @e; 6101 my $goodbye_message; 6102 $self->debug("checking disabled id[$self->{ID}]") if $CPAN::DEBUG; 6103 if ($self->prefs->{disabled}) { 6104 my $why = sprintf( 6105 "Disabled via prefs file '%s' doc %d", 6106 $self->{prefs_file}, 6107 $self->{prefs_file_doc}, 6108 ); 6109 push @e, $why; 6110 $self->{unwrapped} = CPAN::Distrostatus->new("NO $why"); 6111 $goodbye_message = "[disabled] -- NA $why"; 6112 # note: not intended to be persistent but at least visible 6113 # during this session 6114 } else { 6115 if (exists $self->{build_dir} && -d $self->{build_dir} 6116 && ($self->{modulebuild}||$self->{writemakefile}) 6117 ) { 6118 # this deserves print, not warn: 6119 $CPAN::Frontend->myprint(" Has already been unwrapped into directory ". 6120 "$self->{build_dir}\n" 6121 ); 6122 return 1; 6123 } 6124 6125 # although we talk about 'force' we shall not test on 6126 # force directly. New model of force tries to refrain from 6127 # direct checking of force. 6128 exists $self->{unwrapped} and ( 6129 UNIVERSAL::can($self->{unwrapped},"failed") ? 6130 $self->{unwrapped}->failed : 6131 $self->{unwrapped} =~ /^NO/ 6132 ) 6133 and push @e, "Unwrapping had some problem, won't try again without force"; 6134 } 6135 if (@e) { 6136 $CPAN::Frontend->mywarn(join "", map {"$_\n"} @e); 6137 if ($goodbye_message) { 6138 $self->goodbye($goodbye_message); 6139 } 6140 return; 6141 } 6142 } 6143 my $sub_wd = CPAN::anycwd(); # for cleaning up as good as possible 6144 6145 my($local_file); 6146 unless ($self->{build_dir} && -d $self->{build_dir}) { 6147 $self->get_file_onto_local_disk; 6148 return if $CPAN::Signal; 6149 $self->check_integrity; 6150 return if $CPAN::Signal; 6151 (my $packagedir,$local_file) = $self->run_preps_on_packagedir; 6152 $packagedir ||= $self->{build_dir}; 6153 $self->{build_dir} = $packagedir; 6154 } 6155 6156 if ($CPAN::Signal) { 6157 $self->safe_chdir($sub_wd); 6158 return; 6159 } 6160 return $self->run_MM_or_MB($local_file); 6161 } 6162 6163 #-> CPAN::Distribution::get_file_onto_local_disk 6164 sub get_file_onto_local_disk { 6165 my($self) = @_; 6166 6167 return if $self->is_dot_dist; 6168 my($local_file); 6169 my($local_wanted) = 6170 File::Spec->catfile( 6171 $CPAN::Config->{keep_source_where}, 6172 "authors", 6173 "id", 6174 split(/\//,$self->id) 6175 ); 6176 6177 $self->debug("Doing localize") if $CPAN::DEBUG; 6178 unless ($local_file = 6179 CPAN::FTP->localize("authors/id/$self->{ID}", 6180 $local_wanted)) { 6181 my $note = ""; 6182 if ($CPAN::Index::DATE_OF_02) { 6183 $note = "Note: Current database in memory was generated ". 6184 "on $CPAN::Index::DATE_OF_02\n"; 6185 } 6186 $CPAN::Frontend->mydie("Giving up on '$local_wanted'\n$note"); 6187 } 6188 6189 $self->debug("local_wanted[$local_wanted]local_file[$local_file]") if $CPAN::DEBUG; 6190 $self->{localfile} = $local_file; 6191 } 6192 6193 6194 #-> CPAN::Distribution::check_integrity 6195 sub check_integrity { 6196 my($self) = @_; 6197 6198 return if $self->is_dot_dist; 6199 if ($CPAN::META->has_inst("Digest::SHA")) { 6200 $self->debug("Digest::SHA is installed, verifying"); 6201 $self->verifyCHECKSUM; 6202 } else { 6203 $self->debug("Digest::SHA is NOT installed"); 6204 } 6205 } 6206 6207 #-> CPAN::Distribution::run_preps_on_packagedir 6208 sub run_preps_on_packagedir { 6209 my($self) = @_; 6210 return if $self->is_dot_dist; 6211 6212 $CPAN::META->{cachemgr} ||= CPAN::CacheMgr->new(); # unsafe meta access, ok 6213 my $builddir = $CPAN::META->{cachemgr}->dir; # unsafe meta access, ok 6214 $self->safe_chdir($builddir); 6215 $self->debug("Removing tmp-$$") if $CPAN::DEBUG; 6216 File::Path::rmtree("tmp-$$"); 6217 unless (mkdir "tmp-$$", 0755) { 6218 $CPAN::Frontend->unrecoverable_error(<<EOF); 6219 Couldn't mkdir '$builddir/tmp-$$': $! 6220 6221 Cannot continue: Please find the reason why I cannot make the 6222 directory 6223 $builddir/tmp-$$ 6224 and fix the problem, then retry. 6225 6226 EOF 6227 } 6228 if ($CPAN::Signal) { 6229 return; 6230 } 6231 $self->safe_chdir("tmp-$$"); 6232 6233 # 6234 # Unpack the goods 6235 # 6236 my $local_file = $self->{localfile}; 6237 my $ct = eval{CPAN::Tarzip->new($local_file)}; 6238 unless ($ct) { 6239 $self->{unwrapped} = CPAN::Distrostatus->new("NO"); 6240 delete $self->{build_dir}; 6241 return; 6242 } 6243 if ($local_file =~ /(\.tar\.(bz2|gz|Z)|\.tgz)(?!\n)\Z/i) { 6244 $self->{was_uncompressed}++ unless eval{$ct->gtest()}; 6245 $self->untar_me($ct); 6246 } elsif ( $local_file =~ /\.zip(?!\n)\Z/i ) { 6247 $self->unzip_me($ct); 6248 } else { 6249 $self->{was_uncompressed}++ unless $ct->gtest(); 6250 $local_file = $self->handle_singlefile($local_file); 6251 } 6252 6253 # we are still in the tmp directory! 6254 # Let's check if the package has its own directory. 6255 my $dh = DirHandle->new(File::Spec->curdir) 6256 or Carp::croak("Couldn't opendir .: $!"); 6257 my @readdir = grep $_ !~ /^\.\.?(?!\n)\Z/s, $dh->read; ### MAC?? 6258 $dh->close; 6259 my ($packagedir); 6260 # XXX here we want in each branch File::Temp to protect all build_dir directories 6261 if (CPAN->has_usable("File::Temp")) { 6262 my $tdir_base; 6263 my $from_dir; 6264 my @dirents; 6265 if (@readdir == 1 && -d $readdir[0]) { 6266 $tdir_base = $readdir[0]; 6267 $from_dir = File::Spec->catdir(File::Spec->curdir,$readdir[0]); 6268 my $dh2 = DirHandle->new($from_dir) 6269 or Carp::croak("Couldn't opendir $from_dir: $!"); 6270 @dirents = grep $_ !~ /^\.\.?(?!\n)\Z/s, $dh2->read; ### MAC?? 6271 } else { 6272 my $userid = $self->cpan_userid; 6273 CPAN->debug("userid[$userid]"); 6274 if (!$userid or $userid eq "N/A") { 6275 $userid = "anon"; 6276 } 6277 $tdir_base = $userid; 6278 $from_dir = File::Spec->curdir; 6279 @dirents = @readdir; 6280 } 6281 $packagedir = File::Temp::tempdir( 6282 "$tdir_base-XXXXXX", 6283 DIR => $builddir, 6284 CLEANUP => 0, 6285 ); 6286 my $f; 6287 for $f (@dirents) { # is already without "." and ".." 6288 my $from = File::Spec->catdir($from_dir,$f); 6289 my $to = File::Spec->catdir($packagedir,$f); 6290 unless (File::Copy::move($from,$to)) { 6291 my $err = $!; 6292 $from = File::Spec->rel2abs($from); 6293 Carp::confess("Couldn't move $from to $to: $err"); 6294 } 6295 } 6296 } else { # older code below, still better than nothing when there is no File::Temp 6297 my($distdir); 6298 if (@readdir == 1 && -d $readdir[0]) { 6299 $distdir = $readdir[0]; 6300 $packagedir = File::Spec->catdir($builddir,$distdir); 6301 $self->debug("packagedir[$packagedir]builddir[$builddir]distdir[$distdir]") 6302 if $CPAN::DEBUG; 6303 -d $packagedir and $CPAN::Frontend->myprint("Removing previously used ". 6304 "$packagedir\n"); 6305 File::Path::rmtree($packagedir); 6306 unless (File::Copy::move($distdir,$packagedir)) { 6307 $CPAN::Frontend->unrecoverable_error(<<EOF); 6308 Couldn't move '$distdir' to '$packagedir': $! 6309 6310 Cannot continue: Please find the reason why I cannot move 6311 $builddir/tmp-$$/$distdir 6312 to 6313 $packagedir 6314 and fix the problem, then retry 6315 6316 EOF 6317 } 6318 $self->debug(sprintf("moved distdir[%s] to packagedir[%s] -e[%s]-d[%s]", 6319 $distdir, 6320 $packagedir, 6321 -e $packagedir, 6322 -d $packagedir, 6323 )) if $CPAN::DEBUG; 6324 } else { 6325 my $userid = $self->cpan_userid; 6326 CPAN->debug("userid[$userid]") if $CPAN::DEBUG; 6327 if (!$userid or $userid eq "N/A") { 6328 $userid = "anon"; 6329 } 6330 my $pragmatic_dir = $userid . '000'; 6331 $pragmatic_dir =~ s/\W_//g; 6332 $pragmatic_dir++ while -d "../$pragmatic_dir"; 6333 $packagedir = File::Spec->catdir($builddir,$pragmatic_dir); 6334 $self->debug("packagedir[$packagedir]") if $CPAN::DEBUG; 6335 File::Path::mkpath($packagedir); 6336 my($f); 6337 for $f (@readdir) { # is already without "." and ".." 6338 my $to = File::Spec->catdir($packagedir,$f); 6339 File::Copy::move($f,$to) or Carp::confess("Couldn't move $f to $to: $!"); 6340 } 6341 } 6342 } 6343 $self->{build_dir} = $packagedir; 6344 $self->safe_chdir($builddir); 6345 File::Path::rmtree("tmp-$$"); 6346 6347 $self->safe_chdir($packagedir); 6348 $self->_signature_business(); 6349 $self->safe_chdir($builddir); 6350 6351 return($packagedir,$local_file); 6352 } 6353 6354 #-> sub CPAN::Distribution::parse_meta_yml ; 6355 sub parse_meta_yml { 6356 my($self) = @_; 6357 my $build_dir = $self->{build_dir} or die "PANIC: cannot parse yaml without a build_dir"; 6358 my $yaml = File::Spec->catfile($build_dir,"META.yml"); 6359 $self->debug("yaml[$yaml]") if $CPAN::DEBUG; 6360 return unless -f $yaml; 6361 my $early_yaml; 6362 eval { 6363 require Parse::Metayaml; # hypothetical 6364 $early_yaml = Parse::Metayaml::LoadFile($yaml)->[0]; 6365 }; 6366 unless ($early_yaml) { 6367 eval { $early_yaml = CPAN->_yaml_loadfile($yaml)->[0]; }; 6368 } 6369 unless ($early_yaml) { 6370 return; 6371 } 6372 return $early_yaml; 6373 } 6374 6375 #-> sub CPAN::Distribution::satisfy_configure_requires ; 6376 sub satisfy_configure_requires { 6377 my($self) = @_; 6378 my $enable_configure_requires = 1; 6379 if (!$enable_configure_requires) { 6380 return 1; 6381 # if we return 1 here, everything is as before we introduced 6382 # configure_requires that means, things with 6383 # configure_requires simply fail, all others succeed 6384 } 6385 my @prereq = $self->unsat_prereq("configure_requires_later") or return 1; 6386 if ($self->{configure_requires_later}) { 6387 for my $k (keys %{$self->{configure_requires_later_for}||{}}) { 6388 if ($self->{configure_requires_later_for}{$k}>1) { 6389 # we must not come here a second time 6390 $CPAN::Frontend->mywarn("Panic: Some prerequisites is not available, please investigate..."); 6391 require YAML::Syck; 6392 $CPAN::Frontend->mydie 6393 ( 6394 YAML::Syck::Dump 6395 ({self=>$self, prereq=>\@prereq}) 6396 ); 6397 } 6398 } 6399 } 6400 if ($prereq[0][0] eq "perl") { 6401 my $need = "requires perl '$prereq[0][1]'"; 6402 my $id = $self->pretty_id; 6403 $CPAN::Frontend->mywarn("$id $need; you have only $]; giving up\n"); 6404 $self->{make} = CPAN::Distrostatus->new("NO $need"); 6405 $self->store_persistent_state; 6406 return $self->goodbye("[prereq] -- NOT OK"); 6407 } else { 6408 my $follow = eval { 6409 $self->follow_prereqs("configure_requires_later", @prereq); 6410 }; 6411 if (0) { 6412 } elsif ($follow) { 6413 return; 6414 } elsif ($@ && ref $@ && $@->isa("CPAN::Exception::RecursiveDependency")) { 6415 $CPAN::Frontend->mywarn($@); 6416 return $self->goodbye("[depend] -- NOT OK"); 6417 } 6418 } 6419 die "never reached"; 6420 } 6421 6422 #-> sub CPAN::Distribution::run_MM_or_MB ; 6423 sub run_MM_or_MB { 6424 my($self,$local_file) = @_; 6425 $self->satisfy_configure_requires() or return; 6426 my($mpl) = File::Spec->catfile($self->{build_dir},"Makefile.PL"); 6427 my($mpl_exists) = -f $mpl; 6428 unless ($mpl_exists) { 6429 # NFS has been reported to have racing problems after the 6430 # renaming of a directory in some environments. 6431 # This trick helps. 6432 $CPAN::Frontend->mysleep(1); 6433 my $mpldh = DirHandle->new($self->{build_dir}) 6434 or Carp::croak("Couldn't opendir $self->{build_dir}: $!"); 6435 $mpl_exists = grep /^Makefile\.PL$/, $mpldh->read; 6436 $mpldh->close; 6437 } 6438 my $prefer_installer = "eumm"; # eumm|mb 6439 if (-f File::Spec->catfile($self->{build_dir},"Build.PL")) { 6440 if ($mpl_exists) { # they *can* choose 6441 if ($CPAN::META->has_inst("Module::Build")) { 6442 $prefer_installer = CPAN::HandleConfig->prefs_lookup($self, 6443 q{prefer_installer}); 6444 } 6445 } else { 6446 $prefer_installer = "mb"; 6447 } 6448 } 6449 return unless $self->patch; 6450 if (lc($prefer_installer) eq "rand") { 6451 $prefer_installer = rand()<.5 ? "eumm" : "mb"; 6452 } 6453 if (lc($prefer_installer) eq "mb") { 6454 $self->{modulebuild} = 1; 6455 } elsif ($self->{archived} eq "patch") { 6456 # not an edge case, nothing to install for sure 6457 my $why = "A patch file cannot be installed"; 6458 $CPAN::Frontend->mywarn("Refusing to handle this file: $why\n"); 6459 $self->{writemakefile} = CPAN::Distrostatus->new("NO $why"); 6460 } elsif (! $mpl_exists) { 6461 $self->_edge_cases($mpl,$local_file); 6462 } 6463 if ($self->{build_dir} 6464 && 6465 $CPAN::Config->{build_dir_reuse} 6466 ) { 6467 $self->store_persistent_state; 6468 } 6469 return $self; 6470 } 6471 6472 #-> CPAN::Distribution::store_persistent_state 6473 sub store_persistent_state { 6474 my($self) = @_; 6475 my $dir = $self->{build_dir}; 6476 unless (File::Spec->canonpath(File::Basename::dirname($dir)) 6477 eq File::Spec->canonpath($CPAN::Config->{build_dir})) { 6478 $CPAN::Frontend->mywarn("Directory '$dir' not below $CPAN::Config->{build_dir}, ". 6479 "will not store persistent state\n"); 6480 return; 6481 } 6482 my $file = sprintf "%s.yml", $dir; 6483 my $yaml_module = CPAN::_yaml_module; 6484 if ($CPAN::META->has_inst($yaml_module)) { 6485 CPAN->_yaml_dumpfile( 6486 $file, 6487 { 6488 time => time, 6489 perl => CPAN::_perl_fingerprint, 6490 distribution => $self, 6491 } 6492 ); 6493 } else { 6494 $CPAN::Frontend->myprint("Warning (usually harmless): '$yaml_module' not installed, ". 6495 "will not store persistent state\n"); 6496 } 6497 } 6498 6499 #-> CPAN::Distribution::try_download 6500 sub try_download { 6501 my($self,$patch) = @_; 6502 my $norm = $self->normalize($patch); 6503 my($local_wanted) = 6504 File::Spec->catfile( 6505 $CPAN::Config->{keep_source_where}, 6506 "authors", 6507 "id", 6508 split(/\//,$norm), 6509 ); 6510 $self->debug("Doing localize") if $CPAN::DEBUG; 6511 return CPAN::FTP->localize("authors/id/$norm", 6512 $local_wanted); 6513 } 6514 6515 { 6516 my $stdpatchargs = ""; 6517 #-> CPAN::Distribution::patch 6518 sub patch { 6519 my($self) = @_; 6520 $self->debug("checking patches id[$self->{ID}]") if $CPAN::DEBUG; 6521 my $patches = $self->prefs->{patches}; 6522 $patches ||= ""; 6523 $self->debug("patches[$patches]") if $CPAN::DEBUG; 6524 if ($patches) { 6525 return unless @$patches; 6526 $self->safe_chdir($self->{build_dir}); 6527 CPAN->debug("patches[$patches]") if $CPAN::DEBUG; 6528 my $patchbin = $CPAN::Config->{patch}; 6529 unless ($patchbin && length $patchbin) { 6530 $CPAN::Frontend->mydie("No external patch command configured\n\n". 6531 "Please run 'o conf init /patch/'\n\n"); 6532 } 6533 unless (MM->maybe_command($patchbin)) { 6534 $CPAN::Frontend->mydie("No external patch command available\n\n". 6535 "Please run 'o conf init /patch/'\n\n"); 6536 } 6537 $patchbin = CPAN::HandleConfig->safe_quote($patchbin); 6538 local $ENV{PATCH_GET} = 0; # formerly known as -g0 6539 unless ($stdpatchargs) { 6540 my $system = "$patchbin --version |"; 6541 local *FH; 6542 open FH, $system or die "Could not fork '$system': $!"; 6543 local $/ = "\n"; 6544 my $pversion; 6545 PARSEVERSION: while (<FH>) { 6546 if (/^patch\s+([\d\.]+)/) { 6547 $pversion = $1; 6548 last PARSEVERSION; 6549 } 6550 } 6551 if ($pversion) { 6552 $stdpatchargs = "-N --fuzz=3"; 6553 } else { 6554 $stdpatchargs = "-N"; 6555 } 6556 } 6557 my $countedpatches = @$patches == 1 ? "1 patch" : (scalar @$patches . " patches"); 6558 $CPAN::Frontend->myprint("Going to apply $countedpatches:\n"); 6559 for my $patch (@$patches) { 6560 unless (-f $patch) { 6561 if (my $trydl = $self->try_download($patch)) { 6562 $patch = $trydl; 6563 } else { 6564 my $fail = "Could not find patch '$patch'"; 6565 $CPAN::Frontend->mywarn("$fail; cannot continue\n"); 6566 $self->{unwrapped} = CPAN::Distrostatus->new("NO -- $fail"); 6567 delete $self->{build_dir}; 6568 return; 6569 } 6570 } 6571 $CPAN::Frontend->myprint(" $patch\n"); 6572 my $readfh = CPAN::Tarzip->TIEHANDLE($patch); 6573 6574 my $pcommand; 6575 my $ppp = $self->_patch_p_parameter($readfh); 6576 if ($ppp eq "applypatch") { 6577 $pcommand = "$CPAN::Config->{applypatch} -verbose"; 6578 } else { 6579 my $thispatchargs = join " ", $stdpatchargs, $ppp; 6580 $pcommand = "$patchbin $thispatchargs"; 6581 } 6582 6583 $readfh = CPAN::Tarzip->TIEHANDLE($patch); # open again 6584 my $writefh = FileHandle->new; 6585 $CPAN::Frontend->myprint(" $pcommand\n"); 6586 unless (open $writefh, "|$pcommand") { 6587 my $fail = "Could not fork '$pcommand'"; 6588 $CPAN::Frontend->mywarn("$fail; cannot continue\n"); 6589 $self->{unwrapped} = CPAN::Distrostatus->new("NO -- $fail"); 6590 delete $self->{build_dir}; 6591 return; 6592 } 6593 while (my $x = $readfh->READLINE) { 6594 print $writefh $x; 6595 } 6596 unless (close $writefh) { 6597 my $fail = "Could not apply patch '$patch'"; 6598 $CPAN::Frontend->mywarn("$fail; cannot continue\n"); 6599 $self->{unwrapped} = CPAN::Distrostatus->new("NO -- $fail"); 6600 delete $self->{build_dir}; 6601 return; 6602 } 6603 } 6604 $self->{patched}++; 6605 } 6606 return 1; 6607 } 6608 } 6609 6610 sub _patch_p_parameter { 6611 my($self,$fh) = @_; 6612 my $cnt_files = 0; 6613 my $cnt_p0files = 0; 6614 local($_); 6615 while ($_ = $fh->READLINE) { 6616 if ( 6617 $CPAN::Config->{applypatch} 6618 && 6619 /\#\#\#\# ApplyPatch data follows \#\#\#\#/ 6620 ) { 6621 return "applypatch" 6622 } 6623 next unless /^[\*\+]{3}\s(\S+)/; 6624 my $file = $1; 6625 $cnt_files++; 6626 $cnt_p0files++ if -f $file; 6627 CPAN->debug("file[$file]cnt_files[$cnt_files]cnt_p0files[$cnt_p0files]") 6628 if $CPAN::DEBUG; 6629 } 6630 return "-p1" unless $cnt_files; 6631 return $cnt_files==$cnt_p0files ? "-p0" : "-p1"; 6632 } 6633 6634 #-> sub CPAN::Distribution::_edge_cases 6635 # with "configure" or "Makefile" or single file scripts 6636 sub _edge_cases { 6637 my($self,$mpl,$local_file) = @_; 6638 $self->debug(sprintf("makefilepl[%s]anycwd[%s]", 6639 $mpl, 6640 CPAN::anycwd(), 6641 )) if $CPAN::DEBUG; 6642 my $build_dir = $self->{build_dir}; 6643 my($configure) = File::Spec->catfile($build_dir,"Configure"); 6644 if (-f $configure) { 6645 # do we have anything to do? 6646 $self->{configure} = $configure; 6647 } elsif (-f File::Spec->catfile($build_dir,"Makefile")) { 6648 $CPAN::Frontend->mywarn(qq{ 6649 Package comes with a Makefile and without a Makefile.PL. 6650 We\'ll try to build it with that Makefile then. 6651 }); 6652 $self->{writemakefile} = CPAN::Distrostatus->new("YES"); 6653 $CPAN::Frontend->mysleep(2); 6654 } else { 6655 my $cf = $self->called_for || "unknown"; 6656 if ($cf =~ m|/|) { 6657 $cf =~ s|.*/||; 6658 $cf =~ s|\W.*||; 6659 } 6660 $cf =~ s|[/\\:]||g; # risk of filesystem damage 6661 $cf = "unknown" unless length($cf); 6662 $CPAN::Frontend->mywarn(qq{Package seems to come without Makefile.PL. 6663 (The test -f "$mpl" returned false.) 6664 Writing one on our own (setting NAME to $cf)\a\n}); 6665 $self->{had_no_makefile_pl}++; 6666 $CPAN::Frontend->mysleep(3); 6667 6668 # Writing our own Makefile.PL 6669 6670 my $script = ""; 6671 if ($self->{archived} eq "maybe_pl") { 6672 my $fh = FileHandle->new; 6673 my $script_file = File::Spec->catfile($build_dir,$local_file); 6674 $fh->open($script_file) 6675 or Carp::croak("Could not open script '$script_file': $!"); 6676 local $/ = "\n"; 6677 # name parsen und prereq 6678 my($state) = "poddir"; 6679 my($name, $prereq) = ("", ""); 6680 while (<$fh>) { 6681 if ($state eq "poddir" && /^=head\d\s+(\S+)/) { 6682 if ($1 eq 'NAME') { 6683 $state = "name"; 6684 } elsif ($1 eq 'PREREQUISITES') { 6685 $state = "prereq"; 6686 } 6687 } elsif ($state =~ m{^(name|prereq)$}) { 6688 if (/^=/) { 6689 $state = "poddir"; 6690 } elsif (/^\s*$/) { 6691 # nop 6692 } elsif ($state eq "name") { 6693 if ($name eq "") { 6694 ($name) = /^(\S+)/; 6695 $state = "poddir"; 6696 } 6697 } elsif ($state eq "prereq") { 6698 $prereq .= $_; 6699 } 6700 } elsif (/^=cut\b/) { 6701 last; 6702 } 6703 } 6704 $fh->close; 6705 6706 for ($name) { 6707 s{.*<}{}; # strip X<...> 6708 s{>.*}{}; 6709 } 6710 chomp $prereq; 6711 $prereq = join " ", split /\s+/, $prereq; 6712 my($PREREQ_PM) = join("\n", map { 6713 s{.*<}{}; # strip X<...> 6714 s{>.*}{}; 6715 if (/[\s\'\"]/) { # prose? 6716 } else { 6717 s/[^\w:]$//; # period? 6718 " "x28 . "'$_' => 0,"; 6719 } 6720 } split /\s*,\s*/, $prereq); 6721 6722 $script = " 6723 EXE_FILES => ['$name'], 6724 PREREQ_PM => { 6725 $PREREQ_PM 6726 }, 6727 "; 6728 if ($name) { 6729 my $to_file = File::Spec->catfile($build_dir, $name); 6730 rename $script_file, $to_file 6731 or die "Can't rename $script_file to $to_file: $!"; 6732 } 6733 } 6734 6735 my $fh = FileHandle->new; 6736 $fh->open(">$mpl") 6737 or Carp::croak("Could not open >$mpl: $!"); 6738 $fh->print( 6739 qq{# This Makefile.PL has been autogenerated by the module CPAN.pm 6740 # because there was no Makefile.PL supplied. 6741 # Autogenerated on: }.scalar localtime().qq{ 6742 6743 use ExtUtils::MakeMaker; 6744 WriteMakefile( 6745 NAME => q[$cf],$script 6746 ); 6747 }); 6748 $fh->close; 6749 } 6750 } 6751 6752 #-> CPAN::Distribution::_signature_business 6753 sub _signature_business { 6754 my($self) = @_; 6755 my $check_sigs = CPAN::HandleConfig->prefs_lookup($self, 6756 q{check_sigs}); 6757 if ($check_sigs) { 6758 if ($CPAN::META->has_inst("Module::Signature")) { 6759 if (-f "SIGNATURE") { 6760 $self->debug("Module::Signature is installed, verifying") if $CPAN::DEBUG; 6761 my $rv = Module::Signature::verify(); 6762 if ($rv != Module::Signature::SIGNATURE_OK() and 6763 $rv != Module::Signature::SIGNATURE_MISSING()) { 6764 $CPAN::Frontend->mywarn( 6765 qq{\nSignature invalid for }. 6766 qq{distribution file. }. 6767 qq{Please investigate.\n\n} 6768 ); 6769 6770 my $wrap = 6771 sprintf(qq{I'd recommend removing %s. Some error occured }. 6772 qq{while checking its signature, so it could }. 6773 qq{be invalid. Maybe you have configured }. 6774 qq{your 'urllist' with a bad URL. Please check this }. 6775 qq{array with 'o conf urllist' and retry. Or }. 6776 qq{examine the distribution in a subshell. Try 6777 look %s 6778 and run 6779 cpansign -v 6780 }, 6781 $self->{localfile}, 6782 $self->pretty_id, 6783 ); 6784 $self->{signature_verify} = CPAN::Distrostatus->new("NO"); 6785 $CPAN::Frontend->mywarn(Text::Wrap::wrap("","",$wrap)); 6786 $CPAN::Frontend->mysleep(5) if $CPAN::Frontend->can("mysleep"); 6787 } else { 6788 $self->{signature_verify} = CPAN::Distrostatus->new("YES"); 6789 $self->debug("Module::Signature has verified") if $CPAN::DEBUG; 6790 } 6791 } else { 6792 $CPAN::Frontend->mywarn(qq{Package came without SIGNATURE\n\n}); 6793 } 6794 } else { 6795 $self->debug("Module::Signature is NOT installed") if $CPAN::DEBUG; 6796 } 6797 } 6798 } 6799 6800 #-> CPAN::Distribution::untar_me ; 6801 sub untar_me { 6802 my($self,$ct) = @_; 6803 $self->{archived} = "tar"; 6804 if ($ct->untar()) { 6805 $self->{unwrapped} = CPAN::Distrostatus->new("YES"); 6806 } else { 6807 $self->{unwrapped} = CPAN::Distrostatus->new("NO -- untar failed"); 6808 } 6809 } 6810 6811 # CPAN::Distribution::unzip_me ; 6812 sub unzip_me { 6813 my($self,$ct) = @_; 6814 $self->{archived} = "zip"; 6815 if ($ct->unzip()) { 6816 $self->{unwrapped} = CPAN::Distrostatus->new("YES"); 6817 } else { 6818 $self->{unwrapped} = CPAN::Distrostatus->new("NO -- unzip failed"); 6819 } 6820 return; 6821 } 6822 6823 sub handle_singlefile { 6824 my($self,$local_file) = @_; 6825 6826 if ( $local_file =~ /\.pm(\.(gz|Z))?(?!\n)\Z/ ) { 6827 $self->{archived} = "pm"; 6828 } elsif ( $local_file =~ /\.patch(\.(gz|bz2))?(?!\n)\Z/ ) { 6829 $self->{archived} = "patch"; 6830 } else { 6831 $self->{archived} = "maybe_pl"; 6832 } 6833 6834 my $to = File::Basename::basename($local_file); 6835 if ($to =~ s/\.(gz|Z)(?!\n)\Z//) { 6836 if (eval{CPAN::Tarzip->new($local_file)->gunzip($to)}) { 6837 $self->{unwrapped} = CPAN::Distrostatus->new("YES"); 6838 } else { 6839 $self->{unwrapped} = CPAN::Distrostatus->new("NO -- uncompressing failed"); 6840 } 6841 } else { 6842 if (File::Copy::cp($local_file,".")) { 6843 $self->{unwrapped} = CPAN::Distrostatus->new("YES"); 6844 } else { 6845 $self->{unwrapped} = CPAN::Distrostatus->new("NO -- copying failed"); 6846 } 6847 } 6848 return $to; 6849 } 6850 6851 #-> sub CPAN::Distribution::new ; 6852 sub new { 6853 my($class,%att) = @_; 6854 6855 # $CPAN::META->{cachemgr} ||= CPAN::CacheMgr->new(); 6856 6857 my $this = { %att }; 6858 return bless $this, $class; 6859 } 6860 6861 #-> sub CPAN::Distribution::look ; 6862 sub look { 6863 my($self) = @_; 6864 6865 if ($^O eq 'MacOS') { 6866 $self->Mac::BuildTools::look; 6867 return; 6868 } 6869 6870 if ( $CPAN::Config->{'shell'} ) { 6871 $CPAN::Frontend->myprint(qq{ 6872 Trying to open a subshell in the build directory... 6873 }); 6874 } else { 6875 $CPAN::Frontend->myprint(qq{ 6876 Your configuration does not define a value for subshells. 6877 Please define it with "o conf shell <your shell>" 6878 }); 6879 return; 6880 } 6881 my $dist = $self->id; 6882 my $dir; 6883 unless ($dir = $self->dir) { 6884 $self->get; 6885 } 6886 unless ($dir ||= $self->dir) { 6887 $CPAN::Frontend->mywarn(qq{ 6888 Could not determine which directory to use for looking at $dist. 6889 }); 6890 return; 6891 } 6892 my $pwd = CPAN::anycwd(); 6893 $self->safe_chdir($dir); 6894 $CPAN::Frontend->myprint(qq{Working directory is $dir\n}); 6895 { 6896 local $ENV{CPAN_SHELL_LEVEL} = $ENV{CPAN_SHELL_LEVEL}||0; 6897 $ENV{CPAN_SHELL_LEVEL} += 1; 6898 my $shell = CPAN::HandleConfig->safe_quote($CPAN::Config->{'shell'}); 6899 unless (system($shell) == 0) { 6900 my $code = $? >> 8; 6901 $CPAN::Frontend->mywarn("Subprocess shell exit code $code\n"); 6902 } 6903 } 6904 $self->safe_chdir($pwd); 6905 } 6906 6907 # CPAN::Distribution::cvs_import ; 6908 sub cvs_import { 6909 my($self) = @_; 6910 $self->get; 6911 my $dir = $self->dir; 6912 6913 my $package = $self->called_for; 6914 my $module = $CPAN::META->instance('CPAN::Module', $package); 6915 my $version = $module->cpan_version; 6916 6917 my $userid = $self->cpan_userid; 6918 6919 my $cvs_dir = (split /\//, $dir)[-1]; 6920 $cvs_dir =~ s/-\d+[^-]+(?!\n)\Z//; 6921 my $cvs_root = 6922 $CPAN::Config->{cvsroot} || $ENV{CVSROOT}; 6923 my $cvs_site_perl = 6924 $CPAN::Config->{cvs_site_perl} || $ENV{CVS_SITE_PERL}; 6925 if ($cvs_site_perl) { 6926 $cvs_dir = "$cvs_site_perl/$cvs_dir"; 6927 } 6928 my $cvs_log = qq{"imported $package $version sources"}; 6929 $version =~ s/\./_/g; 6930 # XXX cvs: undocumented and unclear how it was meant to work 6931 my @cmd = ('cvs', '-d', $cvs_root, 'import', '-m', $cvs_log, 6932 "$cvs_dir", $userid, "v$version"); 6933 6934 my $pwd = CPAN::anycwd(); 6935 chdir($dir) or $CPAN::Frontend->mydie(qq{Could not chdir to "$dir": $!}); 6936 6937 $CPAN::Frontend->myprint(qq{Working directory is $dir\n}); 6938 6939 $CPAN::Frontend->myprint(qq{@cmd\n}); 6940 system(@cmd) == 0 or 6941 # XXX cvs 6942 $CPAN::Frontend->mydie("cvs import failed"); 6943 chdir($pwd) or $CPAN::Frontend->mydie(qq{Could not chdir to "$pwd": $!}); 6944 } 6945 6946 #-> sub CPAN::Distribution::readme ; 6947 sub readme { 6948 my($self) = @_; 6949 my($dist) = $self->id; 6950 my($sans,$suffix) = $dist =~ /(.+)\.(tgz|tar[\._-]gz|tar\.Z|zip)$/; 6951 $self->debug("sans[$sans] suffix[$suffix]\n") if $CPAN::DEBUG; 6952 my($local_file); 6953 my($local_wanted) = 6954 File::Spec->catfile( 6955 $CPAN::Config->{keep_source_where}, 6956 "authors", 6957 "id", 6958 split(/\//,"$sans.readme"), 6959 ); 6960 $self->debug("Doing localize") if $CPAN::DEBUG; 6961 $local_file = CPAN::FTP->localize("authors/id/$sans.readme", 6962 $local_wanted) 6963 or $CPAN::Frontend->mydie(qq{No $sans.readme found});; 6964 6965 if ($^O eq 'MacOS') { 6966 Mac::BuildTools::launch_file($local_file); 6967 return; 6968 } 6969 6970 my $fh_pager = FileHandle->new; 6971 local($SIG{PIPE}) = "IGNORE"; 6972 my $pager = $CPAN::Config->{'pager'} || "cat"; 6973 $fh_pager->open("|$pager") 6974 or die "Could not open pager $pager\: $!"; 6975 my $fh_readme = FileHandle->new; 6976 $fh_readme->open($local_file) 6977 or $CPAN::Frontend->mydie(qq{Could not open "$local_file": $!}); 6978 $CPAN::Frontend->myprint(qq{ 6979 Displaying file 6980 $local_file 6981 with pager "$pager" 6982 }); 6983 $fh_pager->print(<$fh_readme>); 6984 $fh_pager->close; 6985 } 6986 6987 #-> sub CPAN::Distribution::verifyCHECKSUM ; 6988 sub verifyCHECKSUM { 6989 my($self) = @_; 6990 EXCUSE: { 6991 my @e; 6992 $self->{CHECKSUM_STATUS} ||= ""; 6993 $self->{CHECKSUM_STATUS} eq "OK" and push @e, "Checksum was ok"; 6994 $CPAN::Frontend->myprint(join "", map {" $_\n"} @e) and return if @e; 6995 } 6996 my($lc_want,$lc_file,@local,$basename); 6997 @local = split(/\//,$self->id); 6998 pop @local; 6999 push @local, "CHECKSUMS"; 7000 $lc_want = 7001 File::Spec->catfile($CPAN::Config->{keep_source_where}, 7002 "authors", "id", @local); 7003 local($") = "/"; 7004 if (my $size = -s $lc_want) { 7005 $self->debug("lc_want[$lc_want]size[$size]") if $CPAN::DEBUG; 7006 if ($self->CHECKSUM_check_file($lc_want,1)) { 7007 return $self->{CHECKSUM_STATUS} = "OK"; 7008 } 7009 } 7010 $lc_file = CPAN::FTP->localize("authors/id/@local", 7011 $lc_want,1); 7012 unless ($lc_file) { 7013 $CPAN::Frontend->myprint("Trying $lc_want.gz\n"); 7014 $local[-1] .= ".gz"; 7015 $lc_file = CPAN::FTP->localize("authors/id/@local", 7016 "$lc_want.gz",1); 7017 if ($lc_file) { 7018 $lc_file =~ s/\.gz(?!\n)\Z//; 7019 eval{CPAN::Tarzip->new("$lc_file.gz")->gunzip($lc_file)}; 7020 } else { 7021 return; 7022 } 7023 } 7024 if ($self->CHECKSUM_check_file($lc_file)) { 7025 return $self->{CHECKSUM_STATUS} = "OK"; 7026 } 7027 } 7028 7029 #-> sub CPAN::Distribution::SIG_check_file ; 7030 sub SIG_check_file { 7031 my($self,$chk_file) = @_; 7032 my $rv = eval { Module::Signature::_verify($chk_file) }; 7033 7034 if ($rv == Module::Signature::SIGNATURE_OK()) { 7035 $CPAN::Frontend->myprint("Signature for $chk_file ok\n"); 7036 return $self->{SIG_STATUS} = "OK"; 7037 } else { 7038 $CPAN::Frontend->myprint(qq{\nSignature invalid for }. 7039 qq{distribution file. }. 7040 qq{Please investigate.\n\n}. 7041 $self->as_string, 7042 $CPAN::META->instance( 7043 'CPAN::Author', 7044 $self->cpan_userid 7045 )->as_string); 7046 7047 my $wrap = qq{I\'d recommend removing $chk_file. Its signature 7048 is invalid. Maybe you have configured your 'urllist' with 7049 a bad URL. Please check this array with 'o conf urllist', and 7050 retry.}; 7051 7052 $CPAN::Frontend->mydie(Text::Wrap::wrap("","",$wrap)); 7053 } 7054 } 7055 7056 #-> sub CPAN::Distribution::CHECKSUM_check_file ; 7057 7058 # sloppy is 1 when we have an old checksums file that maybe is good 7059 # enough 7060 7061 sub CHECKSUM_check_file { 7062 my($self,$chk_file,$sloppy) = @_; 7063 my($cksum,$file,$basename); 7064 7065 $sloppy ||= 0; 7066 $self->debug("chk_file[$chk_file]sloppy[$sloppy]") if $CPAN::DEBUG; 7067 my $check_sigs = CPAN::HandleConfig->prefs_lookup($self, 7068 q{check_sigs}); 7069 if ($check_sigs) { 7070 if ($CPAN::META->has_inst("Module::Signature")) { 7071 $self->debug("Module::Signature is installed, verifying") if $CPAN::DEBUG; 7072 $self->SIG_check_file($chk_file); 7073 } else { 7074 $self->debug("Module::Signature is NOT installed") if $CPAN::DEBUG; 7075 } 7076 } 7077 7078 $file = $self->{localfile}; 7079 $basename = File::Basename::basename($file); 7080 my $fh = FileHandle->new; 7081 if (open $fh, $chk_file) { 7082 local($/); 7083 my $eval = <$fh>; 7084 $eval =~ s/\015?\012/\n/g; 7085 close $fh; 7086 my($comp) = Safe->new(); 7087 $cksum = $comp->reval($eval); 7088 if ($@) { 7089 rename $chk_file, "$chk_file.bad"; 7090 Carp::confess($@) if $@; 7091 } 7092 } else { 7093 Carp::carp "Could not open $chk_file for reading"; 7094 } 7095 7096 if (! ref $cksum or ref $cksum ne "HASH") { 7097 $CPAN::Frontend->mywarn(qq{ 7098 Warning: checksum file '$chk_file' broken. 7099 7100 When trying to read that file I expected to get a hash reference 7101 for further processing, but got garbage instead. 7102 }); 7103 my $answer = CPAN::Shell::colorable_makemaker_prompt("Proceed nonetheless?", "no"); 7104 $answer =~ /^\s*y/i or $CPAN::Frontend->mydie("Aborted.\n"); 7105 $self->{CHECKSUM_STATUS} = "NIL -- CHECKSUMS file broken"; 7106 return; 7107 } elsif (exists $cksum->{$basename}{sha256}) { 7108 $self->debug("Found checksum for $basename:" . 7109 "$cksum->{$basename}{sha256}\n") if $CPAN::DEBUG; 7110 7111 open($fh, $file); 7112 binmode $fh; 7113 my $eq = $self->eq_CHECKSUM($fh,$cksum->{$basename}{sha256}); 7114 $fh->close; 7115 $fh = CPAN::Tarzip->TIEHANDLE($file); 7116 7117 unless ($eq) { 7118 my $dg = Digest::SHA->new(256); 7119 my($data,$ref); 7120 $ref = \$data; 7121 while ($fh->READ($ref, 4096) > 0) { 7122 $dg->add($data); 7123 } 7124 my $hexdigest = $dg->hexdigest; 7125 $eq += $hexdigest eq $cksum->{$basename}{'sha256-ungz'}; 7126 } 7127 7128 if ($eq) { 7129 $CPAN::Frontend->myprint("Checksum for $file ok\n"); 7130 return $self->{CHECKSUM_STATUS} = "OK"; 7131 } else { 7132 $CPAN::Frontend->myprint(qq{\nChecksum mismatch for }. 7133 qq{distribution file. }. 7134 qq{Please investigate.\n\n}. 7135 $self->as_string, 7136 $CPAN::META->instance( 7137 'CPAN::Author', 7138 $self->cpan_userid 7139 )->as_string); 7140 7141 my $wrap = qq{I\'d recommend removing $file. Its 7142 checksum is incorrect. Maybe you have configured your 'urllist' with 7143 a bad URL. Please check this array with 'o conf urllist', and 7144 retry.}; 7145 7146 $CPAN::Frontend->mydie(Text::Wrap::wrap("","",$wrap)); 7147 7148 # former versions just returned here but this seems a 7149 # serious threat that deserves a die 7150 7151 # $CPAN::Frontend->myprint("\n\n"); 7152 # sleep 3; 7153 # return; 7154 } 7155 # close $fh if fileno($fh); 7156 } else { 7157 return if $sloppy; 7158 unless ($self->{CHECKSUM_STATUS}) { 7159 $CPAN::Frontend->mywarn(qq{ 7160 Warning: No checksum for $basename in $chk_file. 7161 7162 The cause for this may be that the file is very new and the checksum 7163 has not yet been calculated, but it may also be that something is 7164 going awry right now. 7165 }); 7166 my $answer = CPAN::Shell::colorable_makemaker_prompt("Proceed?", "yes"); 7167 $answer =~ /^\s*y/i or $CPAN::Frontend->mydie("Aborted.\n"); 7168 } 7169 $self->{CHECKSUM_STATUS} = "NIL -- distro not in CHECKSUMS file"; 7170 return; 7171 } 7172 } 7173 7174 #-> sub CPAN::Distribution::eq_CHECKSUM ; 7175 sub eq_CHECKSUM { 7176 my($self,$fh,$expect) = @_; 7177 if ($CPAN::META->has_inst("Digest::SHA")) { 7178 my $dg = Digest::SHA->new(256); 7179 my($data); 7180 while (read($fh, $data, 4096)) { 7181 $dg->add($data); 7182 } 7183 my $hexdigest = $dg->hexdigest; 7184 # warn "fh[$fh] hex[$hexdigest] aexp[$expectMD5]"; 7185 return $hexdigest eq $expect; 7186 } 7187 return 1; 7188 } 7189 7190 #-> sub CPAN::Distribution::force ; 7191 7192 # Both CPAN::Modules and CPAN::Distributions know if "force" is in 7193 # effect by autoinspection, not by inspecting a global variable. One 7194 # of the reason why this was chosen to work that way was the treatment 7195 # of dependencies. They should not automatically inherit the force 7196 # status. But this has the downside that ^C and die() will return to 7197 # the prompt but will not be able to reset the force_update 7198 # attributes. We try to correct for it currently in the read_metadata 7199 # routine, and immediately before we check for a Signal. I hope this 7200 # works out in one of v1.57_53ff 7201 7202 # "Force get forgets previous error conditions" 7203 7204 #-> sub CPAN::Distribution::fforce ; 7205 sub fforce { 7206 my($self, $method) = @_; 7207 $self->force($method,1); 7208 } 7209 7210 #-> sub CPAN::Distribution::force ; 7211 sub force { 7212 my($self, $method,$fforce) = @_; 7213 my %phase_map = ( 7214 get => [ 7215 "unwrapped", 7216 "build_dir", 7217 "archived", 7218 "localfile", 7219 "CHECKSUM_STATUS", 7220 "signature_verify", 7221 "prefs", 7222 "prefs_file", 7223 "prefs_file_doc", 7224 ], 7225 make => [ 7226 "writemakefile", 7227 "make", 7228 "modulebuild", 7229 "prereq_pm", 7230 "prereq_pm_detected", 7231 ], 7232 test => [ 7233 "badtestcnt", 7234 "make_test", 7235 ], 7236 install => [ 7237 "install", 7238 ], 7239 unknown => [ 7240 "reqtype", 7241 "yaml_content", 7242 ], 7243 ); 7244 my $methodmatch = 0; 7245 my $ldebug = 0; 7246 PHASE: for my $phase (qw(unknown get make test install)) { # order matters 7247 $methodmatch = 1 if $fforce || $phase eq $method; 7248 next unless $methodmatch; 7249 ATTRIBUTE: for my $att (@{$phase_map{$phase}}) { 7250 if ($phase eq "get") { 7251 if (substr($self->id,-1,1) eq "." 7252 && $att =~ /(unwrapped|build_dir|archived)/ ) { 7253 # cannot be undone for local distros 7254 next ATTRIBUTE; 7255 } 7256 if ($att eq "build_dir" 7257 && $self->{build_dir} 7258 && $CPAN::META->{is_tested} 7259 ) { 7260 delete $CPAN::META->{is_tested}{$self->{build_dir}}; 7261 } 7262 } elsif ($phase eq "test") { 7263 if ($att eq "make_test" 7264 && $self->{make_test} 7265 && $self->{make_test}{COMMANDID} 7266 && $self->{make_test}{COMMANDID} == $CPAN::CurrentCommandId 7267 ) { 7268 # endless loop too likely 7269 next ATTRIBUTE; 7270 } 7271 } 7272 delete $self->{$att}; 7273 if ($ldebug || $CPAN::DEBUG) { 7274 # local $CPAN::DEBUG = 16; # Distribution 7275 CPAN->debug(sprintf "id[%s]phase[%s]att[%s]", $self->id, $phase, $att); 7276 } 7277 } 7278 } 7279 if ($method && $method =~ /make|test|install/) { 7280 $self->{force_update} = 1; # name should probably have been force_install 7281 } 7282 } 7283 7284 #-> sub CPAN::Distribution::notest ; 7285 sub notest { 7286 my($self, $method) = @_; 7287 # $CPAN::Frontend->mywarn("XDEBUG: set notest for $self $method"); 7288 $self->{"notest"}++; # name should probably have been force_install 7289 } 7290 7291 #-> sub CPAN::Distribution::unnotest ; 7292 sub unnotest { 7293 my($self) = @_; 7294 # warn "XDEBUG: deleting notest"; 7295 delete $self->{notest}; 7296 } 7297 7298 #-> sub CPAN::Distribution::unforce ; 7299 sub unforce { 7300 my($self) = @_; 7301 delete $self->{force_update}; 7302 } 7303 7304 #-> sub CPAN::Distribution::isa_perl ; 7305 sub isa_perl { 7306 my($self) = @_; 7307 my $file = File::Basename::basename($self->id); 7308 if ($file =~ m{ ^ perl 7309 -? 7310 (5) 7311 ([._-]) 7312 ( 7313 \d{3}(_[0-4][0-9])? 7314 | 7315 \d+\.\d+ 7316 ) 7317 \.tar[._-](?:gz|bz2) 7318 (?!\n)\Z 7319 }xs) { 7320 return "$1.$3"; 7321 } elsif ($self->cpan_comment 7322 && 7323 $self->cpan_comment =~ /isa_perl\(.+?\)/) { 7324 return $1; 7325 } 7326 } 7327 7328 7329 #-> sub CPAN::Distribution::perl ; 7330 sub perl { 7331 my ($self) = @_; 7332 if (! $self) { 7333 use Carp qw(carp); 7334 carp __PACKAGE__ . "::perl was called without parameters."; 7335 } 7336 return CPAN::HandleConfig->safe_quote($CPAN::Perl); 7337 } 7338 7339 7340 #-> sub CPAN::Distribution::make ; 7341 sub make { 7342 my($self) = @_; 7343 if (my $goto = $self->prefs->{goto}) { 7344 return $self->goto($goto); 7345 } 7346 my $make = $self->{modulebuild} ? "Build" : "make"; 7347 # Emergency brake if they said install Pippi and get newest perl 7348 if ($self->isa_perl) { 7349 if ( 7350 $self->called_for ne $self->id && 7351 ! $self->{force_update} 7352 ) { 7353 # if we die here, we break bundles 7354 $CPAN::Frontend 7355 ->mywarn(sprintf( 7356 qq{The most recent version "%s" of the module "%s" 7357 is part of the perl-%s distribution. To install that, you need to run 7358 force install %s --or-- 7359 install %s 7360 }, 7361 $CPAN::META->instance( 7362 'CPAN::Module', 7363 $self->called_for 7364 )->cpan_version, 7365 $self->called_for, 7366 $self->isa_perl, 7367 $self->called_for, 7368 $self->id, 7369 )); 7370 $self->{make} = CPAN::Distrostatus->new("NO isa perl"); 7371 $CPAN::Frontend->mysleep(1); 7372 return; 7373 } 7374 } 7375 $CPAN::Frontend->myprint(sprintf "Running %s for %s\n", $make, $self->id); 7376 $self->get; 7377 if ($self->{configure_requires_later}) { 7378 return; 7379 } 7380 local $ENV{PERL5LIB} = defined($ENV{PERL5LIB}) 7381 ? $ENV{PERL5LIB} 7382 : ($ENV{PERLLIB} || ""); 7383 $CPAN::META->set_perl5lib; 7384 local $ENV{MAKEFLAGS}; # protect us from outer make calls 7385 7386 if ($CPAN::Signal) { 7387 delete $self->{force_update}; 7388 return; 7389 } 7390 7391 my $builddir; 7392 EXCUSE: { 7393 my @e; 7394 if (!$self->{archived} || $self->{archived} eq "NO") { 7395 push @e, "Is neither a tar nor a zip archive."; 7396 } 7397 7398 if (!$self->{unwrapped} 7399 || ( 7400 UNIVERSAL::can($self->{unwrapped},"failed") ? 7401 $self->{unwrapped}->failed : 7402 $self->{unwrapped} =~ /^NO/ 7403 )) { 7404 push @e, "Had problems unarchiving. Please build manually"; 7405 } 7406 7407 unless ($self->{force_update}) { 7408 exists $self->{signature_verify} and 7409 ( 7410 UNIVERSAL::can($self->{signature_verify},"failed") ? 7411 $self->{signature_verify}->failed : 7412 $self->{signature_verify} =~ /^NO/ 7413 ) 7414 and push @e, "Did not pass the signature test."; 7415 } 7416 7417 if (exists $self->{writemakefile} && 7418 ( 7419 UNIVERSAL::can($self->{writemakefile},"failed") ? 7420 $self->{writemakefile}->failed : 7421 $self->{writemakefile} =~ /^NO/ 7422 )) { 7423 # XXX maybe a retry would be in order? 7424 my $err = UNIVERSAL::can($self->{writemakefile},"text") ? 7425 $self->{writemakefile}->text : 7426 $self->{writemakefile}; 7427 $err =~ s/^NO\s*//; 7428 $err ||= "Had some problem writing Makefile"; 7429 $err .= ", won't make"; 7430 push @e, $err; 7431 } 7432 7433 if (defined $self->{make}) { 7434 if (UNIVERSAL::can($self->{make},"failed") ? 7435 $self->{make}->failed : 7436 $self->{make} =~ /^NO/) { 7437 if ($self->{force_update}) { 7438 # Trying an already failed 'make' (unless somebody else blocks) 7439 } else { 7440 # introduced for turning recursion detection into a distrostatus 7441 my $error = length $self->{make}>3 7442 ? substr($self->{make},3) : "Unknown error"; 7443 $CPAN::Frontend->mywarn("Could not make: $error\n"); 7444 $self->store_persistent_state; 7445 return; 7446 } 7447 } else { 7448 push @e, "Has already been made"; 7449 } 7450 } 7451 7452 my $later = $self->{later} || $self->{configure_requires_later}; 7453 if ($later) { # see also undelay 7454 if ($later) { 7455 push @e, $later; 7456 } 7457 } 7458 7459 $CPAN::Frontend->myprint(join "", map {" $_\n"} @e) and return if @e; 7460 $builddir = $self->dir or 7461 $CPAN::Frontend->mydie("PANIC: Cannot determine build directory\n"); 7462 unless (chdir $builddir) { 7463 push @e, "Couldn't chdir to '$builddir': $!"; 7464 } 7465 $CPAN::Frontend->mywarn(join "", map {" $_\n"} @e) and return if @e; 7466 } 7467 if ($CPAN::Signal) { 7468 delete $self->{force_update}; 7469 return; 7470 } 7471 $CPAN::Frontend->myprint("\n CPAN.pm: Going to build ".$self->id."\n\n"); 7472 $self->debug("Changed directory to $builddir") if $CPAN::DEBUG; 7473 7474 if ($^O eq 'MacOS') { 7475 Mac::BuildTools::make($self); 7476 return; 7477 } 7478 7479 my %env; 7480 while (my($k,$v) = each %ENV) { 7481 next unless defined $v; 7482 $env{$k} = $v; 7483 } 7484 local %ENV = %env; 7485 my $system; 7486 if (my $commandline = $self->prefs->{pl}{commandline}) { 7487 $system = $commandline; 7488 $ENV{PERL} = $^X; 7489 } elsif ($self->{'configure'}) { 7490 $system = $self->{'configure'}; 7491 } elsif ($self->{modulebuild}) { 7492 my($perl) = $self->perl or die "Couldn\'t find executable perl\n"; 7493 $system = "$perl Build.PL $CPAN::Config->{mbuildpl_arg}"; 7494 } else { 7495 my($perl) = $self->perl or die "Couldn\'t find executable perl\n"; 7496 my $switch = ""; 7497 # This needs a handler that can be turned on or off: 7498 # $switch = "-MExtUtils::MakeMaker ". 7499 # "-Mops=:default,:filesys_read,:filesys_open,require,chdir" 7500 # if $] > 5.00310; 7501 my $makepl_arg = $self->make_x_arg("pl"); 7502 $ENV{PERL5_CPAN_IS_EXECUTING} = File::Spec->catfile($self->{build_dir}, 7503 "Makefile.PL"); 7504 $system = sprintf("%s%s Makefile.PL%s", 7505 $perl, 7506 $switch ? " $switch" : "", 7507 $makepl_arg ? " $makepl_arg" : "", 7508 ); 7509 } 7510 if (my $env = $self->prefs->{pl}{env}) { 7511 for my $e (keys %$env) { 7512 $ENV{$e} = $env->{$e}; 7513 } 7514 } 7515 if (exists $self->{writemakefile}) { 7516 } else { 7517 local($SIG{ALRM}) = sub { die "inactivity_timeout reached\n" }; 7518 my($ret,$pid,$output); 7519 $@ = ""; 7520 my $go_via_alarm; 7521 if ($CPAN::Config->{inactivity_timeout}) { 7522 require Config; 7523 if ($Config::Config{d_alarm} 7524 && 7525 $Config::Config{d_alarm} eq "define" 7526 ) { 7527 $go_via_alarm++ 7528 } else { 7529 $CPAN::Frontend->mywarn("Warning: you have configured the config ". 7530 "variable 'inactivity_timeout' to ". 7531 "'$CPAN::Config->{inactivity_timeout}'. But ". 7532 "on this machine the system call 'alarm' ". 7533 "isn't available. This means that we cannot ". 7534 "provide the feature of intercepting long ". 7535 "waiting code and will turn this feature off.\n" 7536 ); 7537 $CPAN::Config->{inactivity_timeout} = 0; 7538 } 7539 } 7540 if ($go_via_alarm) { 7541 if ( $self->_should_report('pl') ) { 7542 ($output, $ret) = CPAN::Reporter::record_command( 7543 $system, 7544 $CPAN::Config->{inactivity_timeout}, 7545 ); 7546 CPAN::Reporter::grade_PL( $self, $system, $output, $ret ); 7547 } 7548 else { 7549 eval { 7550 alarm $CPAN::Config->{inactivity_timeout}; 7551 local $SIG{CHLD}; # = sub { wait }; 7552 if (defined($pid = fork)) { 7553 if ($pid) { #parent 7554 # wait; 7555 waitpid $pid, 0; 7556 } else { #child 7557 # note, this exec isn't necessary if 7558 # inactivity_timeout is 0. On the Mac I'd 7559 # suggest, we set it always to 0. 7560 exec $system; 7561 } 7562 } else { 7563 $CPAN::Frontend->myprint("Cannot fork: $!"); 7564 return; 7565 } 7566 }; 7567 alarm 0; 7568 if ($@) { 7569 kill 9, $pid; 7570 waitpid $pid, 0; 7571 my $err = "$@"; 7572 $CPAN::Frontend->myprint($err); 7573 $self->{writemakefile} = CPAN::Distrostatus->new("NO $err"); 7574 $@ = ""; 7575 $self->store_persistent_state; 7576 return $self->goodbye("$system -- TIMED OUT"); 7577 } 7578 } 7579 } else { 7580 if (my $expect_model = $self->_prefs_with_expect("pl")) { 7581 # XXX probably want to check _should_report here and warn 7582 # about not being able to use CPAN::Reporter with expect 7583 $ret = $self->_run_via_expect($system,$expect_model); 7584 if (! defined $ret 7585 && $self->{writemakefile} 7586 && $self->{writemakefile}->failed) { 7587 # timeout 7588 return; 7589 } 7590 } 7591 elsif ( $self->_should_report('pl') ) { 7592 ($output, $ret) = CPAN::Reporter::record_command($system); 7593 CPAN::Reporter::grade_PL( $self, $system, $output, $ret ); 7594 } 7595 else { 7596 $ret = system($system); 7597 } 7598 if ($ret != 0) { 7599 $self->{writemakefile} = CPAN::Distrostatus 7600 ->new("NO '$system' returned status $ret"); 7601 $CPAN::Frontend->mywarn("Warning: No success on command[$system]\n"); 7602 $self->store_persistent_state; 7603 return $self->goodbye("$system -- NOT OK"); 7604 } 7605 } 7606 if (-f "Makefile" || -f "Build") { 7607 $self->{writemakefile} = CPAN::Distrostatus->new("YES"); 7608 delete $self->{make_clean}; # if cleaned before, enable next 7609 } else { 7610 my $makefile = $self->{modulebuild} ? "Build" : "Makefile"; 7611 $self->{writemakefile} = CPAN::Distrostatus 7612 ->new(qq{NO -- No $makefile created}); 7613 $self->store_persistent_state; 7614 return $self->goodbye("$system -- NO $makefile created"); 7615 } 7616 } 7617 if ($CPAN::Signal) { 7618 delete $self->{force_update}; 7619 return; 7620 } 7621 if (my @prereq = $self->unsat_prereq("later")) { 7622 if ($prereq[0][0] eq "perl") { 7623 my $need = "requires perl '$prereq[0][1]'"; 7624 my $id = $self->pretty_id; 7625 $CPAN::Frontend->mywarn("$id $need; you have only $]; giving up\n"); 7626 $self->{make} = CPAN::Distrostatus->new("NO $need"); 7627 $self->store_persistent_state; 7628 return $self->goodbye("[prereq] -- NOT OK"); 7629 } else { 7630 my $follow = eval { $self->follow_prereqs("later",@prereq); }; 7631 if (0) { 7632 } elsif ($follow) { 7633 # signal success to the queuerunner 7634 return 1; 7635 } elsif ($@ && ref $@ && $@->isa("CPAN::Exception::RecursiveDependency")) { 7636 $CPAN::Frontend->mywarn($@); 7637 return $self->goodbye("[depend] -- NOT OK"); 7638 } 7639 } 7640 } 7641 if ($CPAN::Signal) { 7642 delete $self->{force_update}; 7643 return; 7644 } 7645 if (my $commandline = $self->prefs->{make}{commandline}) { 7646 $system = $commandline; 7647 $ENV{PERL} = CPAN::find_perl; 7648 } else { 7649 if ($self->{modulebuild}) { 7650 unless (-f "Build") { 7651 my $cwd = CPAN::anycwd(); 7652 $CPAN::Frontend->mywarn("Alert: no Build file available for 'make $self->{id}'". 7653 " in cwd[$cwd]. Danger, Will Robinson!\n"); 7654 $CPAN::Frontend->mysleep(5); 7655 } 7656 $system = join " ", $self->_build_command(), $CPAN::Config->{mbuild_arg}; 7657 } else { 7658 $system = join " ", $self->_make_command(), $CPAN::Config->{make_arg}; 7659 } 7660 $system =~ s/\s+$//; 7661 my $make_arg = $self->make_x_arg("make"); 7662 $system = sprintf("%s%s", 7663 $system, 7664 $make_arg ? " $make_arg" : "", 7665 ); 7666 } 7667 if (my $env = $self->prefs->{make}{env}) { # overriding the local 7668 # ENV of PL, not the 7669 # outer ENV, but 7670 # unlikely to be a risk 7671 for my $e (keys %$env) { 7672 $ENV{$e} = $env->{$e}; 7673 } 7674 } 7675 my $expect_model = $self->_prefs_with_expect("make"); 7676 my $want_expect = 0; 7677 if ( $expect_model && @{$expect_model->{talk}} ) { 7678 my $can_expect = $CPAN::META->has_inst("Expect"); 7679 if ($can_expect) { 7680 $want_expect = 1; 7681 } else { 7682 $CPAN::Frontend->mywarn("Expect not installed, falling back to ". 7683 "system()\n"); 7684 } 7685 } 7686 my $system_ok; 7687 if ($want_expect) { 7688 # XXX probably want to check _should_report here and 7689 # warn about not being able to use CPAN::Reporter with expect 7690 $system_ok = $self->_run_via_expect($system,$expect_model) == 0; 7691 } 7692 elsif ( $self->_should_report('make') ) { 7693 my ($output, $ret) = CPAN::Reporter::record_command($system); 7694 CPAN::Reporter::grade_make( $self, $system, $output, $ret ); 7695 $system_ok = ! $ret; 7696 } 7697 else { 7698 $system_ok = system($system) == 0; 7699 } 7700 $self->introduce_myself; 7701 if ( $system_ok ) { 7702 $CPAN::Frontend->myprint(" $system -- OK\n"); 7703 $self->{make} = CPAN::Distrostatus->new("YES"); 7704 } else { 7705 $self->{writemakefile} ||= CPAN::Distrostatus->new("YES"); 7706 $self->{make} = CPAN::Distrostatus->new("NO"); 7707 $CPAN::Frontend->mywarn(" $system -- NOT OK\n"); 7708 } 7709 $self->store_persistent_state; 7710 } 7711 7712 # CPAN::Distribution::goodbye ; 7713 sub goodbye { 7714 my($self,$goodbye) = @_; 7715 my $id = $self->pretty_id; 7716 $CPAN::Frontend->mywarn(" $id\n $goodbye\n"); 7717 return; 7718 } 7719 7720 # CPAN::Distribution::_run_via_expect ; 7721 sub _run_via_expect { 7722 my($self,$system,$expect_model) = @_; 7723 CPAN->debug("system[$system]expect_model[$expect_model]") if $CPAN::DEBUG; 7724 if ($CPAN::META->has_inst("Expect")) { 7725 my $expo = Expect->new; # expo Expect object; 7726 $expo->spawn($system); 7727 $expect_model->{mode} ||= "deterministic"; 7728 if ($expect_model->{mode} eq "deterministic") { 7729 return $self->_run_via_expect_deterministic($expo,$expect_model); 7730 } elsif ($expect_model->{mode} eq "anyorder") { 7731 return $self->_run_via_expect_anyorder($expo,$expect_model); 7732 } else { 7733 die "Panic: Illegal expect mode: $expect_model->{mode}"; 7734 } 7735 } else { 7736 $CPAN::Frontend->mywarn("Expect not installed, falling back to system()\n"); 7737 return system($system); 7738 } 7739 } 7740 7741 sub _run_via_expect_anyorder { 7742 my($self,$expo,$expect_model) = @_; 7743 my $timeout = $expect_model->{timeout} || 5; 7744 my $reuse = $expect_model->{reuse}; 7745 my @expectacopy = @{$expect_model->{talk}}; # we trash it! 7746 my $but = ""; 7747 EXPECT: while () { 7748 my($eof,$ran_into_timeout); 7749 my @match = $expo->expect($timeout, 7750 [ eof => sub { 7751 $eof++; 7752 } ], 7753 [ timeout => sub { 7754 $ran_into_timeout++; 7755 } ], 7756 -re => eval"qr{.}", 7757 ); 7758 if ($match[2]) { 7759 $but .= $match[2]; 7760 } 7761 $but .= $expo->clear_accum; 7762 if ($eof) { 7763 $expo->soft_close; 7764 return $expo->exitstatus(); 7765 } elsif ($ran_into_timeout) { 7766 # warn "DEBUG: they are asking a question, but[$but]"; 7767 for (my $i = 0; $i <= $#expectacopy; $i+=2) { 7768 my($next,$send) = @expectacopy[$i,$i+1]; 7769 my $regex = eval "qr{$next}"; 7770 # warn "DEBUG: will compare with regex[$regex]."; 7771 if ($but =~ /$regex/) { 7772 # warn "DEBUG: will send send[$send]"; 7773 $expo->send($send); 7774 # never allow reusing an QA pair unless they told us 7775 splice @expectacopy, $i, 2 unless $reuse; 7776 next EXPECT; 7777 } 7778 } 7779 my $why = "could not answer a question during the dialog"; 7780 $CPAN::Frontend->mywarn("Failing: $why\n"); 7781 $self->{writemakefile} = 7782 CPAN::Distrostatus->new("NO $why"); 7783 return; 7784 } 7785 } 7786 } 7787 7788 sub _run_via_expect_deterministic { 7789 my($self,$expo,$expect_model) = @_; 7790 my $ran_into_timeout; 7791 my $timeout = $expect_model->{timeout} || 15; # currently unsettable 7792 my $expecta = $expect_model->{talk}; 7793 EXPECT: for (my $i = 0; $i <= $#$expecta; $i+=2) { 7794 my($re,$send) = @$expecta[$i,$i+1]; 7795 CPAN->debug("timeout[$timeout]re[$re]") if $CPAN::DEBUG; 7796 my $regex = eval "qr{$re}"; 7797 $expo->expect($timeout, 7798 [ eof => sub { 7799 my $but = $expo->clear_accum; 7800 $CPAN::Frontend->mywarn("EOF (maybe harmless) 7801 expected[$regex]\nbut[$but]\n\n"); 7802 last EXPECT; 7803 } ], 7804 [ timeout => sub { 7805 my $but = $expo->clear_accum; 7806 $CPAN::Frontend->mywarn("TIMEOUT 7807 expected[$regex]\nbut[$but]\n\n"); 7808 $ran_into_timeout++; 7809 } ], 7810 -re => $regex); 7811 if ($ran_into_timeout) { 7812 # note that the caller expects 0 for success 7813 $self->{writemakefile} = 7814 CPAN::Distrostatus->new("NO timeout during expect dialog"); 7815 return; 7816 } 7817 $expo->send($send); 7818 } 7819 $expo->soft_close; 7820 return $expo->exitstatus(); 7821 } 7822 7823 #-> CPAN::Distribution::_validate_distropref 7824 sub _validate_distropref { 7825 my($self,@args) = @_; 7826 if ( 7827 $CPAN::META->has_inst("CPAN::Kwalify") 7828 && 7829 $CPAN::META->has_inst("Kwalify") 7830 ) { 7831 eval {CPAN::Kwalify::_validate("distroprefs",@args);}; 7832 if ($@) { 7833 $CPAN::Frontend->mywarn($@); 7834 } 7835 } else { 7836 CPAN->debug("not validating '@args'") if $CPAN::DEBUG; 7837 } 7838 } 7839 7840 #-> CPAN::Distribution::_find_prefs 7841 sub _find_prefs { 7842 my($self) = @_; 7843 my $distroid = $self->pretty_id; 7844 #CPAN->debug("distroid[$distroid]") if $CPAN::DEBUG; 7845 my $prefs_dir = $CPAN::Config->{prefs_dir}; 7846 return if $prefs_dir =~ /^\s*$/; 7847 eval { File::Path::mkpath($prefs_dir); }; 7848 if ($@) { 7849 $CPAN::Frontend->mydie("Cannot create directory $prefs_dir"); 7850 } 7851 my $yaml_module = CPAN::_yaml_module; 7852 my @extensions; 7853 if ($CPAN::META->has_inst($yaml_module)) { 7854 push @extensions, "yml"; 7855 } else { 7856 my @fallbacks; 7857 if ($CPAN::META->has_inst("Data::Dumper")) { 7858 push @extensions, "dd"; 7859 push @fallbacks, "Data::Dumper"; 7860 } 7861 if ($CPAN::META->has_inst("Storable")) { 7862 push @extensions, "st"; 7863 push @fallbacks, "Storable"; 7864 } 7865 if (@fallbacks) { 7866 local $" = " and "; 7867 unless ($self->{have_complained_about_missing_yaml}++) { 7868 $CPAN::Frontend->mywarn("'$yaml_module' not installed, falling back ". 7869 "to @fallbacks to read prefs '$prefs_dir'\n"); 7870 } 7871 } else { 7872 unless ($self->{have_complained_about_missing_yaml}++) { 7873 $CPAN::Frontend->mywarn("'$yaml_module' not installed, cannot ". 7874 "read prefs '$prefs_dir'\n"); 7875 } 7876 } 7877 } 7878 if (@extensions) { 7879 my $dh = DirHandle->new($prefs_dir) 7880 or die Carp::croak("Couldn't open '$prefs_dir': $!"); 7881 DIRENT: for (sort $dh->read) { 7882 next if $_ eq "." || $_ eq ".."; 7883 my $exte = join "|", @extensions; 7884 next unless /\.($exte)$/; 7885 my $thisexte = $1; 7886 my $abs = File::Spec->catfile($prefs_dir, $_); 7887 if (-f $abs) { 7888 #CPAN->debug(sprintf "abs[%s]", $abs) if $CPAN::DEBUG; 7889 my @distropref; 7890 if ($thisexte eq "yml") { 7891 # need no eval because if we have no YAML we do not try to read *.yml 7892 #CPAN->debug(sprintf "before yaml load abs[%s]", $abs) if $CPAN::DEBUG; 7893 @distropref = @{CPAN->_yaml_loadfile($abs)}; 7894 #CPAN->debug(sprintf "after yaml load abs[%s]", $abs) if $CPAN::DEBUG; 7895 } elsif ($thisexte eq "dd") { 7896 package CPAN::Eval; 7897 no strict; 7898 open FH, "<$abs" or $CPAN::Frontend->mydie("Could not open '$abs': $!"); 7899 local $/; 7900 my $eval = <FH>; 7901 close FH; 7902 eval $eval; 7903 if ($@) { 7904 $CPAN::Frontend->mydie("Error in distroprefs file $_\: $@"); 7905 } 7906 my $i = 1; 7907 while (${"VAR".$i}) { 7908 push @distropref, ${"VAR".$i}; 7909 $i++; 7910 } 7911 } elsif ($thisexte eq "st") { 7912 # eval because Storable is never forward compatible 7913 eval { @distropref = @{scalar Storable::retrieve($abs)}; }; 7914 if ($@) { 7915 $CPAN::Frontend->mywarn("Error reading distroprefs file ". 7916 "$_, skipping\: $@"); 7917 $CPAN::Frontend->mysleep(4); 7918 next DIRENT; 7919 } 7920 } 7921 # $DB::single=1; 7922 #CPAN->debug(sprintf "#distropref[%d]", scalar @distropref) if $CPAN::DEBUG; 7923 ELEMENT: for my $y (0..$#distropref) { 7924 my $distropref = $distropref[$y]; 7925 $self->_validate_distropref($distropref,$abs,$y); 7926 my $match = $distropref->{match}; 7927 unless ($match) { 7928 #CPAN->debug("no 'match' in abs[$abs], skipping") if $CPAN::DEBUG; 7929 next ELEMENT; 7930 } 7931 my $ok = 1; 7932 # do not take the order of C<keys %$match> because 7933 # "module" is by far the slowest 7934 my $saw_valid_subkeys = 0; 7935 for my $sub_attribute (qw(distribution perl perlconfig module)) { 7936 next unless exists $match->{$sub_attribute}; 7937 $saw_valid_subkeys++; 7938 my $qr = eval "qr{$distropref->{match}{$sub_attribute}}"; 7939 if ($sub_attribute eq "module") { 7940 my $okm = 0; 7941 #CPAN->debug(sprintf "distropref[%d]", scalar @distropref) if $CPAN::DEBUG; 7942 my @modules = $self->containsmods; 7943 #CPAN->debug(sprintf "modules[%s]", join(",",@modules)) if $CPAN::DEBUG; 7944 MODULE: for my $module (@modules) { 7945 $okm ||= $module =~ /$qr/; 7946 last MODULE if $okm; 7947 } 7948 $ok &&= $okm; 7949 } elsif ($sub_attribute eq "distribution") { 7950 my $okd = $distroid =~ /$qr/; 7951 $ok &&= $okd; 7952 } elsif ($sub_attribute eq "perl") { 7953 my $okp = CPAN::find_perl =~ /$qr/; 7954 $ok &&= $okp; 7955 } elsif ($sub_attribute eq "perlconfig") { 7956 for my $perlconfigkey (keys %{$match->{perlconfig}}) { 7957 my $perlconfigval = $match->{perlconfig}->{$perlconfigkey}; 7958 # XXX should probably warn if Config does not exist 7959 my $okpc = $Config::Config{$perlconfigkey} =~ /$perlconfigval/; 7960 $ok &&= $okpc; 7961 last if $ok == 0; 7962 } 7963 } else { 7964 $CPAN::Frontend->mydie("Nonconforming .$thisexte file '$abs': ". 7965 "unknown sub_attribut '$sub_attribute'. ". 7966 "Please ". 7967 "remove, cannot continue."); 7968 } 7969 last if $ok == 0; # short circuit 7970 } 7971 unless ($saw_valid_subkeys) { 7972 $CPAN::Frontend->mydie("Nonconforming .$thisexte file '$abs': ". 7973 "missing match/* subattribute. ". 7974 "Please ". 7975 "remove, cannot continue."); 7976 } 7977 #CPAN->debug(sprintf "ok[%d]", $ok) if $CPAN::DEBUG; 7978 if ($ok) { 7979 return { 7980 prefs => $distropref, 7981 prefs_file => $abs, 7982 prefs_file_doc => $y, 7983 }; 7984 } 7985 7986 } 7987 } 7988 } 7989 $dh->close; 7990 } 7991 return; 7992 } 7993 7994 # CPAN::Distribution::prefs 7995 sub prefs { 7996 my($self) = @_; 7997 if (exists $self->{negative_prefs_cache} 7998 && 7999 $self->{negative_prefs_cache} != $CPAN::CurrentCommandId 8000 ) { 8001 delete $self->{negative_prefs_cache}; 8002 delete $self->{prefs}; 8003 } 8004 if (exists $self->{prefs}) { 8005 return $self->{prefs}; # XXX comment out during debugging 8006 } 8007 if ($CPAN::Config->{prefs_dir}) { 8008 CPAN->debug("prefs_dir[$CPAN::Config->{prefs_dir}]") if $CPAN::DEBUG; 8009 my $prefs = $self->_find_prefs(); 8010 $prefs ||= ""; # avoid warning next line 8011 CPAN->debug("prefs[$prefs]") if $CPAN::DEBUG; 8012 if ($prefs) { 8013 for my $x (qw(prefs prefs_file prefs_file_doc)) { 8014 $self->{$x} = $prefs->{$x}; 8015 } 8016 my $bs = sprintf( 8017 "%s[%s]", 8018 File::Basename::basename($self->{prefs_file}), 8019 $self->{prefs_file_doc}, 8020 ); 8021 my $filler1 = "_" x 22; 8022 my $filler2 = int(66 - length($bs))/2; 8023 $filler2 = 0 if $filler2 < 0; 8024 $filler2 = " " x $filler2; 8025 $CPAN::Frontend->myprint(" 8026 $filler1 D i s t r o P r e f s $filler1 8027 $filler2 $bs $filler2 8028 "); 8029 $CPAN::Frontend->mysleep(1); 8030 return $self->{prefs}; 8031 } 8032 } 8033 $self->{negative_prefs_cache} = $CPAN::CurrentCommandId; 8034 return $self->{prefs} = +{}; 8035 } 8036 8037 # CPAN::Distribution::make_x_arg 8038 sub make_x_arg { 8039 my($self, $whixh) = @_; 8040 my $make_x_arg; 8041 my $prefs = $self->prefs; 8042 if ( 8043 $prefs 8044 && exists $prefs->{$whixh} 8045 && exists $prefs->{$whixh}{args} 8046 && $prefs->{$whixh}{args} 8047 ) { 8048 $make_x_arg = join(" ", 8049 map {CPAN::HandleConfig 8050 ->safe_quote($_)} @{$prefs->{$whixh}{args}}, 8051 ); 8052 } 8053 my $what = sprintf "make%s_arg", $whixh eq "make" ? "" : $whixh; 8054 $make_x_arg ||= $CPAN::Config->{$what}; 8055 return $make_x_arg; 8056 } 8057 8058 # CPAN::Distribution::_make_command 8059 sub _make_command { 8060 my ($self) = @_; 8061 if ($self) { 8062 return 8063 CPAN::HandleConfig 8064 ->safe_quote( 8065 CPAN::HandleConfig->prefs_lookup($self, 8066 q{make}) 8067 || $Config::Config{make} 8068 || 'make' 8069 ); 8070 } else { 8071 # Old style call, without object. Deprecated 8072 Carp::confess("CPAN::_make_command() used as function. Don't Do That."); 8073 return 8074 safe_quote(undef, 8075 CPAN::HandleConfig->prefs_lookup($self,q{make}) 8076 || $CPAN::Config->{make} 8077 || $Config::Config{make} 8078 || 'make'); 8079 } 8080 } 8081 8082 #-> sub CPAN::Distribution::follow_prereqs ; 8083 sub follow_prereqs { 8084 my($self) = shift; 8085 my($slot) = shift; 8086 my(@prereq_tuples) = grep {$_->[0] ne "perl"} @_; 8087 return unless @prereq_tuples; 8088 my @prereq = map { $_->[0] } @prereq_tuples; 8089 my $pretty_id = $self->pretty_id; 8090 my %map = ( 8091 b => "build_requires", 8092 r => "requires", 8093 c => "commandline", 8094 ); 8095 my($filler1,$filler2,$filler3,$filler4); 8096 # $DB::single=1; 8097 my $unsat = "Unsatisfied dependencies detected during"; 8098 my $w = length($unsat) > length($pretty_id) ? length($unsat) : length($pretty_id); 8099 { 8100 my $r = int(($w - length($unsat))/2); 8101 my $l = $w - length($unsat) - $r; 8102 $filler1 = "-"x4 . " "x$l; 8103 $filler2 = " "x$r . "-"x4 . "\n"; 8104 } 8105 { 8106 my $r = int(($w - length($pretty_id))/2); 8107 my $l = $w - length($pretty_id) - $r; 8108 $filler3 = "-"x4 . " "x$l; 8109 $filler4 = " "x$r . "-"x4 . "\n"; 8110 } 8111 $CPAN::Frontend-> 8112 myprint("$filler1 $unsat $filler2". 8113 "$filler3 $pretty_id $filler4". 8114 join("", map {" $_->[0] \[$map{$_->[1]}]\n"} @prereq_tuples), 8115 ); 8116 my $follow = 0; 8117 if ($CPAN::Config->{prerequisites_policy} eq "follow") { 8118 $follow = 1; 8119 } elsif ($CPAN::Config->{prerequisites_policy} eq "ask") { 8120 my $answer = CPAN::Shell::colorable_makemaker_prompt( 8121 "Shall I follow them and prepend them to the queue 8122 of modules we are processing right now?", "yes"); 8123 $follow = $answer =~ /^\s*y/i; 8124 } else { 8125 local($") = ", "; 8126 $CPAN::Frontend-> 8127 myprint(" Ignoring dependencies on modules @prereq\n"); 8128 } 8129 if ($follow) { 8130 my $id = $self->id; 8131 # color them as dirty 8132 for my $p (@prereq) { 8133 # warn "calling color_cmd_tmps(0,1)"; 8134 my $any = CPAN::Shell->expandany($p); 8135 $self->{$slot . "_for"}{$any->id}++; 8136 if ($any) { 8137 $any->color_cmd_tmps(0,2); 8138 } else { 8139 $CPAN::Frontend->mywarn("Warning (maybe a bug): Cannot expand prereq '$p'\n"); 8140 $CPAN::Frontend->mysleep(2); 8141 } 8142 } 8143 # queue them and re-queue yourself 8144 CPAN::Queue->jumpqueue({qmod => $id, reqtype => $self->{reqtype}}, 8145 map {+{qmod=>$_->[0],reqtype=>$_->[1]}} reverse @prereq_tuples); 8146 $self->{$slot} = "Delayed until after prerequisites"; 8147 return 1; # signal success to the queuerunner 8148 } 8149 return; 8150 } 8151 8152 #-> sub CPAN::Distribution::unsat_prereq ; 8153 # return ([Foo=>1],[Bar=>1.2]) for normal modules 8154 # return ([perl=>5.008]) if we need a newer perl than we are running under 8155 sub unsat_prereq { 8156 my($self,$slot) = @_; 8157 my(%merged,$prereq_pm); 8158 my $prefs_depends = $self->prefs->{depends}||{}; 8159 if ($slot eq "configure_requires_later") { 8160 my $meta_yml = $self->parse_meta_yml(); 8161 %merged = (%{$meta_yml->{configure_requires}||{}}, 8162 %{$prefs_depends->{configure_requires}||{}}); 8163 $prereq_pm = {}; # configure_requires defined as "b" 8164 } elsif ($slot eq "later") { 8165 my $prereq_pm_0 = $self->prereq_pm || {}; 8166 for my $reqtype (qw(requires build_requires)) { 8167 $prereq_pm->{$reqtype} = {%{$prereq_pm_0->{$reqtype}||{}}}; # copy to not pollute it 8168 for my $k (keys %{$prefs_depends->{$reqtype}||{}}) { 8169 $prereq_pm->{$reqtype}{$k} = $prefs_depends->{$reqtype}{$k}; 8170 } 8171 } 8172 %merged = (%{$prereq_pm->{requires}||{}},%{$prereq_pm->{build_requires}||{}}); 8173 } else { 8174 die "Panic: illegal slot '$slot'"; 8175 } 8176 my(@need); 8177 my @merged = %merged; 8178 CPAN->debug("all merged_prereqs[@merged]") if $CPAN::DEBUG; 8179 NEED: while (my($need_module, $need_version) = each %merged) { 8180 my($available_version,$available_file,$nmo); 8181 if ($need_module eq "perl") { 8182 $available_version = $]; 8183 $available_file = CPAN::find_perl; 8184 } else { 8185 $nmo = $CPAN::META->instance("CPAN::Module",$need_module); 8186 next if $nmo->uptodate; 8187 $available_file = $nmo->available_file; 8188 8189 # if they have not specified a version, we accept any installed one 8190 if (defined $available_file 8191 and ( # a few quick shortcurcuits 8192 not defined $need_version 8193 or $need_version eq '0' # "==" would trigger warning when not numeric 8194 or $need_version eq "undef" 8195 )) { 8196 next NEED; 8197 } 8198 8199 $available_version = $nmo->available_version; 8200 } 8201 8202 # We only want to install prereqs if either they're not installed 8203 # or if the installed version is too old. We cannot omit this 8204 # check, because if 'force' is in effect, nobody else will check. 8205 if (defined $available_file) { 8206 my(@all_requirements) = split /\s*,\s*/, $need_version; 8207 local($^W) = 0; 8208 my $ok = 0; 8209 RQ: for my $rq (@all_requirements) { 8210 if ($rq =~ s|>=\s*||) { 8211 } elsif ($rq =~ s|>\s*||) { 8212 # 2005-12: one user 8213 if (CPAN::Version->vgt($available_version,$rq)) { 8214 $ok++; 8215 } 8216 next RQ; 8217 } elsif ($rq =~ s|!=\s*||) { 8218 # 2005-12: no user 8219 if (CPAN::Version->vcmp($available_version,$rq)) { 8220 $ok++; 8221 next RQ; 8222 } else { 8223 last RQ; 8224 } 8225 } elsif ($rq =~ m|<=?\s*|) { 8226 # 2005-12: no user 8227 $CPAN::Frontend->mywarn("Downgrading not supported (rq[$rq])\n"); 8228 $ok++; 8229 next RQ; 8230 } 8231 if (! CPAN::Version->vgt($rq, $available_version)) { 8232 $ok++; 8233 } 8234 CPAN->debug(sprintf("need_module[%s]available_file[%s]". 8235 "available_version[%s]rq[%s]ok[%d]", 8236 $need_module, 8237 $available_file, 8238 $available_version, 8239 CPAN::Version->readable($rq), 8240 $ok, 8241 )) if $CPAN::DEBUG; 8242 } 8243 next NEED if $ok == @all_requirements; 8244 } 8245 8246 if ($need_module eq "perl") { 8247 return ["perl", $need_version]; 8248 } 8249 $self->{sponsored_mods}{$need_module} ||= 0; 8250 CPAN->debug("need_module[$need_module]s/s/n[$self->{sponsored_mods}{$need_module}]") if $CPAN::DEBUG; 8251 if ($self->{sponsored_mods}{$need_module}++) { 8252 # We have already sponsored it and for some reason it's still 8253 # not available. So we do ... what?? 8254 8255 # if we push it again, we have a potential infinite loop 8256 8257 # The following "next" was a very problematic construct. 8258 # It helped a lot but broke some day and had to be 8259 # replaced. 8260 8261 # We must be able to deal with modules that come again and 8262 # again as a prereq and have themselves prereqs and the 8263 # queue becomes long but finally we would find the correct 8264 # order. The RecursiveDependency check should trigger a 8265 # die when it's becoming too weird. Unfortunately removing 8266 # this next breaks many other things. 8267 8268 # The bug that brought this up is described in Todo under 8269 # "5.8.9 cannot install Compress::Zlib" 8270 8271 # next; # this is the next that had to go away 8272 8273 # The following "next NEED" are fine and the error message 8274 # explains well what is going on. For example when the DBI 8275 # fails and consequently DBD::SQLite fails and now we are 8276 # processing CPAN::SQLite. Then we must have a "next" for 8277 # DBD::SQLite. How can we get it and how can we identify 8278 # all other cases we must identify? 8279 8280 my $do = $nmo->distribution; 8281 next NEED unless $do; # not on CPAN 8282 if (CPAN::Version->vcmp($need_version, $nmo->ro->{CPAN_VERSION}) > 0){ 8283 $CPAN::Frontend->mywarn("Warning: Prerequisite ". 8284 "'$need_module => $need_version' ". 8285 "for '$self->{ID}' seems ". 8286 "not available according to the indexes\n" 8287 ); 8288 next NEED; 8289 } 8290 NOSAYER: for my $nosayer ( 8291 "unwrapped", 8292 "writemakefile", 8293 "signature_verify", 8294 "make", 8295 "make_test", 8296 "install", 8297 "make_clean", 8298 ) { 8299 if ($do->{$nosayer}) { 8300 if (UNIVERSAL::can($do->{$nosayer},"failed") ? 8301 $do->{$nosayer}->failed : 8302 $do->{$nosayer} =~ /^NO/) { 8303 if ($nosayer eq "make_test" 8304 && 8305 $do->{make_test}{COMMANDID} != $CPAN::CurrentCommandId 8306 ) { 8307 next NOSAYER; 8308 } 8309 $CPAN::Frontend->mywarn("Warning: Prerequisite ". 8310 "'$need_module => $need_version' ". 8311 "for '$self->{ID}' failed when ". 8312 "processing '$do->{ID}' with ". 8313 "'$nosayer => $do->{$nosayer}'. Continuing, ". 8314 "but chances to succeed are limited.\n" 8315 ); 8316 next NEED; 8317 } else { # the other guy succeeded 8318 if ($nosayer eq "install") { 8319 # we had this with 8320 # DMAKI/DateTime-Calendar-Chinese-0.05.tar.gz 8321 # 2007-03 8322 $CPAN::Frontend->mywarn("Warning: Prerequisite ". 8323 "'$need_module => $need_version' ". 8324 "for '$self->{ID}' already installed ". 8325 "but installation looks suspicious. ". 8326 "Skipping another installation attempt, ". 8327 "to prevent looping endlessly.\n" 8328 ); 8329 next NEED; 8330 } 8331 } 8332 } 8333 } 8334 } 8335 my $needed_as = exists $prereq_pm->{requires}{$need_module} ? "r" : "b"; 8336 push @need, [$need_module,$needed_as]; 8337 } 8338 my @unfolded = map { "[".join(",",@$_)."]" } @need; 8339 CPAN->debug("returning from unsat_prereq[@unfolded]") if $CPAN::DEBUG; 8340 @need; 8341 } 8342 8343 #-> sub CPAN::Distribution::read_yaml ; 8344 sub read_yaml { 8345 my($self) = @_; 8346 return $self->{yaml_content} if exists $self->{yaml_content}; 8347 my $build_dir = $self->{build_dir}; 8348 my $yaml = File::Spec->catfile($build_dir,"META.yml"); 8349 $self->debug("yaml[$yaml]") if $CPAN::DEBUG; 8350 return unless -f $yaml; 8351 eval { $self->{yaml_content} = CPAN->_yaml_loadfile($yaml)->[0]; }; 8352 if ($@) { 8353 $CPAN::Frontend->mywarn("Could not read ". 8354 "'$yaml'. Falling back to other ". 8355 "methods to determine prerequisites\n"); 8356 return $self->{yaml_content} = undef; # if we die, then we 8357 # cannot read YAML's own 8358 # META.yml 8359 } 8360 # not "authoritative" 8361 if (not exists $self->{yaml_content}{dynamic_config} 8362 or $self->{yaml_content}{dynamic_config} 8363 ) { 8364 $self->{yaml_content} = undef; 8365 } 8366 $self->debug(sprintf "yaml_content[%s]", $self->{yaml_content} || "UNDEF") 8367 if $CPAN::DEBUG; 8368 return $self->{yaml_content}; 8369 } 8370 8371 #-> sub CPAN::Distribution::prereq_pm ; 8372 sub prereq_pm { 8373 my($self) = @_; 8374 $self->{prereq_pm_detected} ||= 0; 8375 CPAN->debug("ID[$self->{ID}]prereq_pm_detected[$self->{prereq_pm_detected}]") if $CPAN::DEBUG; 8376 return $self->{prereq_pm} if $self->{prereq_pm_detected}; 8377 return unless $self->{writemakefile} # no need to have succeeded 8378 # but we must have run it 8379 || $self->{modulebuild}; 8380 CPAN->debug(sprintf "writemakefile[%s]modulebuild[%s]", 8381 $self->{writemakefile}||"", 8382 $self->{modulebuild}||"", 8383 ) if $CPAN::DEBUG; 8384 my($req,$breq); 8385 if (my $yaml = $self->read_yaml) { # often dynamic_config prevents a result here 8386 $req = $yaml->{requires} || {}; 8387 $breq = $yaml->{build_requires} || {}; 8388 undef $req unless ref $req eq "HASH" && %$req; 8389 if ($req) { 8390 if ($yaml->{generated_by} && 8391 $yaml->{generated_by} =~ /ExtUtils::MakeMaker version ([\d\._]+)/) { 8392 my $eummv = do { local $^W = 0; $1+0; }; 8393 if ($eummv < 6.2501) { 8394 # thanks to Slaven for digging that out: MM before 8395 # that could be wrong because it could reflect a 8396 # previous release 8397 undef $req; 8398 } 8399 } 8400 my $areq; 8401 my $do_replace; 8402 while (my($k,$v) = each %{$req||{}}) { 8403 if ($v =~ /\d/) { 8404 $areq->{$k} = $v; 8405 } elsif ($k =~ /[A-Za-z]/ && 8406 $v =~ /[A-Za-z]/ && 8407 $CPAN::META->exists("Module",$v) 8408 ) { 8409 $CPAN::Frontend->mywarn("Suspicious key-value pair in META.yml's ". 8410 "requires hash: $k => $v; I'll take both ". 8411 "key and value as a module name\n"); 8412 $CPAN::Frontend->mysleep(1); 8413 $areq->{$k} = 0; 8414 $areq->{$v} = 0; 8415 $do_replace++; 8416 } 8417 } 8418 $req = $areq if $do_replace; 8419 } 8420 } 8421 unless ($req || $breq) { 8422 my $build_dir = $self->{build_dir} or die "Panic: no build_dir?"; 8423 my $makefile = File::Spec->catfile($build_dir,"Makefile"); 8424 my $fh; 8425 if (-f $makefile 8426 and 8427 $fh = FileHandle->new("<$makefile\0")) { 8428 CPAN->debug("Getting prereq from Makefile") if $CPAN::DEBUG; 8429 local($/) = "\n"; 8430 while (<$fh>) { 8431 last if /MakeMaker post_initialize section/; 8432 my($p) = m{^[\#] 8433 \s+PREREQ_PM\s+=>\s+(.+) 8434 }x; 8435 next unless $p; 8436 # warn "Found prereq expr[$p]"; 8437 8438 # Regexp modified by A.Speer to remember actual version of file 8439 # PREREQ_PM hash key wants, then add to 8440 while ( $p =~ m/(?:\s)([\w\:]+)=>(q\[.*?\]|undef),?/g ) { 8441 # In case a prereq is mentioned twice, complain. 8442 if ( defined $req->{$1} ) { 8443 warn "Warning: PREREQ_PM mentions $1 more than once, ". 8444 "last mention wins"; 8445 } 8446 my($m,$n) = ($1,$2); 8447 if ($n =~ /^q\[(.*?)\]$/) { 8448 $n = $1; 8449 } 8450 $req->{$m} = $n; 8451 } 8452 last; 8453 } 8454 } 8455 } 8456 unless ($req || $breq) { 8457 my $build_dir = $self->{build_dir} or die "Panic: no build_dir?"; 8458 my $buildfile = File::Spec->catfile($build_dir,"Build"); 8459 if (-f $buildfile) { 8460 CPAN->debug("Found '$buildfile'") if $CPAN::DEBUG; 8461 my $build_prereqs = File::Spec->catfile($build_dir,"_build","prereqs"); 8462 if (-f $build_prereqs) { 8463 CPAN->debug("Getting prerequisites from '$build_prereqs'") if $CPAN::DEBUG; 8464 my $content = do { local *FH; 8465 open FH, $build_prereqs 8466 or $CPAN::Frontend->mydie("Could not open ". 8467 "'$build_prereqs': $!"); 8468 local $/; 8469 <FH>; 8470 }; 8471 my $bphash = eval $content; 8472 if ($@) { 8473 } else { 8474 $req = $bphash->{requires} || +{}; 8475 $breq = $bphash->{build_requires} || +{}; 8476 } 8477 } 8478 } 8479 } 8480 if (-f "Build.PL" 8481 && ! -f "Makefile.PL" 8482 && ! exists $req->{"Module::Build"} 8483 && ! $CPAN::META->has_inst("Module::Build")) { 8484 $CPAN::Frontend->mywarn(" Warning: CPAN.pm discovered Module::Build as ". 8485 "undeclared prerequisite.\n". 8486 " Adding it now as such.\n" 8487 ); 8488 $CPAN::Frontend->mysleep(5); 8489 $req->{"Module::Build"} = 0; 8490 delete $self->{writemakefile}; 8491 } 8492 if ($req || $breq) { 8493 $self->{prereq_pm_detected}++; 8494 return $self->{prereq_pm} = { requires => $req, build_requires => $breq }; 8495 } 8496 } 8497 8498 #-> sub CPAN::Distribution::test ; 8499 sub test { 8500 my($self) = @_; 8501 if (my $goto = $self->prefs->{goto}) { 8502 return $self->goto($goto); 8503 } 8504 $self->make; 8505 if ($CPAN::Signal) { 8506 delete $self->{force_update}; 8507 return; 8508 } 8509 # warn "XDEBUG: checking for notest: $self->{notest} $self"; 8510 if ($self->{notest}) { 8511 $CPAN::Frontend->myprint("Skipping test because of notest pragma\n"); 8512 return 1; 8513 } 8514 8515 my $make = $self->{modulebuild} ? "Build" : "make"; 8516 8517 local $ENV{PERL5LIB} = defined($ENV{PERL5LIB}) 8518 ? $ENV{PERL5LIB} 8519 : ($ENV{PERLLIB} || ""); 8520 8521 $CPAN::META->set_perl5lib; 8522 local $ENV{MAKEFLAGS}; # protect us from outer make calls 8523 8524 $CPAN::Frontend->myprint("Running $make test\n"); 8525 8526 EXCUSE: { 8527 my @e; 8528 if ($self->{make} or $self->{later}) { 8529 # go ahead 8530 } else { 8531 push @e, 8532 "Make had some problems, won't test"; 8533 } 8534 8535 exists $self->{make} and 8536 ( 8537 UNIVERSAL::can($self->{make},"failed") ? 8538 $self->{make}->failed : 8539 $self->{make} =~ /^NO/ 8540 ) and push @e, "Can't test without successful make"; 8541 $self->{badtestcnt} ||= 0; 8542 if ($self->{badtestcnt} > 0) { 8543 require Data::Dumper; 8544 CPAN->debug(sprintf "NOREPEAT[%s]", Data::Dumper::Dumper($self)) if $CPAN::DEBUG; 8545 push @e, "Won't repeat unsuccessful test during this command"; 8546 } 8547 8548 push @e, $self->{later} if $self->{later}; 8549 push @e, $self->{configure_requires_later} if $self->{configure_requires_later}; 8550 8551 if (exists $self->{build_dir}) { 8552 if (exists $self->{make_test}) { 8553 if ( 8554 UNIVERSAL::can($self->{make_test},"failed") ? 8555 $self->{make_test}->failed : 8556 $self->{make_test} =~ /^NO/ 8557 ) { 8558 if ( 8559 UNIVERSAL::can($self->{make_test},"commandid") 8560 && 8561 $self->{make_test}->commandid == $CPAN::CurrentCommandId 8562 ) { 8563 push @e, "Has already been tested within this command"; 8564 } 8565 } else { 8566 push @e, "Has already been tested successfully"; 8567 } 8568 } 8569 } elsif (!@e) { 8570 push @e, "Has no own directory"; 8571 } 8572 $CPAN::Frontend->myprint(join "", map {" $_\n"} @e) and return if @e; 8573 unless (chdir $self->{build_dir}) { 8574 push @e, "Couldn't chdir to '$self->{build_dir}': $!"; 8575 } 8576 $CPAN::Frontend->mywarn(join "", map {" $_\n"} @e) and return if @e; 8577 } 8578 $self->debug("Changed directory to $self->{build_dir}") 8579 if $CPAN::DEBUG; 8580 8581 if ($^O eq 'MacOS') { 8582 Mac::BuildTools::make_test($self); 8583 return; 8584 } 8585 8586 if ($self->{modulebuild}) { 8587 my $v = CPAN::Shell->expand("Module","Test::Harness")->inst_version; 8588 if (CPAN::Version->vlt($v,2.62)) { 8589 $CPAN::Frontend->mywarn(qq{The version of your Test::Harness is only 8590 '$v', you need at least '2.62'. Please upgrade your Test::Harness.\n}); 8591 $self->{make_test} = CPAN::Distrostatus->new("NO Test::Harness too old"); 8592 return; 8593 } 8594 } 8595 8596 my $system; 8597 my $prefs_test = $self->prefs->{test}; 8598 if (my $commandline 8599 = exists $prefs_test->{commandline} ? $prefs_test->{commandline} : "") { 8600 $system = $commandline; 8601 $ENV{PERL} = CPAN::find_perl; 8602 } elsif ($self->{modulebuild}) { 8603 $system = sprintf "%s test", $self->_build_command(); 8604 } else { 8605 $system = join " ", $self->_make_command(), "test"; 8606 } 8607 my $make_test_arg = $self->make_x_arg("test"); 8608 $system = sprintf("%s%s", 8609 $system, 8610 $make_test_arg ? " $make_test_arg" : "", 8611 ); 8612 my($tests_ok); 8613 my %env; 8614 while (my($k,$v) = each %ENV) { 8615 next unless defined $v; 8616 $env{$k} = $v; 8617 } 8618 local %ENV = %env; 8619 if (my $env = $self->prefs->{test}{env}) { 8620 for my $e (keys %$env) { 8621 $ENV{$e} = $env->{$e}; 8622 } 8623 } 8624 my $expect_model = $self->_prefs_with_expect("test"); 8625 my $want_expect = 0; 8626 if ( $expect_model && @{$expect_model->{talk}} ) { 8627 my $can_expect = $CPAN::META->has_inst("Expect"); 8628 if ($can_expect) { 8629 $want_expect = 1; 8630 } else { 8631 $CPAN::Frontend->mywarn("Expect not installed, falling back to ". 8632 "testing without\n"); 8633 } 8634 } 8635 if ($want_expect) { 8636 if ($self->_should_report('test')) { 8637 $CPAN::Frontend->mywarn("Reporting via CPAN::Reporter is currently ". 8638 "not supported when distroprefs specify ". 8639 "an interactive test\n"); 8640 } 8641 $tests_ok = $self->_run_via_expect($system,$expect_model) == 0; 8642 } elsif ( $self->_should_report('test') ) { 8643 $tests_ok = CPAN::Reporter::test($self, $system); 8644 } else { 8645 $tests_ok = system($system) == 0; 8646 } 8647 $self->introduce_myself; 8648 if ( $tests_ok ) { 8649 { 8650 my @prereq; 8651 8652 # local $CPAN::DEBUG = 16; # Distribution 8653 for my $m (keys %{$self->{sponsored_mods}}) { 8654 next unless $self->{sponsored_mods}{$m} > 0; 8655 my $m_obj = CPAN::Shell->expand("Module",$m) or next; 8656 # XXX we need available_version which reflects 8657 # $ENV{PERL5LIB} so that already tested but not yet 8658 # installed modules are counted. 8659 my $available_version = $m_obj->available_version; 8660 my $available_file = $m_obj->available_file; 8661 if ($available_version && 8662 !CPAN::Version->vlt($available_version,$self->{prereq_pm}{$m}) 8663 ) { 8664 CPAN->debug("m[$m] good enough available_version[$available_version]") 8665 if $CPAN::DEBUG; 8666 } elsif ($available_file 8667 && ( 8668 !$self->{prereq_pm}{$m} 8669 || 8670 $self->{prereq_pm}{$m} == 0 8671 ) 8672 ) { 8673 # lex Class::Accessor::Chained::Fast which has no $VERSION 8674 CPAN->debug("m[$m] have available_file[$available_file]") 8675 if $CPAN::DEBUG; 8676 } else { 8677 push @prereq, $m; 8678 } 8679 } 8680 if (@prereq) { 8681 my $cnt = @prereq; 8682 my $which = join ",", @prereq; 8683 my $but = $cnt == 1 ? "one dependency not OK ($which)" : 8684 "$cnt dependencies missing ($which)"; 8685 $CPAN::Frontend->mywarn("Tests succeeded but $but\n"); 8686 $self->{make_test} = CPAN::Distrostatus->new("NO $but"); 8687 $self->store_persistent_state; 8688 return $self->goodbye("[dependencies] -- NA"); 8689 } 8690 } 8691 8692 $CPAN::Frontend->myprint(" $system -- OK\n"); 8693 $self->{make_test} = CPAN::Distrostatus->new("YES"); 8694 $CPAN::META->is_tested($self->{build_dir},$self->{make_test}{TIME}); 8695 # probably impossible to need the next line because badtestcnt 8696 # has a lifespan of one command 8697 delete $self->{badtestcnt}; 8698 } else { 8699 $self->{make_test} = CPAN::Distrostatus->new("NO"); 8700 $self->{badtestcnt}++; 8701 $CPAN::Frontend->mywarn(" $system -- NOT OK\n"); 8702 CPAN::Shell->optprint 8703 ("hint", 8704 sprintf 8705 ("//hint// to see the cpan-testers results for installing this module, try: 8706 reports %s\n", 8707 $self->pretty_id)); 8708 } 8709 $self->store_persistent_state; 8710 } 8711 8712 sub _prefs_with_expect { 8713 my($self,$where) = @_; 8714 return unless my $prefs = $self->prefs; 8715 return unless my $where_prefs = $prefs->{$where}; 8716 if ($where_prefs->{expect}) { 8717 return { 8718 mode => "deterministic", 8719 timeout => 15, 8720 talk => $where_prefs->{expect}, 8721 }; 8722 } elsif ($where_prefs->{"eexpect"}) { 8723 return $where_prefs->{"eexpect"}; 8724 } 8725 return; 8726 } 8727 8728 #-> sub CPAN::Distribution::clean ; 8729 sub clean { 8730 my($self) = @_; 8731 my $make = $self->{modulebuild} ? "Build" : "make"; 8732 $CPAN::Frontend->myprint("Running $make clean\n"); 8733 unless (exists $self->{archived}) { 8734 $CPAN::Frontend->mywarn("Distribution seems to have never been unzipped". 8735 "/untarred, nothing done\n"); 8736 return 1; 8737 } 8738 unless (exists $self->{build_dir}) { 8739 $CPAN::Frontend->mywarn("Distribution has no own directory, nothing to do.\n"); 8740 return 1; 8741 } 8742 if (exists $self->{writemakefile} 8743 and $self->{writemakefile}->failed 8744 ) { 8745 $CPAN::Frontend->mywarn("No Makefile, don't know how to 'make clean'\n"); 8746 return 1; 8747 } 8748 EXCUSE: { 8749 my @e; 8750 exists $self->{make_clean} and $self->{make_clean} eq "YES" and 8751 push @e, "make clean already called once"; 8752 $CPAN::Frontend->myprint(join "", map {" $_\n"} @e) and return if @e; 8753 } 8754 chdir $self->{build_dir} or 8755 Carp::confess("Couldn't chdir to $self->{build_dir}: $!"); 8756 $self->debug("Changed directory to $self->{build_dir}") if $CPAN::DEBUG; 8757 8758 if ($^O eq 'MacOS') { 8759 Mac::BuildTools::make_clean($self); 8760 return; 8761 } 8762 8763 my $system; 8764 if ($self->{modulebuild}) { 8765 unless (-f "Build") { 8766 my $cwd = CPAN::anycwd(); 8767 $CPAN::Frontend->mywarn("Alert: no Build file available for 'clean $self->{id}". 8768 " in cwd[$cwd]. Danger, Will Robinson!"); 8769 $CPAN::Frontend->mysleep(5); 8770 } 8771 $system = sprintf "%s clean", $self->_build_command(); 8772 } else { 8773 $system = join " ", $self->_make_command(), "clean"; 8774 } 8775 my $system_ok = system($system) == 0; 8776 $self->introduce_myself; 8777 if ( $system_ok ) { 8778 $CPAN::Frontend->myprint(" $system -- OK\n"); 8779 8780 # $self->force; 8781 8782 # Jost Krieger pointed out that this "force" was wrong because 8783 # it has the effect that the next "install" on this distribution 8784 # will untar everything again. Instead we should bring the 8785 # object's state back to where it is after untarring. 8786 8787 for my $k (qw( 8788 force_update 8789 install 8790 writemakefile 8791 make 8792 make_test 8793 )) { 8794 delete $self->{$k}; 8795 } 8796 $self->{make_clean} = CPAN::Distrostatus->new("YES"); 8797 8798 } else { 8799 # Hmmm, what to do if make clean failed? 8800 8801 $self->{make_clean} = CPAN::Distrostatus->new("NO"); 8802 $CPAN::Frontend->mywarn(qq{ $system -- NOT OK\n}); 8803 8804 # 2006-02-27: seems silly to me to force a make now 8805 # $self->force("make"); # so that this directory won't be used again 8806 8807 } 8808 $self->store_persistent_state; 8809 } 8810 8811 #-> sub CPAN::Distribution::goto ; 8812 sub goto { 8813 my($self,$goto) = @_; 8814 $goto = $self->normalize($goto); 8815 my $why = sprintf( 8816 "Goto '$goto' via prefs file '%s' doc %d", 8817 $self->{prefs_file}, 8818 $self->{prefs_file_doc}, 8819 ); 8820 $self->{unwrapped} = CPAN::Distrostatus->new("NO $why"); 8821 # 2007-07-16 akoenig : Better than NA would be if we could inherit 8822 # the status of the $goto distro but given the exceptional nature 8823 # of 'goto' I feel reluctant to implement it 8824 my $goodbye_message = "[goto] -- NA $why"; 8825 $self->goodbye($goodbye_message); 8826 8827 # inject into the queue 8828 8829 CPAN::Queue->delete($self->id); 8830 CPAN::Queue->jumpqueue({qmod => $goto, reqtype => $self->{reqtype}}); 8831 8832 # and run where we left off 8833 8834 my($method) = (caller(1))[3]; 8835 CPAN->instance("CPAN::Distribution",$goto)->$method(); 8836 CPAN::Queue->delete_first($goto); 8837 } 8838 8839 #-> sub CPAN::Distribution::install ; 8840 sub install { 8841 my($self) = @_; 8842 if (my $goto = $self->prefs->{goto}) { 8843 return $self->goto($goto); 8844 } 8845 # $DB::single=1; 8846 unless ($self->{badtestcnt}) { 8847 $self->test; 8848 } 8849 if ($CPAN::Signal) { 8850 delete $self->{force_update}; 8851 return; 8852 } 8853 my $make = $self->{modulebuild} ? "Build" : "make"; 8854 $CPAN::Frontend->myprint("Running $make install\n"); 8855 EXCUSE: { 8856 my @e; 8857 if ($self->{make} or $self->{later}) { 8858 # go ahead 8859 } else { 8860 push @e, 8861 "Make had some problems, won't install"; 8862 } 8863 8864 exists $self->{make} and 8865 ( 8866 UNIVERSAL::can($self->{make},"failed") ? 8867 $self->{make}->failed : 8868 $self->{make} =~ /^NO/ 8869 ) and 8870 push @e, "Make had returned bad status, install seems impossible"; 8871 8872 if (exists $self->{build_dir}) { 8873 } elsif (!@e) { 8874 push @e, "Has no own directory"; 8875 } 8876 8877 if (exists $self->{make_test} and 8878 ( 8879 UNIVERSAL::can($self->{make_test},"failed") ? 8880 $self->{make_test}->failed : 8881 $self->{make_test} =~ /^NO/ 8882 )) { 8883 if ($self->{force_update}) { 8884 $self->{make_test}->text("FAILED but failure ignored because ". 8885 "'force' in effect"); 8886 } else { 8887 push @e, "make test had returned bad status, ". 8888 "won't install without force" 8889 } 8890 } 8891 if (exists $self->{install}) { 8892 if (UNIVERSAL::can($self->{install},"text") ? 8893 $self->{install}->text eq "YES" : 8894 $self->{install} =~ /^YES/ 8895 ) { 8896 $CPAN::Frontend->myprint(" Already done\n"); 8897 $CPAN::META->is_installed($self->{build_dir}); 8898 return 1; 8899 } else { 8900 # comment in Todo on 2006-02-11; maybe retry? 8901 push @e, "Already tried without success"; 8902 } 8903 } 8904 8905 push @e, $self->{later} if $self->{later}; 8906 push @e, $self->{configure_requires_later} if $self->{configure_requires_later}; 8907 8908 $CPAN::Frontend->myprint(join "", map {" $_\n"} @e) and return if @e; 8909 unless (chdir $self->{build_dir}) { 8910 push @e, "Couldn't chdir to '$self->{build_dir}': $!"; 8911 } 8912 $CPAN::Frontend->mywarn(join "", map {" $_\n"} @e) and return if @e; 8913 } 8914 $self->debug("Changed directory to $self->{build_dir}") 8915 if $CPAN::DEBUG; 8916 8917 if ($^O eq 'MacOS') { 8918 Mac::BuildTools::make_install($self); 8919 return; 8920 } 8921 8922 my $system; 8923 if (my $commandline = $self->prefs->{install}{commandline}) { 8924 $system = $commandline; 8925 $ENV{PERL} = CPAN::find_perl; 8926 } elsif ($self->{modulebuild}) { 8927 my($mbuild_install_build_command) = 8928 exists $CPAN::HandleConfig::keys{mbuild_install_build_command} && 8929 $CPAN::Config->{mbuild_install_build_command} ? 8930 $CPAN::Config->{mbuild_install_build_command} : 8931 $self->_build_command(); 8932 $system = sprintf("%s install %s", 8933 $mbuild_install_build_command, 8934 $CPAN::Config->{mbuild_install_arg}, 8935 ); 8936 } else { 8937 my($make_install_make_command) = 8938 CPAN::HandleConfig->prefs_lookup($self, 8939 q{make_install_make_command}) 8940 || $self->_make_command(); 8941 $system = sprintf("%s install %s", 8942 $make_install_make_command, 8943 $CPAN::Config->{make_install_arg}, 8944 ); 8945 } 8946 8947 my($stderr) = $^O eq "MSWin32" ? "" : " 2>&1 "; 8948 my $brip = CPAN::HandleConfig->prefs_lookup($self, 8949 q{build_requires_install_policy}); 8950 $brip ||="ask/yes"; 8951 my $id = $self->id; 8952 my $reqtype = $self->{reqtype} ||= "c"; # in doubt it was a command 8953 my $want_install = "yes"; 8954 if ($reqtype eq "b") { 8955 if ($brip eq "no") { 8956 $want_install = "no"; 8957 } elsif ($brip =~ m|^ask/(.+)|) { 8958 my $default = $1; 8959 $default = "yes" unless $default =~ /^(y|n)/i; 8960 $want_install = 8961 CPAN::Shell::colorable_makemaker_prompt 8962 ("$id is just needed temporarily during building or testing. ". 8963 "Do you want to install it permanently? (Y/n)", 8964 $default); 8965 } 8966 } 8967 unless ($want_install =~ /^y/i) { 8968 my $is_only = "is only 'build_requires'"; 8969 $CPAN::Frontend->mywarn("Not installing because $is_only\n"); 8970 $self->{install} = CPAN::Distrostatus->new("NO -- $is_only"); 8971 delete $self->{force_update}; 8972 return; 8973 } 8974 local $ENV{PERL5LIB} = defined($ENV{PERL5LIB}) 8975 ? $ENV{PERL5LIB} 8976 : ($ENV{PERLLIB} || ""); 8977 8978 $CPAN::META->set_perl5lib; 8979 my($pipe) = FileHandle->new("$system $stderr |"); 8980 my($makeout) = ""; 8981 while (<$pipe>) { 8982 print $_; # intentionally NOT use Frontend->myprint because it 8983 # looks irritating when we markup in color what we 8984 # just pass through from an external program 8985 $makeout .= $_; 8986 } 8987 $pipe->close; 8988 my $close_ok = $? == 0; 8989 $self->introduce_myself; 8990 if ( $close_ok ) { 8991 $CPAN::Frontend->myprint(" $system -- OK\n"); 8992 $CPAN::META->is_installed($self->{build_dir}); 8993 $self->{install} = CPAN::Distrostatus->new("YES"); 8994 } else { 8995 $self->{install} = CPAN::Distrostatus->new("NO"); 8996 $CPAN::Frontend->mywarn(" $system -- NOT OK\n"); 8997 my $mimc = 8998 CPAN::HandleConfig->prefs_lookup($self, 8999 q{make_install_make_command}); 9000 if ( 9001 $makeout =~ /permission/s 9002 && $> > 0 9003 && ( 9004 ! $mimc 9005 || $mimc eq (CPAN::HandleConfig->prefs_lookup($self, 9006 q{make})) 9007 ) 9008 ) { 9009 $CPAN::Frontend->myprint( 9010 qq{----\n}. 9011 qq{ You may have to su }. 9012 qq{to root to install the package\n}. 9013 qq{ (Or you may want to run something like\n}. 9014 qq{ o conf make_install_make_command 'sudo make'\n}. 9015 qq{ to raise your permissions.} 9016 ); 9017 } 9018 } 9019 delete $self->{force_update}; 9020 # $DB::single = 1; 9021 $self->store_persistent_state; 9022 } 9023 9024 sub introduce_myself { 9025 my($self) = @_; 9026 $CPAN::Frontend->myprint(sprintf(" %s\n",$self->pretty_id)); 9027 } 9028 9029 #-> sub CPAN::Distribution::dir ; 9030 sub dir { 9031 shift->{build_dir}; 9032 } 9033 9034 #-> sub CPAN::Distribution::perldoc ; 9035 sub perldoc { 9036 my($self) = @_; 9037 9038 my($dist) = $self->id; 9039 my $package = $self->called_for; 9040 9041 $self->_display_url( $CPAN::Defaultdocs . $package ); 9042 } 9043 9044 #-> sub CPAN::Distribution::_check_binary ; 9045 sub _check_binary { 9046 my ($dist,$shell,$binary) = @_; 9047 my ($pid,$out); 9048 9049 $CPAN::Frontend->myprint(qq{ + _check_binary($binary)\n}) 9050 if $CPAN::DEBUG; 9051 9052 if ($CPAN::META->has_inst("File::Which")) { 9053 return File::Which::which($binary); 9054 } else { 9055 local *README; 9056 $pid = open README, "which $binary|" 9057 or $CPAN::Frontend->mywarn(qq{Could not fork 'which $binary': $!\n}); 9058 return unless $pid; 9059 while (<README>) { 9060 $out .= $_; 9061 } 9062 close README 9063 or $CPAN::Frontend->mywarn("Could not run 'which $binary': $!\n") 9064 and return; 9065 } 9066 9067 $CPAN::Frontend->myprint(qq{ + $out \n}) 9068 if $CPAN::DEBUG && $out; 9069 9070 return $out; 9071 } 9072 9073 #-> sub CPAN::Distribution::_display_url ; 9074 sub _display_url { 9075 my($self,$url) = @_; 9076 my($res,$saved_file,$pid,$out); 9077 9078 $CPAN::Frontend->myprint(qq{ + _display_url($url)\n}) 9079 if $CPAN::DEBUG; 9080 9081 # should we define it in the config instead? 9082 my $html_converter = "html2text.pl"; 9083 9084 my $web_browser = $CPAN::Config->{'lynx'} || undef; 9085 my $web_browser_out = $web_browser 9086 ? CPAN::Distribution->_check_binary($self,$web_browser) 9087 : undef; 9088 9089 if ($web_browser_out) { 9090 # web browser found, run the action 9091 my $browser = CPAN::HandleConfig->safe_quote($CPAN::Config->{'lynx'}); 9092 $CPAN::Frontend->myprint(qq{system[$browser $url]}) 9093 if $CPAN::DEBUG; 9094 $CPAN::Frontend->myprint(qq{ 9095 Displaying URL 9096 $url 9097 with browser $browser 9098 }); 9099 $CPAN::Frontend->mysleep(1); 9100 system("$browser $url"); 9101 if ($saved_file) { 1 while unlink($saved_file) } 9102 } else { 9103 # web browser not found, let's try text only 9104 my $html_converter_out = 9105 CPAN::Distribution->_check_binary($self,$html_converter); 9106 $html_converter_out = CPAN::HandleConfig->safe_quote($html_converter_out); 9107 9108 if ($html_converter_out ) { 9109 # html2text found, run it 9110 $saved_file = CPAN::Distribution->_getsave_url( $self, $url ); 9111 $CPAN::Frontend->mydie(qq{ERROR: problems while getting $url\n}) 9112 unless defined($saved_file); 9113 9114 local *README; 9115 $pid = open README, "$html_converter $saved_file |" 9116 or $CPAN::Frontend->mydie(qq{ 9117 Could not fork '$html_converter $saved_file': $!}); 9118 my($fh,$filename); 9119 if ($CPAN::META->has_usable("File::Temp")) { 9120 $fh = File::Temp->new( 9121 dir => File::Spec->tmpdir, 9122 template => 'cpan_htmlconvert_XXXX', 9123 suffix => '.txt', 9124 unlink => 0, 9125 ); 9126 $filename = $fh->filename; 9127 } else { 9128 $filename = "cpan_htmlconvert_$$.txt"; 9129 $fh = FileHandle->new(); 9130 open $fh, ">$filename" or die; 9131 } 9132 while (<README>) { 9133 $fh->print($_); 9134 } 9135 close README or 9136 $CPAN::Frontend->mydie(qq{Could not run '$html_converter $saved_file': $!}); 9137 my $tmpin = $fh->filename; 9138 $CPAN::Frontend->myprint(sprintf(qq{ 9139 Run '%s %s' and 9140 saved output to %s\n}, 9141 $html_converter, 9142 $saved_file, 9143 $tmpin, 9144 )) if $CPAN::DEBUG; 9145 close $fh; 9146 local *FH; 9147 open FH, $tmpin 9148 or $CPAN::Frontend->mydie(qq{Could not open "$tmpin": $!}); 9149 my $fh_pager = FileHandle->new; 9150 local($SIG{PIPE}) = "IGNORE"; 9151 my $pager = $CPAN::Config->{'pager'} || "cat"; 9152 $fh_pager->open("|$pager") 9153 or $CPAN::Frontend->mydie(qq{ 9154 Could not open pager '$pager': $!}); 9155 $CPAN::Frontend->myprint(qq{ 9156 Displaying URL 9157 $url 9158 with pager "$pager" 9159 }); 9160 $CPAN::Frontend->mysleep(1); 9161 $fh_pager->print(<FH>); 9162 $fh_pager->close; 9163 } else { 9164 # coldn't find the web browser or html converter 9165 $CPAN::Frontend->myprint(qq{ 9166 You need to install lynx or $html_converter to use this feature.}); 9167 } 9168 } 9169 } 9170 9171 #-> sub CPAN::Distribution::_getsave_url ; 9172 sub _getsave_url { 9173 my($dist, $shell, $url) = @_; 9174 9175 $CPAN::Frontend->myprint(qq{ + _getsave_url($url)\n}) 9176 if $CPAN::DEBUG; 9177 9178 my($fh,$filename); 9179 if ($CPAN::META->has_usable("File::Temp")) { 9180 $fh = File::Temp->new( 9181 dir => File::Spec->tmpdir, 9182 template => "cpan_getsave_url_XXXX", 9183 suffix => ".html", 9184 unlink => 0, 9185 ); 9186 $filename = $fh->filename; 9187 } else { 9188 $fh = FileHandle->new; 9189 $filename = "cpan_getsave_url_$$.html"; 9190 } 9191 my $tmpin = $filename; 9192 if ($CPAN::META->has_usable('LWP')) { 9193 $CPAN::Frontend->myprint("Fetching with LWP: 9194 $url 9195 "); 9196 my $Ua; 9197 CPAN::LWP::UserAgent->config; 9198 eval { $Ua = CPAN::LWP::UserAgent->new; }; 9199 if ($@) { 9200 $CPAN::Frontend->mywarn("ERROR: CPAN::LWP::UserAgent->new dies with $@\n"); 9201 return; 9202 } else { 9203 my($var); 9204 $Ua->proxy('http', $var) 9205 if $var = $CPAN::Config->{http_proxy} || $ENV{http_proxy}; 9206 $Ua->no_proxy($var) 9207 if $var = $CPAN::Config->{no_proxy} || $ENV{no_proxy}; 9208 } 9209 9210 my $req = HTTP::Request->new(GET => $url); 9211 $req->header('Accept' => 'text/html'); 9212 my $res = $Ua->request($req); 9213 if ($res->is_success) { 9214 $CPAN::Frontend->myprint(" + request successful.\n") 9215 if $CPAN::DEBUG; 9216 print $fh $res->content; 9217 close $fh; 9218 $CPAN::Frontend->myprint(qq{ + saved content to $tmpin \n}) 9219 if $CPAN::DEBUG; 9220 return $tmpin; 9221 } else { 9222 $CPAN::Frontend->myprint(sprintf( 9223 "LWP failed with code[%s], message[%s]\n", 9224 $res->code, 9225 $res->message, 9226 )); 9227 return; 9228 } 9229 } else { 9230 $CPAN::Frontend->mywarn(" LWP not available\n"); 9231 return; 9232 } 9233 } 9234 9235 #-> sub CPAN::Distribution::_build_command 9236 sub _build_command { 9237 my($self) = @_; 9238 if ($^O eq "MSWin32") { # special code needed at least up to 9239 # Module::Build 0.2611 and 0.2706; a fix 9240 # in M:B has been promised 2006-01-30 9241 my($perl) = $self->perl or $CPAN::Frontend->mydie("Couldn't find executable perl\n"); 9242 return "$perl ./Build"; 9243 } 9244 return "./Build"; 9245 } 9246 9247 #-> sub CPAN::Distribution::_should_report 9248 sub _should_report { 9249 my($self, $phase) = @_; 9250 die "_should_report() requires a 'phase' argument" 9251 if ! defined $phase; 9252 9253 # configured 9254 my $test_report = CPAN::HandleConfig->prefs_lookup($self, 9255 q{test_report}); 9256 return unless $test_report; 9257 9258 # don't repeat if we cached a result 9259 return $self->{should_report} 9260 if exists $self->{should_report}; 9261 9262 # available 9263 if ( ! $CPAN::META->has_inst("CPAN::Reporter")) { 9264 $CPAN::Frontend->mywarn( 9265 "CPAN::Reporter not installed. No reports will be sent.\n" 9266 ); 9267 return $self->{should_report} = 0; 9268 } 9269 9270 # capable 9271 my $crv = CPAN::Reporter->VERSION; 9272 if ( CPAN::Version->vlt( $crv, 0.99 ) ) { 9273 # don't cache $self->{should_report} -- need to check each phase 9274 if ( $phase eq 'test' ) { 9275 return 1; 9276 } 9277 else { 9278 $CPAN::Frontend->mywarn( 9279 "Reporting on the '$phase' phase requires CPAN::Reporter 0.99, but \n" . 9280 "you only have version $crv\. Only 'test' phase reports will be sent.\n" 9281 ); 9282 return; 9283 } 9284 } 9285 9286 # appropriate 9287 if ($self->is_dot_dist) { 9288 $CPAN::Frontend->mywarn("Reporting via CPAN::Reporter is disabled ". 9289 "for local directories\n"); 9290 return $self->{should_report} = 0; 9291 } 9292 if ($self->prefs->{patches} 9293 && 9294 @{$self->prefs->{patches}} 9295 && 9296 $self->{patched} 9297 ) { 9298 $CPAN::Frontend->mywarn("Reporting via CPAN::Reporter is disabled ". 9299 "when the source has been patched\n"); 9300 return $self->{should_report} = 0; 9301 } 9302 9303 # proceed and cache success 9304 return $self->{should_report} = 1; 9305 } 9306 9307 #-> sub CPAN::Distribution::reports 9308 sub reports { 9309 my($self) = @_; 9310 my $pathname = $self->id; 9311 $CPAN::Frontend->myprint("Distribution: $pathname\n"); 9312 9313 unless ($CPAN::META->has_inst("CPAN::DistnameInfo")) { 9314 $CPAN::Frontend->mydie("CPAN::DistnameInfo not installed; cannot continue"); 9315 } 9316 unless ($CPAN::META->has_usable("LWP")) { 9317 $CPAN::Frontend->mydie("LWP not installed; cannot continue"); 9318 } 9319 unless ($CPAN::META->has_usable("File::Temp")) { 9320 $CPAN::Frontend->mydie("File::Temp not installed; cannot continue"); 9321 } 9322 9323 my $d = CPAN::DistnameInfo->new($pathname); 9324 9325 my $dist = $d->dist; # "CPAN-DistnameInfo" 9326 my $version = $d->version; # "0.02" 9327 my $maturity = $d->maturity; # "released" 9328 my $filename = $d->filename; # "CPAN-DistnameInfo-0.02.tar.gz" 9329 my $cpanid = $d->cpanid; # "GBARR" 9330 my $distvname = $d->distvname; # "CPAN-DistnameInfo-0.02" 9331 9332 my $url = sprintf "http://cpantesters.perl.org/show/%s.yaml", $dist; 9333 9334 CPAN::LWP::UserAgent->config; 9335 my $Ua; 9336 eval { $Ua = CPAN::LWP::UserAgent->new; }; 9337 if ($@) { 9338 $CPAN::Frontend->mydie("CPAN::LWP::UserAgent->new dies with $@\n"); 9339 } 9340 $CPAN::Frontend->myprint("Fetching '$url'..."); 9341 my $resp = $Ua->get($url); 9342 unless ($resp->is_success) { 9343 $CPAN::Frontend->mydie(sprintf "Could not download '%s': %s\n", $url, $resp->code); 9344 } 9345 $CPAN::Frontend->myprint("DONE\n\n"); 9346 my $yaml = $resp->content; 9347 # was fuer ein Umweg! 9348 my $fh = File::Temp->new( 9349 dir => File::Spec->tmpdir, 9350 template => 'cpan_reports_XXXX', 9351 suffix => '.yaml', 9352 unlink => 0, 9353 ); 9354 my $tfilename = $fh->filename; 9355 print $fh $yaml; 9356 close $fh or $CPAN::Frontend->mydie("Could not close '$tfilename': $!"); 9357 my $unserialized = CPAN->_yaml_loadfile($tfilename)->[0]; 9358 unlink $tfilename or $CPAN::Frontend->mydie("Could not unlink '$tfilename': $!"); 9359 my %other_versions; 9360 my $this_version_seen; 9361 for my $rep (@$unserialized) { 9362 my $rversion = $rep->{version}; 9363 if ($rversion eq $version) { 9364 unless ($this_version_seen++) { 9365 $CPAN::Frontend->myprint ("$rep->{version}:\n"); 9366 } 9367 $CPAN::Frontend->myprint 9368 (sprintf("%1s%1s%-4s %s on %s %s (%s)\n", 9369 $rep->{archname} eq $Config::Config{archname}?"*":"", 9370 $rep->{action}eq"PASS"?"+":$rep->{action}eq"FAIL"?"-":"", 9371 $rep->{action}, 9372 $rep->{perl}, 9373 ucfirst $rep->{osname}, 9374 $rep->{osvers}, 9375 $rep->{archname}, 9376 )); 9377 } else { 9378 $other_versions{$rep->{version}}++; 9379 } 9380 } 9381 unless ($this_version_seen) { 9382 $CPAN::Frontend->myprint("No reports found for version '$version' 9383 Reports for other versions:\n"); 9384 for my $v (sort keys %other_versions) { 9385 $CPAN::Frontend->myprint(" $v\: $other_versions{$v}\n"); 9386 } 9387 } 9388 $url =~ s/\.yaml/.html/; 9389 $CPAN::Frontend->myprint("See $url for details\n"); 9390 } 9391 9392 package CPAN::Bundle; 9393 use strict; 9394 9395 sub look { 9396 my $self = shift; 9397 $CPAN::Frontend->myprint($self->as_string); 9398 } 9399 9400 #-> CPAN::Bundle::undelay 9401 sub undelay { 9402 my $self = shift; 9403 delete $self->{later}; 9404 for my $c ( $self->contains ) { 9405 my $obj = CPAN::Shell->expandany($c) or next; 9406 $obj->undelay; 9407 } 9408 } 9409 9410 # mark as dirty/clean 9411 #-> sub CPAN::Bundle::color_cmd_tmps ; 9412 sub color_cmd_tmps { 9413 my($self) = shift; 9414 my($depth) = shift || 0; 9415 my($color) = shift || 0; 9416 my($ancestors) = shift || []; 9417 # a module needs to recurse to its cpan_file, a distribution needs 9418 # to recurse into its prereq_pms, a bundle needs to recurse into its modules 9419 9420 return if exists $self->{incommandcolor} 9421 && $color==1 9422 && $self->{incommandcolor}==$color; 9423 if ($depth>=$CPAN::MAX_RECURSION) { 9424 die(CPAN::Exception::RecursiveDependency->new($ancestors)); 9425 } 9426 # warn "color_cmd_tmps $depth $color " . $self->id; # sleep 1; 9427 9428 for my $c ( $self->contains ) { 9429 my $obj = CPAN::Shell->expandany($c) or next; 9430 CPAN->debug("c[$c]obj[$obj]") if $CPAN::DEBUG; 9431 $obj->color_cmd_tmps($depth+1,$color,[@$ancestors, $self->id]); 9432 } 9433 # never reached code? 9434 #if ($color==0) { 9435 #delete $self->{badtestcnt}; 9436 #} 9437 $self->{incommandcolor} = $color; 9438 } 9439 9440 #-> sub CPAN::Bundle::as_string ; 9441 sub as_string { 9442 my($self) = @_; 9443 $self->contains; 9444 # following line must be "=", not "||=" because we have a moving target 9445 $self->{INST_VERSION} = $self->inst_version; 9446 return $self->SUPER::as_string; 9447 } 9448 9449 #-> sub CPAN::Bundle::contains ; 9450 sub contains { 9451 my($self) = @_; 9452 my($inst_file) = $self->inst_file || ""; 9453 my($id) = $self->id; 9454 $self->debug("inst_file[$inst_file]id[$id]") if $CPAN::DEBUG; 9455 if ($inst_file && CPAN::Version->vlt($self->inst_version,$self->cpan_version)) { 9456 undef $inst_file; 9457 } 9458 unless ($inst_file) { 9459 # Try to get at it in the cpan directory 9460 $self->debug("no inst_file") if $CPAN::DEBUG; 9461 my $cpan_file; 9462 $CPAN::Frontend->mydie("I don't know a bundle with ID $id\n") unless 9463 $cpan_file = $self->cpan_file; 9464 if ($cpan_file eq "N/A") { 9465 $CPAN::Frontend->mydie("Bundle $id not found on disk and not on CPAN. 9466 Maybe stale symlink? Maybe removed during session? Giving up.\n"); 9467 } 9468 my $dist = $CPAN::META->instance('CPAN::Distribution', 9469 $self->cpan_file); 9470 $self->debug("before get id[$dist->{ID}]") if $CPAN::DEBUG; 9471 $dist->get; 9472 $self->debug("after get id[$dist->{ID}]") if $CPAN::DEBUG; 9473 my($todir) = $CPAN::Config->{'cpan_home'}; 9474 my(@me,$from,$to,$me); 9475 @me = split /::/, $self->id; 9476 $me[-1] .= ".pm"; 9477 $me = File::Spec->catfile(@me); 9478 $from = $self->find_bundle_file($dist->{build_dir},join('/',@me)); 9479 $to = File::Spec->catfile($todir,$me); 9480 File::Path::mkpath(File::Basename::dirname($to)); 9481 File::Copy::copy($from, $to) 9482 or Carp::confess("Couldn't copy $from to $to: $!"); 9483 $inst_file = $to; 9484 } 9485 my @result; 9486 my $fh = FileHandle->new; 9487 local $/ = "\n"; 9488 open($fh,$inst_file) or die "Could not open '$inst_file': $!"; 9489 my $in_cont = 0; 9490 $self->debug("inst_file[$inst_file]") if $CPAN::DEBUG; 9491 while (<$fh>) { 9492 $in_cont = m/^=(?!head1\s+CONTENTS)/ ? 0 : 9493 m/^=head1\s+CONTENTS/ ? 1 : $in_cont; 9494 next unless $in_cont; 9495 next if /^=/; 9496 s/\#.*//; 9497 next if /^\s+$/; 9498 chomp; 9499 push @result, (split " ", $_, 2)[0]; 9500 } 9501 close $fh; 9502 delete $self->{STATUS}; 9503 $self->{CONTAINS} = \@result; 9504 $self->debug("CONTAINS[@result]") if $CPAN::DEBUG; 9505 unless (@result) { 9506 $CPAN::Frontend->mywarn(qq{ 9507 The bundle file "$inst_file" may be a broken 9508 bundlefile. It seems not to contain any bundle definition. 9509 Please check the file and if it is bogus, please delete it. 9510 Sorry for the inconvenience. 9511 }); 9512 } 9513 @result; 9514 } 9515 9516 #-> sub CPAN::Bundle::find_bundle_file 9517 # $where is in local format, $what is in unix format 9518 sub find_bundle_file { 9519 my($self,$where,$what) = @_; 9520 $self->debug("where[$where]what[$what]") if $CPAN::DEBUG; 9521 ### The following two lines let CPAN.pm become Bundle/CPAN.pm :-( 9522 ### my $bu = File::Spec->catfile($where,$what); 9523 ### return $bu if -f $bu; 9524 my $manifest = File::Spec->catfile($where,"MANIFEST"); 9525 unless (-f $manifest) { 9526 require ExtUtils::Manifest; 9527 my $cwd = CPAN::anycwd(); 9528 $self->safe_chdir($where); 9529 ExtUtils::Manifest::mkmanifest(); 9530 $self->safe_chdir($cwd); 9531 } 9532 my $fh = FileHandle->new($manifest) 9533 or Carp::croak("Couldn't open $manifest: $!"); 9534 local($/) = "\n"; 9535 my $bundle_filename = $what; 9536 $bundle_filename =~ s|Bundle.*/||; 9537 my $bundle_unixpath; 9538 while (<$fh>) { 9539 next if /^\s*\#/; 9540 my($file) = /(\S+)/; 9541 if ($file =~ m|\Q$what\E$|) { 9542 $bundle_unixpath = $file; 9543 # return File::Spec->catfile($where,$bundle_unixpath); # bad 9544 last; 9545 } 9546 # retry if she managed to have no Bundle directory 9547 $bundle_unixpath = $file if $file =~ m|\Q$bundle_filename\E$|; 9548 } 9549 return File::Spec->catfile($where, split /\//, $bundle_unixpath) 9550 if $bundle_unixpath; 9551 Carp::croak("Couldn't find a Bundle file in $where"); 9552 } 9553 9554 # needs to work quite differently from Module::inst_file because of 9555 # cpan_home/Bundle/ directory and the possibility that we have 9556 # shadowing effect. As it makes no sense to take the first in @INC for 9557 # Bundles, we parse them all for $VERSION and take the newest. 9558 9559 #-> sub CPAN::Bundle::inst_file ; 9560 sub inst_file { 9561 my($self) = @_; 9562 my($inst_file); 9563 my(@me); 9564 @me = split /::/, $self->id; 9565 $me[-1] .= ".pm"; 9566 my($incdir,$bestv); 9567 foreach $incdir ($CPAN::Config->{'cpan_home'},@INC) { 9568 my $bfile = File::Spec->catfile($incdir, @me); 9569 CPAN->debug("bfile[$bfile]") if $CPAN::DEBUG; 9570 next unless -f $bfile; 9571 my $foundv = MM->parse_version($bfile); 9572 if (!$bestv || CPAN::Version->vgt($foundv,$bestv)) { 9573 $self->{INST_FILE} = $bfile; 9574 $self->{INST_VERSION} = $bestv = $foundv; 9575 } 9576 } 9577 $self->{INST_FILE}; 9578 } 9579 9580 #-> sub CPAN::Bundle::inst_version ; 9581 sub inst_version { 9582 my($self) = @_; 9583 $self->inst_file; # finds INST_VERSION as side effect 9584 $self->{INST_VERSION}; 9585 } 9586 9587 #-> sub CPAN::Bundle::rematein ; 9588 sub rematein { 9589 my($self,$meth) = @_; 9590 $self->debug("self[$self] meth[$meth]") if $CPAN::DEBUG; 9591 my($id) = $self->id; 9592 Carp::croak "Can't $meth $id, don't have an associated bundle file. :-(\n" 9593 unless $self->inst_file || $self->cpan_file; 9594 my($s,%fail); 9595 for $s ($self->contains) { 9596 my($type) = $s =~ m|/| ? 'CPAN::Distribution' : 9597 $s =~ m|^Bundle::| ? 'CPAN::Bundle' : 'CPAN::Module'; 9598 if ($type eq 'CPAN::Distribution') { 9599 $CPAN::Frontend->mywarn(qq{ 9600 The Bundle }.$self->id.qq{ contains 9601 explicitly a file '$s'. 9602 Going to $meth that. 9603 }); 9604 $CPAN::Frontend->mysleep(5); 9605 } 9606 # possibly noisy action: 9607 $self->debug("type[$type] s[$s]") if $CPAN::DEBUG; 9608 my $obj = $CPAN::META->instance($type,$s); 9609 $obj->{reqtype} = $self->{reqtype}; 9610 $obj->$meth(); 9611 } 9612 } 9613 9614 # If a bundle contains another that contains an xs_file we have here, 9615 # we just don't bother I suppose 9616 #-> sub CPAN::Bundle::xs_file 9617 sub xs_file { 9618 return 0; 9619 } 9620 9621 #-> sub CPAN::Bundle::force ; 9622 sub fforce { shift->rematein('fforce',@_); } 9623 #-> sub CPAN::Bundle::force ; 9624 sub force { shift->rematein('force',@_); } 9625 #-> sub CPAN::Bundle::notest ; 9626 sub notest { shift->rematein('notest',@_); } 9627 #-> sub CPAN::Bundle::get ; 9628 sub get { shift->rematein('get',@_); } 9629 #-> sub CPAN::Bundle::make ; 9630 sub make { shift->rematein('make',@_); } 9631 #-> sub CPAN::Bundle::test ; 9632 sub test { 9633 my $self = shift; 9634 # $self->{badtestcnt} ||= 0; 9635 $self->rematein('test',@_); 9636 } 9637 #-> sub CPAN::Bundle::install ; 9638 sub install { 9639 my $self = shift; 9640 $self->rematein('install',@_); 9641 } 9642 #-> sub CPAN::Bundle::clean ; 9643 sub clean { shift->rematein('clean',@_); } 9644 9645 #-> sub CPAN::Bundle::uptodate ; 9646 sub uptodate { 9647 my($self) = @_; 9648 return 0 unless $self->SUPER::uptodate; # we mut have the current Bundle def 9649 my $c; 9650 foreach $c ($self->contains) { 9651 my $obj = CPAN::Shell->expandany($c); 9652 return 0 unless $obj->uptodate; 9653 } 9654 return 1; 9655 } 9656 9657 #-> sub CPAN::Bundle::readme ; 9658 sub readme { 9659 my($self) = @_; 9660 my($file) = $self->cpan_file or $CPAN::Frontend->myprint(qq{ 9661 No File found for bundle } . $self->id . qq{\n}), return; 9662 $self->debug("self[$self] file[$file]") if $CPAN::DEBUG; 9663 $CPAN::META->instance('CPAN::Distribution',$file)->readme; 9664 } 9665 9666 package CPAN::Module; 9667 use strict; 9668 9669 # Accessors 9670 #-> sub CPAN::Module::userid 9671 sub userid { 9672 my $self = shift; 9673 my $ro = $self->ro; 9674 return unless $ro; 9675 return $ro->{userid} || $ro->{CPAN_USERID}; 9676 } 9677 #-> sub CPAN::Module::description 9678 sub description { 9679 my $self = shift; 9680 my $ro = $self->ro or return ""; 9681 $ro->{description} 9682 } 9683 9684 #-> sub CPAN::Module::distribution 9685 sub distribution { 9686 my($self) = @_; 9687 CPAN::Shell->expand("Distribution",$self->cpan_file); 9688 } 9689 9690 #-> sub CPAN::Module::undelay 9691 sub undelay { 9692 my $self = shift; 9693 delete $self->{later}; 9694 if ( my $dist = CPAN::Shell->expand("Distribution", $self->cpan_file) ) { 9695 $dist->undelay; 9696 } 9697 } 9698 9699 # mark as dirty/clean 9700 #-> sub CPAN::Module::color_cmd_tmps ; 9701 sub color_cmd_tmps { 9702 my($self) = shift; 9703 my($depth) = shift || 0; 9704 my($color) = shift || 0; 9705 my($ancestors) = shift || []; 9706 # a module needs to recurse to its cpan_file 9707 9708 return if exists $self->{incommandcolor} 9709 && $color==1 9710 && $self->{incommandcolor}==$color; 9711 return if $color==0 && !$self->{incommandcolor}; 9712 if ($color>=1) { 9713 if ( $self->uptodate ) { 9714 $self->{incommandcolor} = $color; 9715 return; 9716 } elsif (my $have_version = $self->available_version) { 9717 # maybe what we have is good enough 9718 if (@$ancestors) { 9719 my $who_asked_for_me = $ancestors->[-1]; 9720 my $obj = CPAN::Shell->expandany($who_asked_for_me); 9721 if (0) { 9722 } elsif ($obj->isa("CPAN::Bundle")) { 9723 # bundles cannot specify a minimum version 9724 return; 9725 } elsif ($obj->isa("CPAN::Distribution")) { 9726 if (my $prereq_pm = $obj->prereq_pm) { 9727 for my $k (keys %$prereq_pm) { 9728 if (my $want_version = $prereq_pm->{$k}{$self->id}) { 9729 if (CPAN::Version->vcmp($have_version,$want_version) >= 0) { 9730 $self->{incommandcolor} = $color; 9731 return; 9732 } 9733 } 9734 } 9735 } 9736 } 9737 } 9738 } 9739 } else { 9740 $self->{incommandcolor} = $color; # set me before recursion, 9741 # so we can break it 9742 } 9743 if ($depth>=$CPAN::MAX_RECURSION) { 9744 die(CPAN::Exception::RecursiveDependency->new($ancestors)); 9745 } 9746 # warn "color_cmd_tmps $depth $color " . $self->id; # sleep 1; 9747 9748 if ( my $dist = CPAN::Shell->expand("Distribution", $self->cpan_file) ) { 9749 $dist->color_cmd_tmps($depth+1,$color,[@$ancestors, $self->id]); 9750 } 9751 # unreached code? 9752 # if ($color==0) { 9753 # delete $self->{badtestcnt}; 9754 # } 9755 $self->{incommandcolor} = $color; 9756 } 9757 9758 #-> sub CPAN::Module::as_glimpse ; 9759 sub as_glimpse { 9760 my($self) = @_; 9761 my(@m); 9762 my $class = ref($self); 9763 $class =~ s/^CPAN:://; 9764 my $color_on = ""; 9765 my $color_off = ""; 9766 if ( 9767 $CPAN::Shell::COLOR_REGISTERED 9768 && 9769 $CPAN::META->has_inst("Term::ANSIColor") 9770 && 9771 $self->description 9772 ) { 9773 $color_on = Term::ANSIColor::color("green"); 9774 $color_off = Term::ANSIColor::color("reset"); 9775 } 9776 my $uptodateness = " "; 9777 unless ($class eq "Bundle") { 9778 my $u = $self->uptodate; 9779 $uptodateness = $u ? "=" : "<" if defined $u; 9780 }; 9781 my $id = do { 9782 my $d = $self->distribution; 9783 $d ? $d -> pretty_id : $self->cpan_userid; 9784 }; 9785 push @m, sprintf("%-7s %1s %s%-22s%s (%s)\n", 9786 $class, 9787 $uptodateness, 9788 $color_on, 9789 $self->id, 9790 $color_off, 9791 $id, 9792 ); 9793 join "", @m; 9794 } 9795 9796 #-> sub CPAN::Module::dslip_status 9797 sub dslip_status { 9798 my($self) = @_; 9799 my($stat); 9800 # development status 9801 @{$stat->{D}}{qw,i c a b R M S,} = qw,idea 9802 pre-alpha alpha beta released 9803 mature standard,; 9804 # support level 9805 @{$stat->{S}}{qw,m d u n a,} = qw,mailing-list 9806 developer comp.lang.perl.* 9807 none abandoned,; 9808 # language 9809 @{$stat->{L}}{qw,p c + o h,} = qw,perl C C++ other hybrid,; 9810 # interface 9811 @{$stat->{I}}{qw,f r O p h n,} = qw,functions 9812 references+ties 9813 object-oriented pragma 9814 hybrid none,; 9815 # public licence 9816 @{$stat->{P}}{qw,p g l b a 2 o d r n,} = qw,Standard-Perl 9817 GPL LGPL 9818 BSD Artistic Artistic_2 9819 open-source 9820 distribution_allowed 9821 restricted_distribution 9822 no_licence,; 9823 for my $x (qw(d s l i p)) { 9824 $stat->{$x}{' '} = 'unknown'; 9825 $stat->{$x}{'?'} = 'unknown'; 9826 } 9827 my $ro = $self->ro; 9828 return +{} unless $ro && $ro->{statd}; 9829 return { 9830 D => $ro->{statd}, 9831 S => $ro->{stats}, 9832 L => $ro->{statl}, 9833 I => $ro->{stati}, 9834 P => $ro->{statp}, 9835 DV => $stat->{D}{$ro->{statd}}, 9836 SV => $stat->{S}{$ro->{stats}}, 9837 LV => $stat->{L}{$ro->{statl}}, 9838 IV => $stat->{I}{$ro->{stati}}, 9839 PV => $stat->{P}{$ro->{statp}}, 9840 }; 9841 } 9842 9843 #-> sub CPAN::Module::as_string ; 9844 sub as_string { 9845 my($self) = @_; 9846 my(@m); 9847 CPAN->debug("$self entering as_string") if $CPAN::DEBUG; 9848 my $class = ref($self); 9849 $class =~ s/^CPAN:://; 9850 local($^W) = 0; 9851 push @m, $class, " id = $self->{ID}\n"; 9852 my $sprintf = " %-12s %s\n"; 9853 push @m, sprintf($sprintf, 'DESCRIPTION', $self->description) 9854 if $self->description; 9855 my $sprintf2 = " %-12s %s (%s)\n"; 9856 my($userid); 9857 $userid = $self->userid; 9858 if ( $userid ) { 9859 my $author; 9860 if ($author = CPAN::Shell->expand('Author',$userid)) { 9861 my $email = ""; 9862 my $m; # old perls 9863 if ($m = $author->email) { 9864 $email = " <$m>"; 9865 } 9866 push @m, sprintf( 9867 $sprintf2, 9868 'CPAN_USERID', 9869 $userid, 9870 $author->fullname . $email 9871 ); 9872 } 9873 } 9874 push @m, sprintf($sprintf, 'CPAN_VERSION', $self->cpan_version) 9875 if $self->cpan_version; 9876 if (my $cpan_file = $self->cpan_file) { 9877 push @m, sprintf($sprintf, 'CPAN_FILE', $cpan_file); 9878 if (my $dist = CPAN::Shell->expand("Distribution",$cpan_file)) { 9879 my $upload_date = $dist->upload_date; 9880 if ($upload_date) { 9881 push @m, sprintf($sprintf, 'UPLOAD_DATE', $upload_date); 9882 } 9883 } 9884 } 9885 my $sprintf3 = " %-12s %1s%1s%1s%1s%1s (%s,%s,%s,%s,%s)\n"; 9886 my $dslip = $self->dslip_status; 9887 push @m, sprintf( 9888 $sprintf3, 9889 'DSLIP_STATUS', 9890 @{$dslip}{qw(D S L I P DV SV LV IV PV)}, 9891 ) if $dslip->{D}; 9892 my $local_file = $self->inst_file; 9893 unless ($self->{MANPAGE}) { 9894 my $manpage; 9895 if ($local_file) { 9896 $manpage = $self->manpage_headline($local_file); 9897 } else { 9898 # If we have already untarred it, we should look there 9899 my $dist = $CPAN::META->instance('CPAN::Distribution', 9900 $self->cpan_file); 9901 # warn "dist[$dist]"; 9902 # mff=manifest file; mfh=manifest handle 9903 my($mff,$mfh); 9904 if ( 9905 $dist->{build_dir} 9906 and 9907 (-f ($mff = File::Spec->catfile($dist->{build_dir}, "MANIFEST"))) 9908 and 9909 $mfh = FileHandle->new($mff) 9910 ) { 9911 CPAN->debug("mff[$mff]") if $CPAN::DEBUG; 9912 my $lfre = $self->id; # local file RE 9913 $lfre =~ s/::/./g; 9914 $lfre .= "\\.pm\$"; 9915 my($lfl); # local file file 9916 local $/ = "\n"; 9917 my(@mflines) = <$mfh>; 9918 for (@mflines) { 9919 s/^\s+//; 9920 s/\s.*//s; 9921 } 9922 while (length($lfre)>5 and !$lfl) { 9923 ($lfl) = grep /$lfre/, @mflines; 9924 CPAN->debug("lfl[$lfl]lfre[$lfre]") if $CPAN::DEBUG; 9925 $lfre =~ s/.+?\.//; 9926 } 9927 $lfl =~ s/\s.*//; # remove comments 9928 $lfl =~ s/\s+//g; # chomp would maybe be too system-specific 9929 my $lfl_abs = File::Spec->catfile($dist->{build_dir},$lfl); 9930 # warn "lfl_abs[$lfl_abs]"; 9931 if (-f $lfl_abs) { 9932 $manpage = $self->manpage_headline($lfl_abs); 9933 } 9934 } 9935 } 9936 $self->{MANPAGE} = $manpage if $manpage; 9937 } 9938 my($item); 9939 for $item (qw/MANPAGE/) { 9940 push @m, sprintf($sprintf, $item, $self->{$item}) 9941 if exists $self->{$item}; 9942 } 9943 for $item (qw/CONTAINS/) { 9944 push @m, sprintf($sprintf, $item, join(" ",@{$self->{$item}})) 9945 if exists $self->{$item} && @{$self->{$item}}; 9946 } 9947 push @m, sprintf($sprintf, 'INST_FILE', 9948 $local_file || "(not installed)"); 9949 push @m, sprintf($sprintf, 'INST_VERSION', 9950 $self->inst_version) if $local_file; 9951 join "", @m, "\n"; 9952 } 9953 9954 #-> sub CPAN::Module::manpage_headline 9955 sub manpage_headline { 9956 my($self,$local_file) = @_; 9957 my(@local_file) = $local_file; 9958 $local_file =~ s/\.pm(?!\n)\Z/.pod/; 9959 push @local_file, $local_file; 9960 my(@result,$locf); 9961 for $locf (@local_file) { 9962 next unless -f $locf; 9963 my $fh = FileHandle->new($locf) 9964 or $Carp::Frontend->mydie("Couldn't open $locf: $!"); 9965 my $inpod = 0; 9966 local $/ = "\n"; 9967 while (<$fh>) { 9968 $inpod = m/^=(?!head1\s+NAME\s*$)/ ? 0 : 9969 m/^=head1\s+NAME\s*$/ ? 1 : $inpod; 9970 next unless $inpod; 9971 next if /^=/; 9972 next if /^\s+$/; 9973 chomp; 9974 push @result, $_; 9975 } 9976 close $fh; 9977 last if @result; 9978 } 9979 for (@result) { 9980 s/^\s+//; 9981 s/\s+$//; 9982 } 9983 join " ", @result; 9984 } 9985 9986 #-> sub CPAN::Module::cpan_file ; 9987 # Note: also inherited by CPAN::Bundle 9988 sub cpan_file { 9989 my $self = shift; 9990 # CPAN->debug(sprintf "id[%s]", $self->id) if $CPAN::DEBUG; 9991 unless ($self->ro) { 9992 CPAN::Index->reload; 9993 } 9994 my $ro = $self->ro; 9995 if ($ro && defined $ro->{CPAN_FILE}) { 9996 return $ro->{CPAN_FILE}; 9997 } else { 9998 my $userid = $self->userid; 9999 if ( $userid ) { 10000 if ($CPAN::META->exists("CPAN::Author",$userid)) { 10001 my $author = $CPAN::META->instance("CPAN::Author", 10002 $userid); 10003 my $fullname = $author->fullname; 10004 my $email = $author->email; 10005 unless (defined $fullname && defined $email) { 10006 return sprintf("Contact Author %s", 10007 $userid, 10008 ); 10009 } 10010 return "Contact Author $fullname <$email>"; 10011 } else { 10012 return "Contact Author $userid (Email address not available)"; 10013 } 10014 } else { 10015 return "N/A"; 10016 } 10017 } 10018 } 10019 10020 #-> sub CPAN::Module::cpan_version ; 10021 sub cpan_version { 10022 my $self = shift; 10023 10024 my $ro = $self->ro; 10025 unless ($ro) { 10026 # Can happen with modules that are not on CPAN 10027 $ro = {}; 10028 } 10029 $ro->{CPAN_VERSION} = 'undef' 10030 unless defined $ro->{CPAN_VERSION}; 10031 $ro->{CPAN_VERSION}; 10032 } 10033 10034 #-> sub CPAN::Module::force ; 10035 sub force { 10036 my($self) = @_; 10037 $self->{force_update} = 1; 10038 } 10039 10040 #-> sub CPAN::Module::fforce ; 10041 sub fforce { 10042 my($self) = @_; 10043 $self->{force_update} = 2; 10044 } 10045 10046 #-> sub CPAN::Module::notest ; 10047 sub notest { 10048 my($self) = @_; 10049 # $CPAN::Frontend->mywarn("XDEBUG: set notest for Module"); 10050 $self->{notest}++; 10051 } 10052 10053 #-> sub CPAN::Module::rematein ; 10054 sub rematein { 10055 my($self,$meth) = @_; 10056 $CPAN::Frontend->myprint(sprintf("Running %s for module '%s'\n", 10057 $meth, 10058 $self->id)); 10059 my $cpan_file = $self->cpan_file; 10060 if ($cpan_file eq "N/A" || $cpan_file =~ /^Contact Author/) { 10061 $CPAN::Frontend->mywarn(sprintf qq{ 10062 The module %s isn\'t available on CPAN. 10063 10064 Either the module has not yet been uploaded to CPAN, or it is 10065 temporary unavailable. Please contact the author to find out 10066 more about the status. Try 'i %s'. 10067 }, 10068 $self->id, 10069 $self->id, 10070 ); 10071 return; 10072 } 10073 my $pack = $CPAN::META->instance('CPAN::Distribution',$cpan_file); 10074 $pack->called_for($self->id); 10075 if (exists $self->{force_update}) { 10076 if ($self->{force_update} == 2) { 10077 $pack->fforce($meth); 10078 } else { 10079 $pack->force($meth); 10080 } 10081 } 10082 $pack->notest($meth) if exists $self->{notest} && $self->{notest}; 10083 10084 $pack->{reqtype} ||= ""; 10085 CPAN->debug("dist-reqtype[$pack->{reqtype}]". 10086 "self-reqtype[$self->{reqtype}]") if $CPAN::DEBUG; 10087 if ($pack->{reqtype}) { 10088 if ($pack->{reqtype} eq "b" && $self->{reqtype} =~ /^[rc]$/) { 10089 $pack->{reqtype} = $self->{reqtype}; 10090 if ( 10091 exists $pack->{install} 10092 && 10093 ( 10094 UNIVERSAL::can($pack->{install},"failed") ? 10095 $pack->{install}->failed : 10096 $pack->{install} =~ /^NO/ 10097 ) 10098 ) { 10099 delete $pack->{install}; 10100 $CPAN::Frontend->mywarn 10101 ("Promoting $pack->{ID} from 'build_requires' to 'requires'"); 10102 } 10103 } 10104 } else { 10105 $pack->{reqtype} = $self->{reqtype}; 10106 } 10107 10108 my $success = eval { 10109 $pack->$meth(); 10110 }; 10111 my $err = $@; 10112 $pack->unforce if $pack->can("unforce") && exists $self->{force_update}; 10113 $pack->unnotest if $pack->can("unnotest") && exists $self->{notest}; 10114 delete $self->{force_update}; 10115 delete $self->{notest}; 10116 if ($err) { 10117 die $err; 10118 } 10119 return $success; 10120 } 10121 10122 #-> sub CPAN::Module::perldoc ; 10123 sub perldoc { shift->rematein('perldoc') } 10124 #-> sub CPAN::Module::readme ; 10125 sub readme { shift->rematein('readme') } 10126 #-> sub CPAN::Module::look ; 10127 sub look { shift->rematein('look') } 10128 #-> sub CPAN::Module::cvs_import ; 10129 sub cvs_import { shift->rematein('cvs_import') } 10130 #-> sub CPAN::Module::get ; 10131 sub get { shift->rematein('get',@_) } 10132 #-> sub CPAN::Module::make ; 10133 sub make { shift->rematein('make') } 10134 #-> sub CPAN::Module::test ; 10135 sub test { 10136 my $self = shift; 10137 # $self->{badtestcnt} ||= 0; 10138 $self->rematein('test',@_); 10139 } 10140 10141 #-> sub CPAN::Module::uptodate ; 10142 sub uptodate { 10143 my ($self) = @_; 10144 local ($_); 10145 my $inst = $self->inst_version or return undef; 10146 my $cpan = $self->cpan_version; 10147 local ($^W) = 0; 10148 CPAN::Version->vgt($cpan,$inst) and return 0; 10149 CPAN->debug(join("", 10150 "returning uptodate. inst_file[", 10151 $self->inst_file, 10152 "cpan[$cpan] inst[$inst]")) if $CPAN::DEBUG; 10153 return 1; 10154 } 10155 10156 #-> sub CPAN::Module::install ; 10157 sub install { 10158 my($self) = @_; 10159 my($doit) = 0; 10160 if ($self->uptodate 10161 && 10162 not exists $self->{force_update} 10163 ) { 10164 $CPAN::Frontend->myprint(sprintf("%s is up to date (%s).\n", 10165 $self->id, 10166 $self->inst_version, 10167 )); 10168 } else { 10169 $doit = 1; 10170 } 10171 my $ro = $self->ro; 10172 if ($ro && $ro->{stats} && $ro->{stats} eq "a") { 10173 $CPAN::Frontend->mywarn(qq{ 10174 \n\n\n ***WARNING*** 10175 The module $self->{ID} has no active maintainer.\n\n\n 10176 }); 10177 $CPAN::Frontend->mysleep(5); 10178 } 10179 $self->rematein('install') if $doit; 10180 } 10181 #-> sub CPAN::Module::clean ; 10182 sub clean { shift->rematein('clean') } 10183 10184 #-> sub CPAN::Module::inst_file ; 10185 sub inst_file { 10186 my($self) = @_; 10187 $self->_file_in_path([@INC]); 10188 } 10189 10190 #-> sub CPAN::Module::available_file ; 10191 sub available_file { 10192 my($self) = @_; 10193 my $sep = $Config::Config{path_sep}; 10194 my $perllib = $ENV{PERL5LIB}; 10195 $perllib = $ENV{PERLLIB} unless defined $perllib; 10196 my @perllib = split(/$sep/,$perllib) if defined $perllib; 10197 $self->_file_in_path([@perllib,@INC]); 10198 } 10199 10200 #-> sub CPAN::Module::file_in_path ; 10201 sub _file_in_path { 10202 my($self,$path) = @_; 10203 my($dir,@packpath); 10204 @packpath = split /::/, $self->{ID}; 10205 $packpath[-1] .= ".pm"; 10206 if (@packpath == 1 && $packpath[0] eq "readline.pm") { 10207 unshift @packpath, "Term", "ReadLine"; # historical reasons 10208 } 10209 foreach $dir (@$path) { 10210 my $pmfile = File::Spec->catfile($dir,@packpath); 10211 if (-f $pmfile) { 10212 return $pmfile; 10213 } 10214 } 10215 return; 10216 } 10217 10218 #-> sub CPAN::Module::xs_file ; 10219 sub xs_file { 10220 my($self) = @_; 10221 my($dir,@packpath); 10222 @packpath = split /::/, $self->{ID}; 10223 push @packpath, $packpath[-1]; 10224 $packpath[-1] .= "." . $Config::Config{'dlext'}; 10225 foreach $dir (@INC) { 10226 my $xsfile = File::Spec->catfile($dir,'auto',@packpath); 10227 if (-f $xsfile) { 10228 return $xsfile; 10229 } 10230 } 10231 return; 10232 } 10233 10234 #-> sub CPAN::Module::inst_version ; 10235 sub inst_version { 10236 my($self) = @_; 10237 my $parsefile = $self->inst_file or return; 10238 my $have = $self->parse_version($parsefile); 10239 $have; 10240 } 10241 10242 #-> sub CPAN::Module::inst_version ; 10243 sub available_version { 10244 my($self) = @_; 10245 my $parsefile = $self->available_file or return; 10246 my $have = $self->parse_version($parsefile); 10247 $have; 10248 } 10249 10250 #-> sub CPAN::Module::parse_version ; 10251 sub parse_version { 10252 my($self,$parsefile) = @_; 10253 my $have = MM->parse_version($parsefile); 10254 $have = "undef" unless defined $have && length $have; 10255 $have =~ s/^ //; # since the %vd hack these two lines here are needed 10256 $have =~ s/ $//; # trailing whitespace happens all the time 10257 10258 $have = CPAN::Version->readable($have); 10259 10260 $have =~ s/\s*//g; # stringify to float around floating point issues 10261 $have; # no stringify needed, \s* above matches always 10262 } 10263 10264 #-> sub CPAN::Module::reports 10265 sub reports { 10266 my($self) = @_; 10267 $self->distribution->reports; 10268 } 10269 10270 package CPAN; 10271 use strict; 10272 10273 1; 10274 10275 10276 __END__ 10277 10278 =head1 NAME 10279 10280 CPAN - query, download and build perl modules from CPAN sites 10281 10282 =head1 SYNOPSIS 10283 10284 Interactive mode: 10285 10286 perl -MCPAN -e shell 10287 10288 --or-- 10289 10290 cpan 10291 10292 Basic commands: 10293 10294 # Modules: 10295 10296 cpan> install Acme::Meta # in the shell 10297 10298 CPAN::Shell->install("Acme::Meta"); # in perl 10299 10300 # Distributions: 10301 10302 cpan> install NWCLARK/Acme-Meta-0.02.tar.gz # in the shell 10303 10304 CPAN::Shell-> 10305 install("NWCLARK/Acme-Meta-0.02.tar.gz"); # in perl 10306 10307 # module objects: 10308 10309 $mo = CPAN::Shell->expandany($mod); 10310 $mo = CPAN::Shell->expand("Module",$mod); # same thing 10311 10312 # distribution objects: 10313 10314 $do = CPAN::Shell->expand("Module",$mod)->distribution; 10315 $do = CPAN::Shell->expandany($distro); # same thing 10316 $do = CPAN::Shell->expand("Distribution", 10317 $distro); # same thing 10318 10319 =head1 DESCRIPTION 10320 10321 The CPAN module automates or at least simplifies the make and install 10322 of perl modules and extensions. It includes some primitive searching 10323 capabilities and knows how to use Net::FTP or LWP or some external 10324 download clients to fetch the distributions from the net. 10325 10326 These are fetched from one or more of the mirrored CPAN (Comprehensive 10327 Perl Archive Network) sites and unpacked in a dedicated directory. 10328 10329 The CPAN module also supports the concept of named and versioned 10330 I<bundles> of modules. Bundles simplify the handling of sets of 10331 related modules. See Bundles below. 10332 10333 The package contains a session manager and a cache manager. The 10334 session manager keeps track of what has been fetched, built and 10335 installed in the current session. The cache manager keeps track of the 10336 disk space occupied by the make processes and deletes excess space 10337 according to a simple FIFO mechanism. 10338 10339 All methods provided are accessible in a programmer style and in an 10340 interactive shell style. 10341 10342 =head2 CPAN::shell([$prompt, $command]) Starting Interactive Mode 10343 10344 The interactive mode is entered by running 10345 10346 perl -MCPAN -e shell 10347 10348 or 10349 10350 cpan 10351 10352 which puts you into a readline interface. If C<Term::ReadKey> and 10353 either C<Term::ReadLine::Perl> or C<Term::ReadLine::Gnu> are installed 10354 it supports both history and command completion. 10355 10356 Once you are on the command line, type C<h> to get a one page help 10357 screen and the rest should be self-explanatory. 10358 10359 The function call C<shell> takes two optional arguments, one is the 10360 prompt, the second is the default initial command line (the latter 10361 only works if a real ReadLine interface module is installed). 10362 10363 The most common uses of the interactive modes are 10364 10365 =over 2 10366 10367 =item Searching for authors, bundles, distribution files and modules 10368 10369 There are corresponding one-letter commands C<a>, C<b>, C<d>, and C<m> 10370 for each of the four categories and another, C<i> for any of the 10371 mentioned four. Each of the four entities is implemented as a class 10372 with slightly differing methods for displaying an object. 10373 10374 Arguments you pass to these commands are either strings exactly matching 10375 the identification string of an object or regular expressions that are 10376 then matched case-insensitively against various attributes of the 10377 objects. The parser recognizes a regular expression only if you 10378 enclose it between two slashes. 10379 10380 The principle is that the number of found objects influences how an 10381 item is displayed. If the search finds one item, the result is 10382 displayed with the rather verbose method C<as_string>, but if we find 10383 more than one, we display each object with the terse method 10384 C<as_glimpse>. 10385 10386 =item C<get>, C<make>, C<test>, C<install>, C<clean> modules or distributions 10387 10388 These commands take any number of arguments and investigate what is 10389 necessary to perform the action. If the argument is a distribution 10390 file name (recognized by embedded slashes), it is processed. If it is 10391 a module, CPAN determines the distribution file in which this module 10392 is included and processes that, following any dependencies named in 10393 the module's META.yml or Makefile.PL (this behavior is controlled by 10394 the configuration parameter C<prerequisites_policy>.) 10395 10396 C<get> downloads a distribution file and untars or unzips it, C<make> 10397 builds it, C<test> runs the test suite, and C<install> installs it. 10398 10399 Any C<make> or C<test> are run unconditionally. An 10400 10401 install <distribution_file> 10402 10403 also is run unconditionally. But for 10404 10405 install <module> 10406 10407 CPAN checks if an install is actually needed for it and prints 10408 I<module up to date> in the case that the distribution file containing 10409 the module doesn't need to be updated. 10410 10411 CPAN also keeps track of what it has done within the current session 10412 and doesn't try to build a package a second time regardless if it 10413 succeeded or not. It does not repeat a test run if the test 10414 has been run successfully before. Same for install runs. 10415 10416 The C<force> pragma may precede another command (currently: C<get>, 10417 C<make>, C<test>, or C<install>) and executes the command from scratch 10418 and tries to continue in case of some errors. See the section below on 10419 the C<force> and the C<fforce> pragma. 10420 10421 The C<notest> pragma may be used to skip the test part in the build 10422 process. 10423 10424 Example: 10425 10426 cpan> notest install Tk 10427 10428 A C<clean> command results in a 10429 10430 make clean 10431 10432 being executed within the distribution file's working directory. 10433 10434 =item C<readme>, C<perldoc>, C<look> module or distribution 10435 10436 C<readme> displays the README file of the associated distribution. 10437 C<Look> gets and untars (if not yet done) the distribution file, 10438 changes to the appropriate directory and opens a subshell process in 10439 that directory. C<perldoc> displays the pod documentation of the 10440 module in html or plain text format. 10441 10442 =item C<ls> author 10443 10444 =item C<ls> globbing_expression 10445 10446 The first form lists all distribution files in and below an author's 10447 CPAN directory as they are stored in the CHECKUMS files distributed on 10448 CPAN. The listing goes recursive into all subdirectories. 10449 10450 The second form allows to limit or expand the output with shell 10451 globbing as in the following examples: 10452 10453 ls JV/make* 10454 ls GSAR/*make* 10455 ls */*make* 10456 10457 The last example is very slow and outputs extra progress indicators 10458 that break the alignment of the result. 10459 10460 Note that globbing only lists directories explicitly asked for, for 10461 example FOO/* will not list FOO/bar/Acme-Sthg-n.nn.tar.gz. This may be 10462 regarded as a bug and may be changed in future versions. 10463 10464 =item C<failed> 10465 10466 The C<failed> command reports all distributions that failed on one of 10467 C<make>, C<test> or C<install> for some reason in the currently 10468 running shell session. 10469 10470 =item Persistence between sessions 10471 10472 If the C<YAML> or the C<YAML::Syck> module is installed a record of 10473 the internal state of all modules is written to disk after each step. 10474 The files contain a signature of the currently running perl version 10475 for later perusal. 10476 10477 If the configurations variable C<build_dir_reuse> is set to a true 10478 value, then CPAN.pm reads the collected YAML files. If the stored 10479 signature matches the currently running perl the stored state is 10480 loaded into memory such that effectively persistence between sessions 10481 is established. 10482 10483 =item The C<force> and the C<fforce> pragma 10484 10485 To speed things up in complex installation scenarios, CPAN.pm keeps 10486 track of what it has already done and refuses to do some things a 10487 second time. A C<get>, a C<make>, and an C<install> are not repeated. 10488 A C<test> is only repeated if the previous test was unsuccessful. The 10489 diagnostic message when CPAN.pm refuses to do something a second time 10490 is one of I<Has already been >C<unwrapped|made|tested successfully> or 10491 something similar. Another situation where CPAN refuses to act is an 10492 C<install> if the according C<test> was not successful. 10493 10494 In all these cases, the user can override the goatish behaviour by 10495 prepending the command with the word force, for example: 10496 10497 cpan> force get Foo 10498 cpan> force make AUTHOR/Bar-3.14.tar.gz 10499 cpan> force test Baz 10500 cpan> force install Acme::Meta 10501 10502 Each I<forced> command is executed with the according part of its 10503 memory erased. 10504 10505 The C<fforce> pragma is a variant that emulates a C<force get> which 10506 erases the entire memory followed by the action specified, effectively 10507 restarting the whole get/make/test/install procedure from scratch. 10508 10509 =item Lockfile 10510 10511 Interactive sessions maintain a lockfile, per default C<~/.cpan/.lock>. 10512 Batch jobs can run without a lockfile and do not disturb each other. 10513 10514 The shell offers to run in I<degraded mode> when another process is 10515 holding the lockfile. This is an experimental feature that is not yet 10516 tested very well. This second shell then does not write the history 10517 file, does not use the metadata file and has a different prompt. 10518 10519 =item Signals 10520 10521 CPAN.pm installs signal handlers for SIGINT and SIGTERM. While you are 10522 in the cpan-shell it is intended that you can press C<^C> anytime and 10523 return to the cpan-shell prompt. A SIGTERM will cause the cpan-shell 10524 to clean up and leave the shell loop. You can emulate the effect of a 10525 SIGTERM by sending two consecutive SIGINTs, which usually means by 10526 pressing C<^C> twice. 10527 10528 CPAN.pm ignores a SIGPIPE. If the user sets C<inactivity_timeout>, a 10529 SIGALRM is used during the run of the C<perl Makefile.PL> or C<perl 10530 Build.PL> subprocess. 10531 10532 =back 10533 10534 =head2 CPAN::Shell 10535 10536 The commands that are available in the shell interface are methods in 10537 the package CPAN::Shell. If you enter the shell command, all your 10538 input is split by the Text::ParseWords::shellwords() routine which 10539 acts like most shells do. The first word is being interpreted as the 10540 method to be called and the rest of the words are treated as arguments 10541 to this method. Continuation lines are supported if a line ends with a 10542 literal backslash. 10543 10544 =head2 autobundle 10545 10546 C<autobundle> writes a bundle file into the 10547 C<$CPAN::Config-E<gt>{cpan_home}/Bundle> directory. The file contains 10548 a list of all modules that are both available from CPAN and currently 10549 installed within @INC. The name of the bundle file is based on the 10550 current date and a counter. 10551 10552 =head2 hosts 10553 10554 Note: this feature is still in alpha state and may change in future 10555 versions of CPAN.pm 10556 10557 This commands provides a statistical overview over recent download 10558 activities. The data for this is collected in the YAML file 10559 C<FTPstats.yml> in your C<cpan_home> directory. If no YAML module is 10560 configured or YAML not installed, then no stats are provided. 10561 10562 =head2 mkmyconfig 10563 10564 mkmyconfig() writes your own CPAN::MyConfig file into your ~/.cpan/ 10565 directory so that you can save your own preferences instead of the 10566 system wide ones. 10567 10568 =head2 recent ***EXPERIMENTAL COMMAND*** 10569 10570 The C<recent> command downloads a list of recent uploads to CPAN and 10571 displays them I<slowly>. While the command is running $SIG{INT} is 10572 defined to mean that the loop shall be left after having displayed the 10573 current item. 10574 10575 B<Note>: This command requires XML::LibXML installed. 10576 10577 B<Note>: This whole command currently is a bit klunky and will 10578 probably change in future versions of CPAN.pm but the general 10579 approach will likely stay. 10580 10581 B<Note>: See also L<smoke> 10582 10583 =head2 recompile 10584 10585 recompile() is a very special command in that it takes no argument and 10586 runs the make/test/install cycle with brute force over all installed 10587 dynamically loadable extensions (aka XS modules) with 'force' in 10588 effect. The primary purpose of this command is to finish a network 10589 installation. Imagine, you have a common source tree for two different 10590 architectures. You decide to do a completely independent fresh 10591 installation. You start on one architecture with the help of a Bundle 10592 file produced earlier. CPAN installs the whole Bundle for you, but 10593 when you try to repeat the job on the second architecture, CPAN 10594 responds with a C<"Foo up to date"> message for all modules. So you 10595 invoke CPAN's recompile on the second architecture and you're done. 10596 10597 Another popular use for C<recompile> is to act as a rescue in case your 10598 perl breaks binary compatibility. If one of the modules that CPAN uses 10599 is in turn depending on binary compatibility (so you cannot run CPAN 10600 commands), then you should try the CPAN::Nox module for recovery. 10601 10602 =head2 report Bundle|Distribution|Module 10603 10604 The C<report> command temporarily turns on the C<test_report> config 10605 variable, then runs the C<force test> command with the given 10606 arguments. The C<force> pragma is used to re-run the tests and repeat 10607 every step that might have failed before. 10608 10609 =head2 smoke ***EXPERIMENTAL COMMAND*** 10610 10611 B<*** WARNING: this command downloads and executes software from CPAN to 10612 your computer of completely unknown status. You should never do 10613 this with your normal account and better have a dedicated well 10614 separated and secured machine to do this. ***> 10615 10616 The C<smoke> command takes the list of recent uploads to CPAN as 10617 provided by the C<recent> command and tests them all. While the 10618 command is running $SIG{INT} is defined to mean that the current item 10619 shall be skipped. 10620 10621 B<Note>: This whole command currently is a bit klunky and will 10622 probably change in future versions of CPAN.pm but the general 10623 approach will likely stay. 10624 10625 B<Note>: See also L<recent> 10626 10627 =head2 upgrade [Module|/Regex/]... 10628 10629 The C<upgrade> command first runs an C<r> command with the given 10630 arguments and then installs the newest versions of all modules that 10631 were listed by that. 10632 10633 =head2 The four C<CPAN::*> Classes: Author, Bundle, Module, Distribution 10634 10635 Although it may be considered internal, the class hierarchy does matter 10636 for both users and programmer. CPAN.pm deals with above mentioned four 10637 classes, and all those classes share a set of methods. A classical 10638 single polymorphism is in effect. A metaclass object registers all 10639 objects of all kinds and indexes them with a string. The strings 10640 referencing objects have a separated namespace (well, not completely 10641 separated): 10642 10643 Namespace Class 10644 10645 words containing a "/" (slash) Distribution 10646 words starting with Bundle:: Bundle 10647 everything else Module or Author 10648 10649 Modules know their associated Distribution objects. They always refer 10650 to the most recent official release. Developers may mark their releases 10651 as unstable development versions (by inserting an underbar into the 10652 module version number which will also be reflected in the distribution 10653 name when you run 'make dist'), so the really hottest and newest 10654 distribution is not always the default. If a module Foo circulates 10655 on CPAN in both version 1.23 and 1.23_90, CPAN.pm offers a convenient 10656 way to install version 1.23 by saying 10657 10658 install Foo 10659 10660 This would install the complete distribution file (say 10661 BAR/Foo-1.23.tar.gz) with all accompanying material. But if you would 10662 like to install version 1.23_90, you need to know where the 10663 distribution file resides on CPAN relative to the authors/id/ 10664 directory. If the author is BAR, this might be BAR/Foo-1.23_90.tar.gz; 10665 so you would have to say 10666 10667 install BAR/Foo-1.23_90.tar.gz 10668 10669 The first example will be driven by an object of the class 10670 CPAN::Module, the second by an object of class CPAN::Distribution. 10671 10672 =head2 Integrating local directories 10673 10674 Note: this feature is still in alpha state and may change in future 10675 versions of CPAN.pm 10676 10677 Distribution objects are normally distributions from the CPAN, but 10678 there is a slightly degenerate case for Distribution objects, too, of 10679 projects held on the local disk. These distribution objects have the 10680 same name as the local directory and end with a dot. A dot by itself 10681 is also allowed for the current directory at the time CPAN.pm was 10682 used. All actions such as C<make>, C<test>, and C<install> are applied 10683 directly to that directory. This gives the command C<cpan .> an 10684 interesting touch: while the normal mantra of installing a CPAN module 10685 without CPAN.pm is one of 10686 10687 perl Makefile.PL perl Build.PL 10688 ( go and get prerequisites ) 10689 make ./Build 10690 make test ./Build test 10691 make install ./Build install 10692 10693 the command C<cpan .> does all of this at once. It figures out which 10694 of the two mantras is appropriate, fetches and installs all 10695 prerequisites, cares for them recursively and finally finishes the 10696 installation of the module in the current directory, be it a CPAN 10697 module or not. 10698 10699 The typical usage case is for private modules or working copies of 10700 projects from remote repositories on the local disk. 10701 10702 =head1 CONFIGURATION 10703 10704 When the CPAN module is used for the first time, a configuration 10705 dialog tries to determine a couple of site specific options. The 10706 result of the dialog is stored in a hash reference C< $CPAN::Config > 10707 in a file CPAN/Config.pm. 10708 10709 The default values defined in the CPAN/Config.pm file can be 10710 overridden in a user specific file: CPAN/MyConfig.pm. Such a file is 10711 best placed in $HOME/.cpan/CPAN/MyConfig.pm, because $HOME/.cpan is 10712 added to the search path of the CPAN module before the use() or 10713 require() statements. The mkmyconfig command writes this file for you. 10714 10715 The C<o conf> command has various bells and whistles: 10716 10717 =over 10718 10719 =item completion support 10720 10721 If you have a ReadLine module installed, you can hit TAB at any point 10722 of the commandline and C<o conf> will offer you completion for the 10723 built-in subcommands and/or config variable names. 10724 10725 =item displaying some help: o conf help 10726 10727 Displays a short help 10728 10729 =item displaying current values: o conf [KEY] 10730 10731 Displays the current value(s) for this config variable. Without KEY 10732 displays all subcommands and config variables. 10733 10734 Example: 10735 10736 o conf shell 10737 10738 If KEY starts and ends with a slash the string in between is 10739 interpreted as a regular expression and only keys matching this regex 10740 are displayed 10741 10742 Example: 10743 10744 o conf /color/ 10745 10746 =item changing of scalar values: o conf KEY VALUE 10747 10748 Sets the config variable KEY to VALUE. The empty string can be 10749 specified as usual in shells, with C<''> or C<""> 10750 10751 Example: 10752 10753 o conf wget /usr/bin/wget 10754 10755 =item changing of list values: o conf KEY SHIFT|UNSHIFT|PUSH|POP|SPLICE|LIST 10756 10757 If a config variable name ends with C<list>, it is a list. C<o conf 10758 KEY shift> removes the first element of the list, C<o conf KEY pop> 10759 removes the last element of the list. C<o conf KEYS unshift LIST> 10760 prepends a list of values to the list, C<o conf KEYS push LIST> 10761 appends a list of valued to the list. 10762 10763 Likewise, C<o conf KEY splice LIST> passes the LIST to the according 10764 splice command. 10765 10766 Finally, any other list of arguments is taken as a new list value for 10767 the KEY variable discarding the previous value. 10768 10769 Examples: 10770 10771 o conf urllist unshift http://cpan.dev.local/CPAN 10772 o conf urllist splice 3 1 10773 o conf urllist http://cpan1.local http://cpan2.local ftp://ftp.perl.org 10774 10775 =item reverting to saved: o conf defaults 10776 10777 Reverts all config variables to the state in the saved config file. 10778 10779 =item saving the config: o conf commit 10780 10781 Saves all config variables to the current config file (CPAN/Config.pm 10782 or CPAN/MyConfig.pm that was loaded at start). 10783 10784 =back 10785 10786 The configuration dialog can be started any time later again by 10787 issuing the command C< o conf init > in the CPAN shell. A subset of 10788 the configuration dialog can be run by issuing C<o conf init WORD> 10789 where WORD is any valid config variable or a regular expression. 10790 10791 =head2 Config Variables 10792 10793 Currently the following keys in the hash reference $CPAN::Config are 10794 defined: 10795 10796 applypatch path to external prg 10797 auto_commit commit all changes to config variables to disk 10798 build_cache size of cache for directories to build modules 10799 build_dir locally accessible directory to build modules 10800 build_dir_reuse boolean if distros in build_dir are persistent 10801 build_requires_install_policy 10802 to install or not to install when a module is 10803 only needed for building. yes|no|ask/yes|ask/no 10804 bzip2 path to external prg 10805 cache_metadata use serializer to cache metadata 10806 commands_quote prefered character to use for quoting external 10807 commands when running them. Defaults to double 10808 quote on Windows, single tick everywhere else; 10809 can be set to space to disable quoting 10810 check_sigs if signatures should be verified 10811 colorize_debug Term::ANSIColor attributes for debugging output 10812 colorize_output boolean if Term::ANSIColor should colorize output 10813 colorize_print Term::ANSIColor attributes for normal output 10814 colorize_warn Term::ANSIColor attributes for warnings 10815 commandnumber_in_prompt 10816 boolean if you want to see current command number 10817 cpan_home local directory reserved for this package 10818 curl path to external prg 10819 dontload_hash DEPRECATED 10820 dontload_list arrayref: modules in the list will not be 10821 loaded by the CPAN::has_inst() routine 10822 ftp path to external prg 10823 ftp_passive if set, the envariable FTP_PASSIVE is set for downloads 10824 ftp_proxy proxy host for ftp requests 10825 getcwd see below 10826 gpg path to external prg 10827 gzip location of external program gzip 10828 histfile file to maintain history between sessions 10829 histsize maximum number of lines to keep in histfile 10830 http_proxy proxy host for http requests 10831 inactivity_timeout breaks interactive Makefile.PLs or Build.PLs 10832 after this many seconds inactivity. Set to 0 to 10833 never break. 10834 index_expire after this many days refetch index files 10835 inhibit_startup_message 10836 if true, does not print the startup message 10837 keep_source_where directory in which to keep the source (if we do) 10838 load_module_verbosity 10839 report loading of optional modules used by CPAN.pm 10840 lynx path to external prg 10841 make location of external make program 10842 make_arg arguments that should always be passed to 'make' 10843 make_install_make_command 10844 the make command for running 'make install', for 10845 example 'sudo make' 10846 make_install_arg same as make_arg for 'make install' 10847 makepl_arg arguments passed to 'perl Makefile.PL' 10848 mbuild_arg arguments passed to './Build' 10849 mbuild_install_arg arguments passed to './Build install' 10850 mbuild_install_build_command 10851 command to use instead of './Build' when we are 10852 in the install stage, for example 'sudo ./Build' 10853 mbuildpl_arg arguments passed to 'perl Build.PL' 10854 ncftp path to external prg 10855 ncftpget path to external prg 10856 no_proxy don't proxy to these hosts/domains (comma separated list) 10857 pager location of external program more (or any pager) 10858 password your password if you CPAN server wants one 10859 patch path to external prg 10860 prefer_installer legal values are MB and EUMM: if a module comes 10861 with both a Makefile.PL and a Build.PL, use the 10862 former (EUMM) or the latter (MB); if the module 10863 comes with only one of the two, that one will be 10864 used in any case 10865 prerequisites_policy 10866 what to do if you are missing module prerequisites 10867 ('follow' automatically, 'ask' me, or 'ignore') 10868 prefs_dir local directory to store per-distro build options 10869 proxy_user username for accessing an authenticating proxy 10870 proxy_pass password for accessing an authenticating proxy 10871 randomize_urllist add some randomness to the sequence of the urllist 10872 scan_cache controls scanning of cache ('atstart' or 'never') 10873 shell your favorite shell 10874 show_unparsable_versions 10875 boolean if r command tells which modules are versionless 10876 show_upload_date boolean if commands should try to determine upload date 10877 show_zero_versions boolean if r command tells for which modules $version==0 10878 tar location of external program tar 10879 tar_verbosity verbosity level for the tar command 10880 term_is_latin deprecated: if true Unicode is translated to ISO-8859-1 10881 (and nonsense for characters outside latin range) 10882 term_ornaments boolean to turn ReadLine ornamenting on/off 10883 test_report email test reports (if CPAN::Reporter is installed) 10884 unzip location of external program unzip 10885 urllist arrayref to nearby CPAN sites (or equivalent locations) 10886 use_sqlite use CPAN::SQLite for metadata storage (fast and lean) 10887 username your username if you CPAN server wants one 10888 wait_list arrayref to a wait server to try (See CPAN::WAIT) 10889 wget path to external prg 10890 yaml_load_code enable YAML code deserialisation 10891 yaml_module which module to use to read/write YAML files 10892 10893 You can set and query each of these options interactively in the cpan 10894 shell with the C<o conf> or the C<o conf init> command as specified below. 10895 10896 =over 2 10897 10898 =item C<o conf E<lt>scalar optionE<gt>> 10899 10900 prints the current value of the I<scalar option> 10901 10902 =item C<o conf E<lt>scalar optionE<gt> E<lt>valueE<gt>> 10903 10904 Sets the value of the I<scalar option> to I<value> 10905 10906 =item C<o conf E<lt>list optionE<gt>> 10907 10908 prints the current value of the I<list option> in MakeMaker's 10909 neatvalue format. 10910 10911 =item C<o conf E<lt>list optionE<gt> [shift|pop]> 10912 10913 shifts or pops the array in the I<list option> variable 10914 10915 =item C<o conf E<lt>list optionE<gt> [unshift|push|splice] E<lt>listE<gt>> 10916 10917 works like the corresponding perl commands. 10918 10919 =item interactive editing: o conf init [MATCH|LIST] 10920 10921 Runs an interactive configuration dialog for matching variables. 10922 Without argument runs the dialog over all supported config variables. 10923 To specify a MATCH the argument must be enclosed by slashes. 10924 10925 Examples: 10926 10927 o conf init ftp_passive ftp_proxy 10928 o conf init /color/ 10929 10930 Note: this method of setting config variables often provides more 10931 explanation about the functioning of a variable than the manpage. 10932 10933 =back 10934 10935 =head2 CPAN::anycwd($path): Note on config variable getcwd 10936 10937 CPAN.pm changes the current working directory often and needs to 10938 determine its own current working directory. Per default it uses 10939 Cwd::cwd but if this doesn't work on your system for some reason, 10940 alternatives can be configured according to the following table: 10941 10942 =over 4 10943 10944 =item cwd 10945 10946 Calls Cwd::cwd 10947 10948 =item getcwd 10949 10950 Calls Cwd::getcwd 10951 10952 =item fastcwd 10953 10954 Calls Cwd::fastcwd 10955 10956 =item backtickcwd 10957 10958 Calls the external command cwd. 10959 10960 =back 10961 10962 =head2 Note on the format of the urllist parameter 10963 10964 urllist parameters are URLs according to RFC 1738. We do a little 10965 guessing if your URL is not compliant, but if you have problems with 10966 C<file> URLs, please try the correct format. Either: 10967 10968 file://localhost/whatever/ftp/pub/CPAN/ 10969 10970 or 10971 10972 file:///home/ftp/pub/CPAN/ 10973 10974 =head2 The urllist parameter has CD-ROM support 10975 10976 The C<urllist> parameter of the configuration table contains a list of 10977 URLs that are to be used for downloading. If the list contains any 10978 C<file> URLs, CPAN always tries to get files from there first. This 10979 feature is disabled for index files. So the recommendation for the 10980 owner of a CD-ROM with CPAN contents is: include your local, possibly 10981 outdated CD-ROM as a C<file> URL at the end of urllist, e.g. 10982 10983 o conf urllist push file://localhost/CDROM/CPAN 10984 10985 CPAN.pm will then fetch the index files from one of the CPAN sites 10986 that come at the beginning of urllist. It will later check for each 10987 module if there is a local copy of the most recent version. 10988 10989 Another peculiarity of urllist is that the site that we could 10990 successfully fetch the last file from automatically gets a preference 10991 token and is tried as the first site for the next request. So if you 10992 add a new site at runtime it may happen that the previously preferred 10993 site will be tried another time. This means that if you want to disallow 10994 a site for the next transfer, it must be explicitly removed from 10995 urllist. 10996 10997 =head2 Maintaining the urllist parameter 10998 10999 If you have YAML.pm (or some other YAML module configured in 11000 C<yaml_module>) installed, CPAN.pm collects a few statistical data 11001 about recent downloads. You can view the statistics with the C<hosts> 11002 command or inspect them directly by looking into the C<FTPstats.yml> 11003 file in your C<cpan_home> directory. 11004 11005 To get some interesting statistics it is recommended to set the 11006 C<randomize_urllist> parameter that introduces some amount of 11007 randomness into the URL selection. 11008 11009 =head2 The C<requires> and C<build_requires> dependency declarations 11010 11011 Since CPAN.pm version 1.88_51 modules declared as C<build_requires> by 11012 a distribution are treated differently depending on the config 11013 variable C<build_requires_install_policy>. By setting 11014 C<build_requires_install_policy> to C<no> such a module is not being 11015 installed. It is only built and tested and then kept in the list of 11016 tested but uninstalled modules. As such it is available during the 11017 build of the dependent module by integrating the path to the 11018 C<blib/arch> and C<blib/lib> directories in the environment variable 11019 PERL5LIB. If C<build_requires_install_policy> is set ti C<yes>, then 11020 both modules declared as C<requires> and those declared as 11021 C<build_requires> are treated alike. By setting to C<ask/yes> or 11022 C<ask/no>, CPAN.pm asks the user and sets the default accordingly. 11023 11024 =head2 Configuration for individual distributions (I<Distroprefs>) 11025 11026 (B<Note:> This feature has been introduced in CPAN.pm 1.8854 and is 11027 still considered beta quality) 11028 11029 Distributions on the CPAN usually behave according to what we call the 11030 CPAN mantra. Or since the event of Module::Build we should talk about 11031 two mantras: 11032 11033 perl Makefile.PL perl Build.PL 11034 make ./Build 11035 make test ./Build test 11036 make install ./Build install 11037 11038 But some modules cannot be built with this mantra. They try to get 11039 some extra data from the user via the environment, extra arguments or 11040 interactively thus disturbing the installation of large bundles like 11041 Phalanx100 or modules with many dependencies like Plagger. 11042 11043 The distroprefs system of C<CPAN.pm> addresses this problem by 11044 allowing the user to specify extra informations and recipes in YAML 11045 files to either 11046 11047 =over 11048 11049 =item 11050 11051 pass additional arguments to one of the four commands, 11052 11053 =item 11054 11055 set environment variables 11056 11057 =item 11058 11059 instantiate an Expect object that reads from the console, waits for 11060 some regular expressions and enters some answers 11061 11062 =item 11063 11064 temporarily override assorted C<CPAN.pm> configuration variables 11065 11066 =item 11067 11068 specify dependencies that the original maintainer forgot to specify 11069 11070 =item 11071 11072 disable the installation of an object altogether 11073 11074 =back 11075 11076 See the YAML and Data::Dumper files that come with the C<CPAN.pm> 11077 distribution in the C<distroprefs/> directory for examples. 11078 11079 =head2 Filenames 11080 11081 The YAML files themselves must have the C<.yml> extension, all other 11082 files are ignored (for two exceptions see I<Fallback Data::Dumper and 11083 Storable> below). The containing directory can be specified in 11084 C<CPAN.pm> in the C<prefs_dir> config variable. Try C<o conf init 11085 prefs_dir> in the CPAN shell to set and activate the distroprefs 11086 system. 11087 11088 Every YAML file may contain arbitrary documents according to the YAML 11089 specification and every single document is treated as an entity that 11090 can specify the treatment of a single distribution. 11091 11092 The names of the files can be picked freely, C<CPAN.pm> always reads 11093 all files (in alphabetical order) and takes the key C<match> (see 11094 below in I<Language Specs>) as a hashref containing match criteria 11095 that determine if the current distribution matches the YAML document 11096 or not. 11097 11098 =head2 Fallback Data::Dumper and Storable 11099 11100 If neither your configured C<yaml_module> nor YAML.pm is installed 11101 CPAN.pm falls back to using Data::Dumper and Storable and looks for 11102 files with the extensions C<.dd> or C<.st> in the C<prefs_dir> 11103 directory. These files are expected to contain one or more hashrefs. 11104 For Data::Dumper generated files, this is expected to be done with by 11105 defining C<$VAR1>, C<$VAR2>, etc. The YAML shell would produce these 11106 with the command 11107 11108 ysh < somefile.yml > somefile.dd 11109 11110 For Storable files the rule is that they must be constructed such that 11111 C<Storable::retrieve(file)> returns an array reference and the array 11112 elements represent one distropref object each. The conversion from 11113 YAML would look like so: 11114 11115 perl -MYAML=LoadFile -MStorable=nstore -e ' 11116 @y=LoadFile(shift); 11117 nstore(\@y, shift)' somefile.yml somefile.st 11118 11119 In bootstrapping situations it is usually sufficient to translate only 11120 a few YAML files to Data::Dumper for the crucial modules like 11121 C<YAML::Syck>, C<YAML.pm> and C<Expect.pm>. If you prefer Storable 11122 over Data::Dumper, remember to pull out a Storable version that writes 11123 an older format than all the other Storable versions that will need to 11124 read them. 11125 11126 =head2 Blueprint 11127 11128 The following example contains all supported keywords and structures 11129 with the exception of C<eexpect> which can be used instead of 11130 C<expect>. 11131 11132 --- 11133 comment: "Demo" 11134 match: 11135 module: "Dancing::Queen" 11136 distribution: "^CHACHACHA/Dancing-" 11137 perl: "/usr/local/cariba-perl/bin/perl" 11138 perlconfig: 11139 archname: "freebsd" 11140 disabled: 1 11141 cpanconfig: 11142 make: gmake 11143 pl: 11144 args: 11145 - "--somearg=specialcase" 11146 11147 env: {} 11148 11149 expect: 11150 - "Which is your favorite fruit" 11151 - "apple\n" 11152 11153 make: 11154 args: 11155 - all 11156 - extra-all 11157 11158 env: {} 11159 11160 expect: [] 11161 11162 commendline: "echo SKIPPING make" 11163 11164 test: 11165 args: [] 11166 11167 env: {} 11168 11169 expect: [] 11170 11171 install: 11172 args: [] 11173 11174 env: 11175 WANT_TO_INSTALL: YES 11176 11177 expect: 11178 - "Do you really want to install" 11179 - "y\n" 11180 11181 patches: 11182 - "ABCDE/Fedcba-3.14-ABCDE-01.patch" 11183 11184 depends: 11185 configure_requires: 11186 LWP: 5.8 11187 build_requires: 11188 Test::Exception: 0.25 11189 requires: 11190 Spiffy: 0.30 11191 11192 11193 =head2 Language Specs 11194 11195 Every YAML document represents a single hash reference. The valid keys 11196 in this hash are as follows: 11197 11198 =over 11199 11200 =item comment [scalar] 11201 11202 A comment 11203 11204 =item cpanconfig [hash] 11205 11206 Temporarily override assorted C<CPAN.pm> configuration variables. 11207 11208 Supported are: C<build_requires_install_policy>, C<check_sigs>, 11209 C<make>, C<make_install_make_command>, C<prefer_installer>, 11210 C<test_report>. Please report as a bug when you need another one 11211 supported. 11212 11213 =item depends [hash] *** EXPERIMENTAL FEATURE *** 11214 11215 All three types, namely C<configure_requires>, C<build_requires>, and 11216 C<requires> are supported in the way specified in the META.yml 11217 specification. The current implementation I<merges> the specified 11218 dependencies with those declared by the package maintainer. In a 11219 future implementation this may be changed to override the original 11220 declaration. 11221 11222 =item disabled [boolean] 11223 11224 Specifies that this distribution shall not be processed at all. 11225 11226 =item goto [string] 11227 11228 The canonical name of a delegate distribution that shall be installed 11229 instead. Useful when a new version, although it tests OK itself, 11230 breaks something else or a developer release or a fork is already 11231 uploaded that is better than the last released version. 11232 11233 =item install [hash] 11234 11235 Processing instructions for the C<make install> or C<./Build install> 11236 phase of the CPAN mantra. See below under I<Processiong Instructions>. 11237 11238 =item make [hash] 11239 11240 Processing instructions for the C<make> or C<./Build> phase of the 11241 CPAN mantra. See below under I<Processiong Instructions>. 11242 11243 =item match [hash] 11244 11245 A hashref with one or more of the keys C<distribution>, C<modules>, 11246 C<perl>, and C<perlconfig> that specify if a document is targeted at a 11247 specific CPAN distribution or installation. 11248 11249 The corresponding values are interpreted as regular expressions. The 11250 C<distribution> related one will be matched against the canonical 11251 distribution name, e.g. "AUTHOR/Foo-Bar-3.14.tar.gz". 11252 11253 The C<module> related one will be matched against I<all> modules 11254 contained in the distribution until one module matches. 11255 11256 The C<perl> related one will be matched against C<$^X> (but with the 11257 absolute path). 11258 11259 The value associated with C<perlconfig> is itself a hashref that is 11260 matched against corresponding values in the C<%Config::Config> hash 11261 living in the C< Config.pm > module. 11262 11263 If more than one restriction of C<module>, C<distribution>, and 11264 C<perl> is specified, the results of the separately computed match 11265 values must all match. If this is the case then the hashref 11266 represented by the YAML document is returned as the preference 11267 structure for the current distribution. 11268 11269 =item patches [array] 11270 11271 An array of patches on CPAN or on the local disk to be applied in 11272 order via the external patch program. If the value for the C<-p> 11273 parameter is C<0> or C<1> is determined by reading the patch 11274 beforehand. 11275 11276 Note: if the C<applypatch> program is installed and C<CPAN::Config> 11277 knows about it B<and> a patch is written by the C<makepatch> program, 11278 then C<CPAN.pm> lets C<applypatch> apply the patch. Both C<makepatch> 11279 and C<applypatch> are available from CPAN in the C<JV/makepatch-*> 11280 distribution. 11281 11282 =item pl [hash] 11283 11284 Processing instructions for the C<perl Makefile.PL> or C<perl 11285 Build.PL> phase of the CPAN mantra. See below under I<Processiong 11286 Instructions>. 11287 11288 =item test [hash] 11289 11290 Processing instructions for the C<make test> or C<./Build test> phase 11291 of the CPAN mantra. See below under I<Processiong Instructions>. 11292 11293 =back 11294 11295 =head2 Processing Instructions 11296 11297 =over 11298 11299 =item args [array] 11300 11301 Arguments to be added to the command line 11302 11303 =item commandline 11304 11305 A full commandline that will be executed as it stands by a system 11306 call. During the execution the environment variable PERL will is set 11307 to $^X (but with an absolute path). If C<commandline> is specified, 11308 the content of C<args> is not used. 11309 11310 =item eexpect [hash] 11311 11312 Extended C<expect>. This is a hash reference with four allowed keys, 11313 C<mode>, C<timeout>, C<reuse>, and C<talk>. 11314 11315 C<mode> may have the values C<deterministic> for the case where all 11316 questions come in the order written down and C<anyorder> for the case 11317 where the questions may come in any order. The default mode is 11318 C<deterministic>. 11319 11320 C<timeout> denotes a timeout in seconds. Floating point timeouts are 11321 OK. In the case of a C<mode=deterministic> the timeout denotes the 11322 timeout per question, in the case of C<mode=anyorder> it denotes the 11323 timeout per byte received from the stream or questions. 11324 11325 C<talk> is a reference to an array that contains alternating questions 11326 and answers. Questions are regular expressions and answers are literal 11327 strings. The Expect module will then watch the stream coming from the 11328 execution of the external program (C<perl Makefile.PL>, C<perl 11329 Build.PL>, C<make>, etc.). 11330 11331 In the case of C<mode=deterministic> the CPAN.pm will inject the 11332 according answer as soon as the stream matches the regular expression. 11333 11334 In the case of C<mode=anyorder> CPAN.pm will answer a question as soon 11335 as the timeout is reached for the next byte in the input stream. In 11336 this mode you can use the C<reuse> parameter to decide what shall 11337 happen with a question-answer pair after it has been used. In the 11338 default case (reuse=0) it is removed from the array, so it cannot be 11339 used again accidentally. In this case, if you want to answer the 11340 question C<Do you really want to do that> several times, then it must 11341 be included in the array at least as often as you want this answer to 11342 be given. Setting the parameter C<reuse> to 1 makes this repetition 11343 unnecessary. 11344 11345 =item env [hash] 11346 11347 Environment variables to be set during the command 11348 11349 =item expect [array] 11350 11351 C<< expect: <array> >> is a short notation for 11352 11353 eexpect: 11354 mode: deterministic 11355 timeout: 15 11356 talk: <array> 11357 11358 =back 11359 11360 =head2 Schema verification with C<Kwalify> 11361 11362 If you have the C<Kwalify> module installed (which is part of the 11363 Bundle::CPANxxl), then all your distroprefs files are checked for 11364 syntactical correctness. 11365 11366 =head2 Example Distroprefs Files 11367 11368 C<CPAN.pm> comes with a collection of example YAML files. Note that these 11369 are really just examples and should not be used without care because 11370 they cannot fit everybody's purpose. After all the authors of the 11371 packages that ask questions had a need to ask, so you should watch 11372 their questions and adjust the examples to your environment and your 11373 needs. You have beend warned:-) 11374 11375 =head1 PROGRAMMER'S INTERFACE 11376 11377 If you do not enter the shell, the available shell commands are both 11378 available as methods (C<CPAN::Shell-E<gt>install(...)>) and as 11379 functions in the calling package (C<install(...)>). Before calling low-level 11380 commands it makes sense to initialize components of CPAN you need, e.g.: 11381 11382 CPAN::HandleConfig->load; 11383 CPAN::Shell::setup_output; 11384 CPAN::Index->reload; 11385 11386 High-level commands do such initializations automatically. 11387 11388 There's currently only one class that has a stable interface - 11389 CPAN::Shell. All commands that are available in the CPAN shell are 11390 methods of the class CPAN::Shell. Each of the commands that produce 11391 listings of modules (C<r>, C<autobundle>, C<u>) also return a list of 11392 the IDs of all modules within the list. 11393 11394 =over 2 11395 11396 =item expand($type,@things) 11397 11398 The IDs of all objects available within a program are strings that can 11399 be expanded to the corresponding real objects with the 11400 C<CPAN::Shell-E<gt>expand("Module",@things)> method. Expand returns a 11401 list of CPAN::Module objects according to the C<@things> arguments 11402 given. In scalar context it only returns the first element of the 11403 list. 11404 11405 =item expandany(@things) 11406 11407 Like expand, but returns objects of the appropriate type, i.e. 11408 CPAN::Bundle objects for bundles, CPAN::Module objects for modules and 11409 CPAN::Distribution objects for distributions. Note: it does not expand 11410 to CPAN::Author objects. 11411 11412 =item Programming Examples 11413 11414 This enables the programmer to do operations that combine 11415 functionalities that are available in the shell. 11416 11417 # install everything that is outdated on my disk: 11418 perl -MCPAN -e 'CPAN::Shell->install(CPAN::Shell->r)' 11419 11420 # install my favorite programs if necessary: 11421 for $mod (qw(Net::FTP Digest::SHA Data::Dumper)) { 11422 CPAN::Shell->install($mod); 11423 } 11424 11425 # list all modules on my disk that have no VERSION number 11426 for $mod (CPAN::Shell->expand("Module","/./")) { 11427 next unless $mod->inst_file; 11428 # MakeMaker convention for undefined $VERSION: 11429 next unless $mod->inst_version eq "undef"; 11430 print "No VERSION in ", $mod->id, "\n"; 11431 } 11432 11433 # find out which distribution on CPAN contains a module: 11434 print CPAN::Shell->expand("Module","Apache::Constants")->cpan_file 11435 11436 Or if you want to write a cronjob to watch The CPAN, you could list 11437 all modules that need updating. First a quick and dirty way: 11438 11439 perl -e 'use CPAN; CPAN::Shell->r;' 11440 11441 If you don't want to get any output in the case that all modules are 11442 up to date, you can parse the output of above command for the regular 11443 expression //modules are up to date// and decide to mail the output 11444 only if it doesn't match. Ick? 11445 11446 If you prefer to do it more in a programmer style in one single 11447 process, maybe something like this suits you better: 11448 11449 # list all modules on my disk that have newer versions on CPAN 11450 for $mod (CPAN::Shell->expand("Module","/./")) { 11451 next unless $mod->inst_file; 11452 next if $mod->uptodate; 11453 printf "Module %s is installed as %s, could be updated to %s from CPAN\n", 11454 $mod->id, $mod->inst_version, $mod->cpan_version; 11455 } 11456 11457 If that gives you too much output every day, you maybe only want to 11458 watch for three modules. You can write 11459 11460 for $mod (CPAN::Shell->expand("Module","/Apache|LWP|CGI/")) { 11461 11462 as the first line instead. Or you can combine some of the above 11463 tricks: 11464 11465 # watch only for a new mod_perl module 11466 $mod = CPAN::Shell->expand("Module","mod_perl"); 11467 exit if $mod->uptodate; 11468 # new mod_perl arrived, let me know all update recommendations 11469 CPAN::Shell->r; 11470 11471 =back 11472 11473 =head2 Methods in the other Classes 11474 11475 =over 4 11476 11477 =item CPAN::Author::as_glimpse() 11478 11479 Returns a one-line description of the author 11480 11481 =item CPAN::Author::as_string() 11482 11483 Returns a multi-line description of the author 11484 11485 =item CPAN::Author::email() 11486 11487 Returns the author's email address 11488 11489 =item CPAN::Author::fullname() 11490 11491 Returns the author's name 11492 11493 =item CPAN::Author::name() 11494 11495 An alias for fullname 11496 11497 =item CPAN::Bundle::as_glimpse() 11498 11499 Returns a one-line description of the bundle 11500 11501 =item CPAN::Bundle::as_string() 11502 11503 Returns a multi-line description of the bundle 11504 11505 =item CPAN::Bundle::clean() 11506 11507 Recursively runs the C<clean> method on all items contained in the bundle. 11508 11509 =item CPAN::Bundle::contains() 11510 11511 Returns a list of objects' IDs contained in a bundle. The associated 11512 objects may be bundles, modules or distributions. 11513 11514 =item CPAN::Bundle::force($method,@args) 11515 11516 Forces CPAN to perform a task that it normally would have refused to 11517 do. Force takes as arguments a method name to be called and any number 11518 of additional arguments that should be passed to the called method. 11519 The internals of the object get the needed changes so that CPAN.pm 11520 does not refuse to take the action. The C<force> is passed recursively 11521 to all contained objects. See also the section above on the C<force> 11522 and the C<fforce> pragma. 11523 11524 =item CPAN::Bundle::get() 11525 11526 Recursively runs the C<get> method on all items contained in the bundle 11527 11528 =item CPAN::Bundle::inst_file() 11529 11530 Returns the highest installed version of the bundle in either @INC or 11531 C<$CPAN::Config->{cpan_home}>. Note that this is different from 11532 CPAN::Module::inst_file. 11533 11534 =item CPAN::Bundle::inst_version() 11535 11536 Like CPAN::Bundle::inst_file, but returns the $VERSION 11537 11538 =item CPAN::Bundle::uptodate() 11539 11540 Returns 1 if the bundle itself and all its members are uptodate. 11541 11542 =item CPAN::Bundle::install() 11543 11544 Recursively runs the C<install> method on all items contained in the bundle 11545 11546 =item CPAN::Bundle::make() 11547 11548 Recursively runs the C<make> method on all items contained in the bundle 11549 11550 =item CPAN::Bundle::readme() 11551 11552 Recursively runs the C<readme> method on all items contained in the bundle 11553 11554 =item CPAN::Bundle::test() 11555 11556 Recursively runs the C<test> method on all items contained in the bundle 11557 11558 =item CPAN::Distribution::as_glimpse() 11559 11560 Returns a one-line description of the distribution 11561 11562 =item CPAN::Distribution::as_string() 11563 11564 Returns a multi-line description of the distribution 11565 11566 =item CPAN::Distribution::author 11567 11568 Returns the CPAN::Author object of the maintainer who uploaded this 11569 distribution 11570 11571 =item CPAN::Distribution::pretty_id() 11572 11573 Returns a string of the form "AUTHORID/TARBALL", where AUTHORID is the 11574 author's PAUSE ID and TARBALL is the distribution filename. 11575 11576 =item CPAN::Distribution::base_id() 11577 11578 Returns the distribution filename without any archive suffix. E.g 11579 "Foo-Bar-0.01" 11580 11581 =item CPAN::Distribution::clean() 11582 11583 Changes to the directory where the distribution has been unpacked and 11584 runs C<make clean> there. 11585 11586 =item CPAN::Distribution::containsmods() 11587 11588 Returns a list of IDs of modules contained in a distribution file. 11589 Only works for distributions listed in the 02packages.details.txt.gz 11590 file. This typically means that only the most recent version of a 11591 distribution is covered. 11592 11593 =item CPAN::Distribution::cvs_import() 11594 11595 Changes to the directory where the distribution has been unpacked and 11596 runs something like 11597 11598 cvs -d $cvs_root import -m $cvs_log $cvs_dir $userid v$version 11599 11600 there. 11601 11602 =item CPAN::Distribution::dir() 11603 11604 Returns the directory into which this distribution has been unpacked. 11605 11606 =item CPAN::Distribution::force($method,@args) 11607 11608 Forces CPAN to perform a task that it normally would have refused to 11609 do. Force takes as arguments a method name to be called and any number 11610 of additional arguments that should be passed to the called method. 11611 The internals of the object get the needed changes so that CPAN.pm 11612 does not refuse to take the action. See also the section above on the 11613 C<force> and the C<fforce> pragma. 11614 11615 =item CPAN::Distribution::get() 11616 11617 Downloads the distribution from CPAN and unpacks it. Does nothing if 11618 the distribution has already been downloaded and unpacked within the 11619 current session. 11620 11621 =item CPAN::Distribution::install() 11622 11623 Changes to the directory where the distribution has been unpacked and 11624 runs the external command C<make install> there. If C<make> has not 11625 yet been run, it will be run first. A C<make test> will be issued in 11626 any case and if this fails, the install will be canceled. The 11627 cancellation can be avoided by letting C<force> run the C<install> for 11628 you. 11629 11630 This install method has only the power to install the distribution if 11631 there are no dependencies in the way. To install an object and all of 11632 its dependencies, use CPAN::Shell->install. 11633 11634 Note that install() gives no meaningful return value. See uptodate(). 11635 11636 =item CPAN::Distribution::install_tested() 11637 11638 Install all the distributions that have been tested sucessfully but 11639 not yet installed. See also C<is_tested>. 11640 11641 =item CPAN::Distribution::isa_perl() 11642 11643 Returns 1 if this distribution file seems to be a perl distribution. 11644 Normally this is derived from the file name only, but the index from 11645 CPAN can contain a hint to achieve a return value of true for other 11646 filenames too. 11647 11648 =item CPAN::Distribution::is_tested() 11649 11650 List all the distributions that have been tested sucessfully but not 11651 yet installed. See also C<install_tested>. 11652 11653 =item CPAN::Distribution::look() 11654 11655 Changes to the directory where the distribution has been unpacked and 11656 opens a subshell there. Exiting the subshell returns. 11657 11658 =item CPAN::Distribution::make() 11659 11660 First runs the C<get> method to make sure the distribution is 11661 downloaded and unpacked. Changes to the directory where the 11662 distribution has been unpacked and runs the external commands C<perl 11663 Makefile.PL> or C<perl Build.PL> and C<make> there. 11664 11665 =item CPAN::Distribution::perldoc() 11666 11667 Downloads the pod documentation of the file associated with a 11668 distribution (in html format) and runs it through the external 11669 command lynx specified in C<$CPAN::Config->{lynx}>. If lynx 11670 isn't available, it converts it to plain text with external 11671 command html2text and runs it through the pager specified 11672 in C<$CPAN::Config->{pager}> 11673 11674 =item CPAN::Distribution::prefs() 11675 11676 Returns the hash reference from the first matching YAML file that the 11677 user has deposited in the C<prefs_dir/> directory. The first 11678 succeeding match wins. The files in the C<prefs_dir/> are processed 11679 alphabetically and the canonical distroname (e.g. 11680 AUTHOR/Foo-Bar-3.14.tar.gz) is matched against the regular expressions 11681 stored in the $root->{match}{distribution} attribute value. 11682 Additionally all module names contained in a distribution are matched 11683 agains the regular expressions in the $root->{match}{module} attribute 11684 value. The two match values are ANDed together. Each of the two 11685 attributes are optional. 11686 11687 =item CPAN::Distribution::prereq_pm() 11688 11689 Returns the hash reference that has been announced by a distribution 11690 as the the C<requires> and C<build_requires> elements. These can be 11691 declared either by the C<META.yml> (if authoritative) or can be 11692 deposited after the run of C<Build.PL> in the file C<./_build/prereqs> 11693 or after the run of C<Makfile.PL> written as the C<PREREQ_PM> hash in 11694 a comment in the produced C<Makefile>. I<Note>: this method only works 11695 after an attempt has been made to C<make> the distribution. Returns 11696 undef otherwise. 11697 11698 =item CPAN::Distribution::readme() 11699 11700 Downloads the README file associated with a distribution and runs it 11701 through the pager specified in C<$CPAN::Config->{pager}>. 11702 11703 =item CPAN::Distribution::reports() 11704 11705 Downloads report data for this distribution from cpantesters.perl.org 11706 and displays a subset of them. 11707 11708 =item CPAN::Distribution::read_yaml() 11709 11710 Returns the content of the META.yml of this distro as a hashref. Note: 11711 works only after an attempt has been made to C<make> the distribution. 11712 Returns undef otherwise. Also returns undef if the content of META.yml 11713 is not authoritative. (The rules about what exactly makes the content 11714 authoritative are still in flux.) 11715 11716 =item CPAN::Distribution::test() 11717 11718 Changes to the directory where the distribution has been unpacked and 11719 runs C<make test> there. 11720 11721 =item CPAN::Distribution::uptodate() 11722 11723 Returns 1 if all the modules contained in the distribution are 11724 uptodate. Relies on containsmods. 11725 11726 =item CPAN::Index::force_reload() 11727 11728 Forces a reload of all indices. 11729 11730 =item CPAN::Index::reload() 11731 11732 Reloads all indices if they have not been read for more than 11733 C<$CPAN::Config->{index_expire}> days. 11734 11735 =item CPAN::InfoObj::dump() 11736 11737 CPAN::Author, CPAN::Bundle, CPAN::Module, and CPAN::Distribution 11738 inherit this method. It prints the data structure associated with an 11739 object. Useful for debugging. Note: the data structure is considered 11740 internal and thus subject to change without notice. 11741 11742 =item CPAN::Module::as_glimpse() 11743 11744 Returns a one-line description of the module in four columns: The 11745 first column contains the word C<Module>, the second column consists 11746 of one character: an equals sign if this module is already installed 11747 and uptodate, a less-than sign if this module is installed but can be 11748 upgraded, and a space if the module is not installed. The third column 11749 is the name of the module and the fourth column gives maintainer or 11750 distribution information. 11751 11752 =item CPAN::Module::as_string() 11753 11754 Returns a multi-line description of the module 11755 11756 =item CPAN::Module::clean() 11757 11758 Runs a clean on the distribution associated with this module. 11759 11760 =item CPAN::Module::cpan_file() 11761 11762 Returns the filename on CPAN that is associated with the module. 11763 11764 =item CPAN::Module::cpan_version() 11765 11766 Returns the latest version of this module available on CPAN. 11767 11768 =item CPAN::Module::cvs_import() 11769 11770 Runs a cvs_import on the distribution associated with this module. 11771 11772 =item CPAN::Module::description() 11773 11774 Returns a 44 character description of this module. Only available for 11775 modules listed in The Module List (CPAN/modules/00modlist.long.html 11776 or 00modlist.long.txt.gz) 11777 11778 =item CPAN::Module::distribution() 11779 11780 Returns the CPAN::Distribution object that contains the current 11781 version of this module. 11782 11783 =item CPAN::Module::dslip_status() 11784 11785 Returns a hash reference. The keys of the hash are the letters C<D>, 11786 C<S>, C<L>, C<I>, and <P>, for development status, support level, 11787 language, interface and public licence respectively. The data for the 11788 DSLIP status are collected by pause.perl.org when authors register 11789 their namespaces. The values of the 5 hash elements are one-character 11790 words whose meaning is described in the table below. There are also 5 11791 hash elements C<DV>, C<SV>, C<LV>, C<IV>, and <PV> that carry a more 11792 verbose value of the 5 status variables. 11793 11794 Where the 'DSLIP' characters have the following meanings: 11795 11796 D - Development Stage (Note: *NO IMPLIED TIMESCALES*): 11797 i - Idea, listed to gain consensus or as a placeholder 11798 c - under construction but pre-alpha (not yet released) 11799 a/b - Alpha/Beta testing 11800 R - Released 11801 M - Mature (no rigorous definition) 11802 S - Standard, supplied with Perl 5 11803 11804 S - Support Level: 11805 m - Mailing-list 11806 d - Developer 11807 u - Usenet newsgroup comp.lang.perl.modules 11808 n - None known, try comp.lang.perl.modules 11809 a - abandoned; volunteers welcome to take over maintainance 11810 11811 L - Language Used: 11812 p - Perl-only, no compiler needed, should be platform independent 11813 c - C and perl, a C compiler will be needed 11814 h - Hybrid, written in perl with optional C code, no compiler needed 11815 + - C++ and perl, a C++ compiler will be needed 11816 o - perl and another language other than C or C++ 11817 11818 I - Interface Style 11819 f - plain Functions, no references used 11820 h - hybrid, object and function interfaces available 11821 n - no interface at all (huh?) 11822 r - some use of unblessed References or ties 11823 O - Object oriented using blessed references and/or inheritance 11824 11825 P - Public License 11826 p - Standard-Perl: user may choose between GPL and Artistic 11827 g - GPL: GNU General Public License 11828 l - LGPL: "GNU Lesser General Public License" (previously known as 11829 "GNU Library General Public License") 11830 b - BSD: The BSD License 11831 a - Artistic license alone 11832 2 - Artistic license 2.0 or later 11833 o - open source: appoved by www.opensource.org 11834 d - allows distribution without restrictions 11835 r - restricted distribtion 11836 n - no license at all 11837 11838 =item CPAN::Module::force($method,@args) 11839 11840 Forces CPAN to perform a task that it normally would have refused to 11841 do. Force takes as arguments a method name to be called and any number 11842 of additional arguments that should be passed to the called method. 11843 The internals of the object get the needed changes so that CPAN.pm 11844 does not refuse to take the action. See also the section above on the 11845 C<force> and the C<fforce> pragma. 11846 11847 =item CPAN::Module::get() 11848 11849 Runs a get on the distribution associated with this module. 11850 11851 =item CPAN::Module::inst_file() 11852 11853 Returns the filename of the module found in @INC. The first file found 11854 is reported just like perl itself stops searching @INC when it finds a 11855 module. 11856 11857 =item CPAN::Module::available_file() 11858 11859 Returns the filename of the module found in PERL5LIB or @INC. The 11860 first file found is reported. The advantage of this method over 11861 C<inst_file> is that modules that have been tested but not yet 11862 installed are included because PERL5LIB keeps track of tested modules. 11863 11864 =item CPAN::Module::inst_version() 11865 11866 Returns the version number of the installed module in readable format. 11867 11868 =item CPAN::Module::available_version() 11869 11870 Returns the version number of the available module in readable format. 11871 11872 =item CPAN::Module::install() 11873 11874 Runs an C<install> on the distribution associated with this module. 11875 11876 =item CPAN::Module::look() 11877 11878 Changes to the directory where the distribution associated with this 11879 module has been unpacked and opens a subshell there. Exiting the 11880 subshell returns. 11881 11882 =item CPAN::Module::make() 11883 11884 Runs a C<make> on the distribution associated with this module. 11885 11886 =item CPAN::Module::manpage_headline() 11887 11888 If module is installed, peeks into the module's manpage, reads the 11889 headline and returns it. Moreover, if the module has been downloaded 11890 within this session, does the equivalent on the downloaded module even 11891 if it is not installed. 11892 11893 =item CPAN::Module::perldoc() 11894 11895 Runs a C<perldoc> on this module. 11896 11897 =item CPAN::Module::readme() 11898 11899 Runs a C<readme> on the distribution associated with this module. 11900 11901 =item CPAN::Module::reports() 11902 11903 Calls the reports() method on the associated distribution object. 11904 11905 =item CPAN::Module::test() 11906 11907 Runs a C<test> on the distribution associated with this module. 11908 11909 =item CPAN::Module::uptodate() 11910 11911 Returns 1 if the module is installed and up-to-date. 11912 11913 =item CPAN::Module::userid() 11914 11915 Returns the author's ID of the module. 11916 11917 =back 11918 11919 =head2 Cache Manager 11920 11921 Currently the cache manager only keeps track of the build directory 11922 ($CPAN::Config->{build_dir}). It is a simple FIFO mechanism that 11923 deletes complete directories below C<build_dir> as soon as the size of 11924 all directories there gets bigger than $CPAN::Config->{build_cache} 11925 (in MB). The contents of this cache may be used for later 11926 re-installations that you intend to do manually, but will never be 11927 trusted by CPAN itself. This is due to the fact that the user might 11928 use these directories for building modules on different architectures. 11929 11930 There is another directory ($CPAN::Config->{keep_source_where}) where 11931 the original distribution files are kept. This directory is not 11932 covered by the cache manager and must be controlled by the user. If 11933 you choose to have the same directory as build_dir and as 11934 keep_source_where directory, then your sources will be deleted with 11935 the same fifo mechanism. 11936 11937 =head2 Bundles 11938 11939 A bundle is just a perl module in the namespace Bundle:: that does not 11940 define any functions or methods. It usually only contains documentation. 11941 11942 It starts like a perl module with a package declaration and a $VERSION 11943 variable. After that the pod section looks like any other pod with the 11944 only difference being that I<one special pod section> exists starting with 11945 (verbatim): 11946 11947 =head1 CONTENTS 11948 11949 In this pod section each line obeys the format 11950 11951 Module_Name [Version_String] [- optional text] 11952 11953 The only required part is the first field, the name of a module 11954 (e.g. Foo::Bar, ie. I<not> the name of the distribution file). The rest 11955 of the line is optional. The comment part is delimited by a dash just 11956 as in the man page header. 11957 11958 The distribution of a bundle should follow the same convention as 11959 other distributions. 11960 11961 Bundles are treated specially in the CPAN package. If you say 'install 11962 Bundle::Tkkit' (assuming such a bundle exists), CPAN will install all 11963 the modules in the CONTENTS section of the pod. You can install your 11964 own Bundles locally by placing a conformant Bundle file somewhere into 11965 your @INC path. The autobundle() command which is available in the 11966 shell interface does that for you by including all currently installed 11967 modules in a snapshot bundle file. 11968 11969 =head1 PREREQUISITES 11970 11971 If you have a local mirror of CPAN and can access all files with 11972 "file:" URLs, then you only need a perl better than perl5.003 to run 11973 this module. Otherwise Net::FTP is strongly recommended. LWP may be 11974 required for non-UNIX systems or if your nearest CPAN site is 11975 associated with a URL that is not C<ftp:>. 11976 11977 If you have neither Net::FTP nor LWP, there is a fallback mechanism 11978 implemented for an external ftp command or for an external lynx 11979 command. 11980 11981 =head1 UTILITIES 11982 11983 =head2 Finding packages and VERSION 11984 11985 This module presumes that all packages on CPAN 11986 11987 =over 2 11988 11989 =item * 11990 11991 declare their $VERSION variable in an easy to parse manner. This 11992 prerequisite can hardly be relaxed because it consumes far too much 11993 memory to load all packages into the running program just to determine 11994 the $VERSION variable. Currently all programs that are dealing with 11995 version use something like this 11996 11997 perl -MExtUtils::MakeMaker -le \ 11998 'print MM->parse_version(shift)' filename 11999 12000 If you are author of a package and wonder if your $VERSION can be 12001 parsed, please try the above method. 12002 12003 =item * 12004 12005 come as compressed or gzipped tarfiles or as zip files and contain a 12006 C<Makefile.PL> or C<Build.PL> (well, we try to handle a bit more, but 12007 without much enthusiasm). 12008 12009 =back 12010 12011 =head2 Debugging 12012 12013 The debugging of this module is a bit complex, because we have 12014 interferences of the software producing the indices on CPAN, of the 12015 mirroring process on CPAN, of packaging, of configuration, of 12016 synchronicity, and of bugs within CPAN.pm. 12017 12018 For debugging the code of CPAN.pm itself in interactive mode some more 12019 or less useful debugging aid can be turned on for most packages within 12020 CPAN.pm with one of 12021 12022 =over 2 12023 12024 =item o debug package... 12025 12026 sets debug mode for packages. 12027 12028 =item o debug -package... 12029 12030 unsets debug mode for packages. 12031 12032 =item o debug all 12033 12034 turns debugging on for all packages. 12035 12036 =item o debug number 12037 12038 =back 12039 12040 which sets the debugging packages directly. Note that C<o debug 0> 12041 turns debugging off. 12042 12043 What seems quite a successful strategy is the combination of C<reload 12044 cpan> and the debugging switches. Add a new debug statement while 12045 running in the shell and then issue a C<reload cpan> and see the new 12046 debugging messages immediately without losing the current context. 12047 12048 C<o debug> without an argument lists the valid package names and the 12049 current set of packages in debugging mode. C<o debug> has built-in 12050 completion support. 12051 12052 For debugging of CPAN data there is the C<dump> command which takes 12053 the same arguments as make/test/install and outputs each object's 12054 Data::Dumper dump. If an argument looks like a perl variable and 12055 contains one of C<$>, C<@> or C<%>, it is eval()ed and fed to 12056 Data::Dumper directly. 12057 12058 =head2 Floppy, Zip, Offline Mode 12059 12060 CPAN.pm works nicely without network too. If you maintain machines 12061 that are not networked at all, you should consider working with file: 12062 URLs. Of course, you have to collect your modules somewhere first. So 12063 you might use CPAN.pm to put together all you need on a networked 12064 machine. Then copy the $CPAN::Config->{keep_source_where} (but not 12065 $CPAN::Config->{build_dir}) directory on a floppy. This floppy is kind 12066 of a personal CPAN. CPAN.pm on the non-networked machines works nicely 12067 with this floppy. See also below the paragraph about CD-ROM support. 12068 12069 =head2 Basic Utilities for Programmers 12070 12071 =over 2 12072 12073 =item has_inst($module) 12074 12075 Returns true if the module is installed. Used to load all modules into 12076 the running CPAN.pm which are considered optional. The config variable 12077 C<dontload_list> can be used to intercept the C<has_inst()> call such 12078 that an optional module is not loaded despite being available. For 12079 example the following command will prevent that C<YAML.pm> is being 12080 loaded: 12081 12082 cpan> o conf dontload_list push YAML 12083 12084 See the source for details. 12085 12086 =item has_usable($module) 12087 12088 Returns true if the module is installed and is in a usable state. Only 12089 useful for a handful of modules that are used internally. See the 12090 source for details. 12091 12092 =item instance($module) 12093 12094 The constructor for all the singletons used to represent modules, 12095 distributions, authors and bundles. If the object already exists, this 12096 method returns the object, otherwise it calls the constructor. 12097 12098 =back 12099 12100 =head1 SECURITY 12101 12102 There's no strong security layer in CPAN.pm. CPAN.pm helps you to 12103 install foreign, unmasked, unsigned code on your machine. We compare 12104 to a checksum that comes from the net just as the distribution file 12105 itself. But we try to make it easy to add security on demand: 12106 12107 =head2 Cryptographically signed modules 12108 12109 Since release 1.77 CPAN.pm has been able to verify cryptographically 12110 signed module distributions using Module::Signature. The CPAN modules 12111 can be signed by their authors, thus giving more security. The simple 12112 unsigned MD5 checksums that were used before by CPAN protect mainly 12113 against accidental file corruption. 12114 12115 You will need to have Module::Signature installed, which in turn 12116 requires that you have at least one of Crypt::OpenPGP module or the 12117 command-line F<gpg> tool installed. 12118 12119 You will also need to be able to connect over the Internet to the public 12120 keyservers, like pgp.mit.edu, and their port 11731 (the HKP protocol). 12121 12122 The configuration parameter check_sigs is there to turn signature 12123 checking on or off. 12124 12125 =head1 EXPORT 12126 12127 Most functions in package CPAN are exported per default. The reason 12128 for this is that the primary use is intended for the cpan shell or for 12129 one-liners. 12130 12131 =head1 ENVIRONMENT 12132 12133 When the CPAN shell enters a subshell via the look command, it sets 12134 the environment CPAN_SHELL_LEVEL to 1 or increments it if it is 12135 already set. 12136 12137 When CPAN runs, it sets the environment variable PERL5_CPAN_IS_RUNNING 12138 to the ID of the running process. It also sets 12139 PERL5_CPANPLUS_IS_RUNNING to prevent runaway processes which could 12140 happen with older versions of Module::Install. 12141 12142 When running C<perl Makefile.PL>, the environment variable 12143 C<PERL5_CPAN_IS_EXECUTING> is set to the full path of the 12144 C<Makefile.PL> that is being executed. This prevents runaway processes 12145 with newer versions of Module::Install. 12146 12147 When the config variable ftp_passive is set, all downloads will be run 12148 with the environment variable FTP_PASSIVE set to this value. This is 12149 in general a good idea as it influences both Net::FTP and LWP based 12150 connections. The same effect can be achieved by starting the cpan 12151 shell with this environment variable set. For Net::FTP alone, one can 12152 also always set passive mode by running libnetcfg. 12153 12154 =head1 POPULATE AN INSTALLATION WITH LOTS OF MODULES 12155 12156 Populating a freshly installed perl with my favorite modules is pretty 12157 easy if you maintain a private bundle definition file. To get a useful 12158 blueprint of a bundle definition file, the command autobundle can be used 12159 on the CPAN shell command line. This command writes a bundle definition 12160 file for all modules that are installed for the currently running perl 12161 interpreter. It's recommended to run this command only once and from then 12162 on maintain the file manually under a private name, say 12163 Bundle/my_bundle.pm. With a clever bundle file you can then simply say 12164 12165 cpan> install Bundle::my_bundle 12166 12167 then answer a few questions and then go out for a coffee. 12168 12169 Maintaining a bundle definition file means keeping track of two 12170 things: dependencies and interactivity. CPAN.pm sometimes fails on 12171 calculating dependencies because not all modules define all MakeMaker 12172 attributes correctly, so a bundle definition file should specify 12173 prerequisites as early as possible. On the other hand, it's a bit 12174 annoying that many distributions need some interactive configuring. So 12175 what I try to accomplish in my private bundle file is to have the 12176 packages that need to be configured early in the file and the gentle 12177 ones later, so I can go out after a few minutes and leave CPAN.pm 12178 untended. 12179 12180 =head1 WORKING WITH CPAN.pm BEHIND FIREWALLS 12181 12182 Thanks to Graham Barr for contributing the following paragraphs about 12183 the interaction between perl, and various firewall configurations. For 12184 further information on firewalls, it is recommended to consult the 12185 documentation that comes with the ncftp program. If you are unable to 12186 go through the firewall with a simple Perl setup, it is very likely 12187 that you can configure ncftp so that it works for your firewall. 12188 12189 =head2 Three basic types of firewalls 12190 12191 Firewalls can be categorized into three basic types. 12192 12193 =over 4 12194 12195 =item http firewall 12196 12197 This is where the firewall machine runs a web server and to access the 12198 outside world you must do it via the web server. If you set environment 12199 variables like http_proxy or ftp_proxy to a values beginning with http:// 12200 or in your web browser you have to set proxy information then you know 12201 you are running an http firewall. 12202 12203 To access servers outside these types of firewalls with perl (even for 12204 ftp) you will need to use LWP. 12205 12206 =item ftp firewall 12207 12208 This where the firewall machine runs an ftp server. This kind of 12209 firewall will only let you access ftp servers outside the firewall. 12210 This is usually done by connecting to the firewall with ftp, then 12211 entering a username like "user@outside.host.com" 12212 12213 To access servers outside these type of firewalls with perl you 12214 will need to use Net::FTP. 12215 12216 =item One way visibility 12217 12218 I say one way visibility as these firewalls try to make themselves look 12219 invisible to the users inside the firewall. An FTP data connection is 12220 normally created by sending the remote server your IP address and then 12221 listening for the connection. But the remote server will not be able to 12222 connect to you because of the firewall. So for these types of firewall 12223 FTP connections need to be done in a passive mode. 12224 12225 There are two that I can think off. 12226 12227 =over 4 12228 12229 =item SOCKS 12230 12231 If you are using a SOCKS firewall you will need to compile perl and link 12232 it with the SOCKS library, this is what is normally called a 'socksified' 12233 perl. With this executable you will be able to connect to servers outside 12234 the firewall as if it is not there. 12235 12236 =item IP Masquerade 12237 12238 This is the firewall implemented in the Linux kernel, it allows you to 12239 hide a complete network behind one IP address. With this firewall no 12240 special compiling is needed as you can access hosts directly. 12241 12242 For accessing ftp servers behind such firewalls you usually need to 12243 set the environment variable C<FTP_PASSIVE> or the config variable 12244 ftp_passive to a true value. 12245 12246 =back 12247 12248 =back 12249 12250 =head2 Configuring lynx or ncftp for going through a firewall 12251 12252 If you can go through your firewall with e.g. lynx, presumably with a 12253 command such as 12254 12255 /usr/local/bin/lynx -pscott:tiger 12256 12257 then you would configure CPAN.pm with the command 12258 12259 o conf lynx "/usr/local/bin/lynx -pscott:tiger" 12260 12261 That's all. Similarly for ncftp or ftp, you would configure something 12262 like 12263 12264 o conf ncftp "/usr/bin/ncftp -f /home/scott/ncftplogin.cfg" 12265 12266 Your mileage may vary... 12267 12268 =head1 FAQ 12269 12270 =over 4 12271 12272 =item 1) 12273 12274 I installed a new version of module X but CPAN keeps saying, 12275 I have the old version installed 12276 12277 Most probably you B<do> have the old version installed. This can 12278 happen if a module installs itself into a different directory in the 12279 @INC path than it was previously installed. This is not really a 12280 CPAN.pm problem, you would have the same problem when installing the 12281 module manually. The easiest way to prevent this behaviour is to add 12282 the argument C<UNINST=1> to the C<make install> call, and that is why 12283 many people add this argument permanently by configuring 12284 12285 o conf make_install_arg UNINST=1 12286 12287 =item 2) 12288 12289 So why is UNINST=1 not the default? 12290 12291 Because there are people who have their precise expectations about who 12292 may install where in the @INC path and who uses which @INC array. In 12293 fine tuned environments C<UNINST=1> can cause damage. 12294 12295 =item 3) 12296 12297 I want to clean up my mess, and install a new perl along with 12298 all modules I have. How do I go about it? 12299 12300 Run the autobundle command for your old perl and optionally rename the 12301 resulting bundle file (e.g. Bundle/mybundle.pm), install the new perl 12302 with the Configure option prefix, e.g. 12303 12304 ./Configure -Dprefix=/usr/local/perl-5.6.78.9 12305 12306 Install the bundle file you produced in the first step with something like 12307 12308 cpan> install Bundle::mybundle 12309 12310 and you're done. 12311 12312 =item 4) 12313 12314 When I install bundles or multiple modules with one command 12315 there is too much output to keep track of. 12316 12317 You may want to configure something like 12318 12319 o conf make_arg "| tee -ai /root/.cpan/logs/make.out" 12320 o conf make_install_arg "| tee -ai /root/.cpan/logs/make_install.out" 12321 12322 so that STDOUT is captured in a file for later inspection. 12323 12324 12325 =item 5) 12326 12327 I am not root, how can I install a module in a personal directory? 12328 12329 First of all, you will want to use your own configuration, not the one 12330 that your root user installed. If you do not have permission to write 12331 in the cpan directory that root has configured, you will be asked if 12332 you want to create your own config. Answering "yes" will bring you into 12333 CPAN's configuration stage, using the system config for all defaults except 12334 things that have to do with CPAN's work directory, saving your choices to 12335 your MyConfig.pm file. 12336 12337 You can also manually initiate this process with the following command: 12338 12339 % perl -MCPAN -e 'mkmyconfig' 12340 12341 or by running 12342 12343 mkmyconfig 12344 12345 from the CPAN shell. 12346 12347 You will most probably also want to configure something like this: 12348 12349 o conf makepl_arg "LIB=~/myperl/lib \ 12350 INSTALLMAN1DIR=~/myperl/man/man1 \ 12351 INSTALLMAN3DIR=~/myperl/man/man3 \ 12352 INSTALLSCRIPT=~/myperl/bin \ 12353 INSTALLBIN=~/myperl/bin" 12354 12355 and then (oh joy) the equivalent command for Module::Build. That would 12356 be 12357 12358 o conf mbuildpl_arg "--lib=~/myperl/lib \ 12359 --installman1dir=~/myperl/man/man1 \ 12360 --installman3dir=~/myperl/man/man3 \ 12361 --installscript=~/myperl/bin \ 12362 --installbin=~/myperl/bin" 12363 12364 You can make this setting permanent like all C<o conf> settings with 12365 C<o conf commit> or by setting C<auto_commit> beforehand. 12366 12367 You will have to add ~/myperl/man to the MANPATH environment variable 12368 and also tell your perl programs to look into ~/myperl/lib, e.g. by 12369 including 12370 12371 use lib "$ENV{HOME}/myperl/lib"; 12372 12373 or setting the PERL5LIB environment variable. 12374 12375 While we're speaking about $ENV{HOME}, it might be worth mentioning, 12376 that for Windows we use the File::HomeDir module that provides an 12377 equivalent to the concept of the home directory on Unix. 12378 12379 Another thing you should bear in mind is that the UNINST parameter can 12380 be dangerous when you are installing into a private area because you 12381 might accidentally remove modules that other people depend on that are 12382 not using the private area. 12383 12384 =item 6) 12385 12386 How to get a package, unwrap it, and make a change before building it? 12387 12388 Have a look at the C<look> (!) command. 12389 12390 =item 7) 12391 12392 I installed a Bundle and had a couple of fails. When I 12393 retried, everything resolved nicely. Can this be fixed to work 12394 on first try? 12395 12396 The reason for this is that CPAN does not know the dependencies of all 12397 modules when it starts out. To decide about the additional items to 12398 install, it just uses data found in the META.yml file or the generated 12399 Makefile. An undetected missing piece breaks the process. But it may 12400 well be that your Bundle installs some prerequisite later than some 12401 depending item and thus your second try is able to resolve everything. 12402 Please note, CPAN.pm does not know the dependency tree in advance and 12403 cannot sort the queue of things to install in a topologically correct 12404 order. It resolves perfectly well IF all modules declare the 12405 prerequisites correctly with the PREREQ_PM attribute to MakeMaker or 12406 the C<requires> stanza of Module::Build. For bundles which fail and 12407 you need to install often, it is recommended to sort the Bundle 12408 definition file manually. 12409 12410 =item 8) 12411 12412 In our intranet we have many modules for internal use. How 12413 can I integrate these modules with CPAN.pm but without uploading 12414 the modules to CPAN? 12415 12416 Have a look at the CPAN::Site module. 12417 12418 =item 9) 12419 12420 When I run CPAN's shell, I get an error message about things in my 12421 /etc/inputrc (or ~/.inputrc) file. 12422 12423 These are readline issues and can only be fixed by studying readline 12424 configuration on your architecture and adjusting the referenced file 12425 accordingly. Please make a backup of the /etc/inputrc or ~/.inputrc 12426 and edit them. Quite often harmless changes like uppercasing or 12427 lowercasing some arguments solves the problem. 12428 12429 =item 10) 12430 12431 Some authors have strange characters in their names. 12432 12433 Internally CPAN.pm uses the UTF-8 charset. If your terminal is 12434 expecting ISO-8859-1 charset, a converter can be activated by setting 12435 term_is_latin to a true value in your config file. One way of doing so 12436 would be 12437 12438 cpan> o conf term_is_latin 1 12439 12440 If other charset support is needed, please file a bugreport against 12441 CPAN.pm at rt.cpan.org and describe your needs. Maybe we can extend 12442 the support or maybe UTF-8 terminals become widely available. 12443 12444 Note: this config variable is deprecated and will be removed in a 12445 future version of CPAN.pm. It will be replaced with the conventions 12446 around the family of $LANG and $LC_* environment variables. 12447 12448 =item 11) 12449 12450 When an install fails for some reason and then I correct the error 12451 condition and retry, CPAN.pm refuses to install the module, saying 12452 C<Already tried without success>. 12453 12454 Use the force pragma like so 12455 12456 force install Foo::Bar 12457 12458 Or you can use 12459 12460 look Foo::Bar 12461 12462 and then 'make install' directly in the subshell. 12463 12464 =item 12) 12465 12466 How do I install a "DEVELOPER RELEASE" of a module? 12467 12468 By default, CPAN will install the latest non-developer release of a 12469 module. If you want to install a dev release, you have to specify the 12470 partial path starting with the author id to the tarball you wish to 12471 install, like so: 12472 12473 cpan> install KWILLIAMS/Module-Build-0.27_07.tar.gz 12474 12475 Note that you can use the C<ls> command to get this path listed. 12476 12477 =item 13) 12478 12479 How do I install a module and all its dependencies from the commandline, 12480 without being prompted for anything, despite my CPAN configuration 12481 (or lack thereof)? 12482 12483 CPAN uses ExtUtils::MakeMaker's prompt() function to ask its questions, so 12484 if you set the PERL_MM_USE_DEFAULT environment variable, you shouldn't be 12485 asked any questions at all (assuming the modules you are installing are 12486 nice about obeying that variable as well): 12487 12488 % PERL_MM_USE_DEFAULT=1 perl -MCPAN -e 'install My::Module' 12489 12490 =item 14) 12491 12492 How do I create a Module::Build based Build.PL derived from an 12493 ExtUtils::MakeMaker focused Makefile.PL? 12494 12495 http://search.cpan.org/search?query=Module::Build::Convert 12496 12497 http://www.refcnt.org/papers/module-build-convert 12498 12499 =item 15) 12500 12501 What's the best CPAN site for me? 12502 12503 The urllist config parameter is yours. You can add and remove sites at 12504 will. You should find out which sites have the best uptodateness, 12505 bandwidth, reliability, etc. and are topologically close to you. Some 12506 people prefer fast downloads, others uptodateness, others reliability. 12507 You decide which to try in which order. 12508 12509 Henk P. Penning maintains a site that collects data about CPAN sites: 12510 12511 http://www.cs.uu.nl/people/henkp/mirmon/cpan.html 12512 12513 =item 16) 12514 12515 Why do I get asked the same questions every time I start the shell? 12516 12517 You can make your configuration changes permanent by calling the 12518 command C<o conf commit>. Alternatively set the C<auto_commit> 12519 variable to true by running C<o conf init auto_commit> and answering 12520 the following question with yes. 12521 12522 =back 12523 12524 =head1 COMPATIBILITY 12525 12526 =head2 OLD PERL VERSIONS 12527 12528 CPAN.pm is regularly tested to run under 5.004, 5.005, and assorted 12529 newer versions. It is getting more and more difficult to get the 12530 minimal prerequisites working on older perls. It is close to 12531 impossible to get the whole Bundle::CPAN working there. If you're in 12532 the position to have only these old versions, be advised that CPAN is 12533 designed to work fine without the Bundle::CPAN installed. 12534 12535 To get things going, note that GBARR/Scalar-List-Utils-1.18.tar.gz is 12536 compatible with ancient perls and that File::Temp is listed as a 12537 prerequisite but CPAN has reasonable workarounds if it is missing. 12538 12539 =head2 CPANPLUS 12540 12541 This module and its competitor, the CPANPLUS module, are both much 12542 cooler than the other. CPAN.pm is older. CPANPLUS was designed to be 12543 more modular but it was never tried to make it compatible with CPAN.pm. 12544 12545 =head1 SECURITY ADVICE 12546 12547 This software enables you to upgrade software on your computer and so 12548 is inherently dangerous because the newly installed software may 12549 contain bugs and may alter the way your computer works or even make it 12550 unusable. Please consider backing up your data before every upgrade. 12551 12552 =head1 BUGS 12553 12554 Please report bugs via L<http://rt.cpan.org/> 12555 12556 Before submitting a bug, please make sure that the traditional method 12557 of building a Perl module package from a shell by following the 12558 installation instructions of that package still works in your 12559 environment. 12560 12561 =head1 AUTHOR 12562 12563 Andreas Koenig C<< <andk@cpan.org> >> 12564 12565 =head1 LICENSE 12566 12567 This program is free software; you can redistribute it and/or 12568 modify it under the same terms as Perl itself. 12569 12570 See L<http://www.perl.com/perl/misc/Artistic.html> 12571 12572 =head1 TRANSLATIONS 12573 12574 Kawai,Takanori provides a Japanese translation of this manpage at 12575 L<http://homepage3.nifty.com/hippo2000/perltips/CPAN.htm> 12576 12577 =head1 SEE ALSO 12578 12579 L<cpan>, L<CPAN::Nox>, L<CPAN::Version> 12580 12581 =cut 12582 12583
title
Description
Body
title
Description
Body
title
Description
Body
title
Body
| Generated: Tue Mar 17 22:47:18 2015 | Cross-referenced by PHPXref 0.7.1 |