| [ Index ] |
PHP Cross Reference of Unnamed Project |
[Summary view] [Print] [Text view]
1 package CPANPLUS::Module; 2 3 use strict; 4 use vars qw[@ISA]; 5 6 7 use CPANPLUS::Dist; 8 use CPANPLUS::Error; 9 use CPANPLUS::Module::Signature; 10 use CPANPLUS::Module::Checksums; 11 use CPANPLUS::Internals::Constants; 12 13 use FileHandle; 14 15 use Locale::Maketext::Simple Class => 'CPANPLUS', Style => 'gettext'; 16 use IPC::Cmd qw[can_run run]; 17 use File::Find qw[find]; 18 use Params::Check qw[check]; 19 use Module::Load::Conditional qw[can_load check_install]; 20 21 $Params::Check::VERBOSE = 1; 22 23 @ISA = qw[ CPANPLUS::Module::Signature CPANPLUS::Module::Checksums]; 24 25 =pod 26 27 =head1 NAME 28 29 CPANPLUS::Module 30 31 =head1 SYNOPSIS 32 33 ### get a module object from the CPANPLUS::Backend object 34 my $mod = $cb->module_tree('Some::Module'); 35 36 ### accessors 37 $mod->version; 38 $mod->package; 39 40 ### methods 41 $mod->fetch; 42 $mod->extract; 43 $mod->install; 44 45 46 =head1 DESCRIPTION 47 48 C<CPANPLUS::Module> creates objects from the information in the 49 source files. These can then be used to query and perform actions 50 on, like fetching or installing. 51 52 These objects should only be created internally. For C<fake> objects, 53 there's the C<CPANPLUS::Module::Fake> class. To obtain a module object 54 consult the C<CPANPLUS::Backend> documentation. 55 56 =cut 57 58 my $tmpl = { 59 module => { default => '', required => 1 }, # full module name 60 version => { default => '0.0' }, # version number 61 path => { default => '', required => 1 }, # extended path on the 62 # cpan mirror, like 63 # /author/id/K/KA/KANE 64 comment => { default => ''}, # comment on module 65 package => { default => '', required => 1 }, # package name, like 66 # 'bar-baz-1.03.tgz' 67 description => { default => '' }, # description of the 68 # module 69 dslip => { default => EMPTY_DSLIP }, # dslip information 70 _id => { required => 1 }, # id of the Internals 71 # parent object 72 _status => { no_override => 1 }, # stores status object 73 author => { default => '', required => 1, 74 allow => IS_AUTHOBJ }, # module author 75 mtime => { default => '' }, 76 }; 77 78 ### some of these will be resolved by wrapper functions that 79 ### do Clever Things to find the actual value, so don't create 80 ### an autogenerated sub for that just here, take an alternate 81 ### name to allow for a wrapper 82 { my %rename = ( 83 dslip => '_dslip' 84 ); 85 86 ### autogenerate accessors ### 87 for my $key ( keys %$tmpl ) { 88 no strict 'refs'; 89 90 my $sub = $rename{$key} || $key; 91 92 *{__PACKAGE__."::$sub"} = sub { 93 $_[0]->{$key} = $_[1] if @_ > 1; 94 return $_[0]->{$key}; 95 } 96 } 97 } 98 99 100 =pod 101 102 =head1 CLASS METHODS 103 104 =head2 accessors () 105 106 Returns a list of all accessor methods to the object 107 108 =cut 109 110 ### *name is an alias, include it explicitly 111 sub accessors { return ('name', keys %$tmpl) }; 112 113 =head1 ACCESSORS 114 115 An objects of this class has the following accessors: 116 117 =over 4 118 119 =item name 120 121 Name of the module. 122 123 =item module 124 125 Name of the module. 126 127 =item version 128 129 Version of the module. Defaults to '0.0' if none was provided. 130 131 =item path 132 133 Extended path on the mirror. 134 135 =item comment 136 137 Any comment about the module -- largely unused. 138 139 =item package 140 141 The name of the package. 142 143 =item description 144 145 Description of the module -- only registered modules have this. 146 147 =item dslip 148 149 The five character dslip string, that represents meta-data of the 150 module -- again, only registered modules have this. 151 152 =cut 153 154 sub dslip { 155 my $self = shift; 156 157 ### if this module has relevant dslip info, return it 158 return $self->_dslip if $self->_dslip ne EMPTY_DSLIP; 159 160 ### if not, look at other modules in the same package, 161 ### see if *they* have any dslip info 162 for my $mod ( $self->contains ) { 163 return $mod->_dslip if $mod->_dslip ne EMPTY_DSLIP; 164 } 165 166 ### ok, really no dslip info found, return the default 167 return EMPTY_DSLIP; 168 } 169 170 171 =pod 172 173 =item status 174 175 The C<CPANPLUS::Module::Status> object associated with this object. 176 (see below). 177 178 =item author 179 180 The C<CPANPLUS::Module::Author> object associated with this object. 181 182 =item parent 183 184 The C<CPANPLUS::Internals> object that spawned this module object. 185 186 =back 187 188 =cut 189 190 ### Alias ->name to ->module, for human beings. 191 *name = *module; 192 193 sub parent { 194 my $self = shift; 195 my $obj = CPANPLUS::Internals->_retrieve_id( $self->_id ); 196 197 return $obj; 198 } 199 200 =head1 STATUS ACCESSORS 201 202 C<CPANPLUS> caches a lot of results from method calls and saves data 203 it collected along the road for later reuse. 204 205 C<CPANPLUS> uses this internally, but it is also available for the end 206 user. You can get a status object by calling: 207 208 $modobj->status 209 210 You can then query the object as follows: 211 212 =over 4 213 214 =item installer_type 215 216 The installer type used for this distribution. Will be one of 217 'makemaker' or 'build'. This determines whether C<CPANPLUS::Dist::MM> 218 or C<CPANPLUS::Dist::Build> will be used to build this distribution. 219 220 =item dist_cpan 221 222 The dist object used to do the CPAN-side of the installation. Either 223 a C<CPANPLUS::Dist::MM> or C<CPANPLUS::Dist::Build> object. 224 225 =item dist 226 227 The custom dist object used to do the operating specific side of the 228 installation, if you've chosen to use this. For example, if you've 229 chosen to install using the C<ports> format, this may be a 230 C<CPANPLUS::Dist::Ports> object. 231 232 Undefined if you didn't specify a separate format to install through. 233 234 =item prereqs 235 236 A hashref of prereqs this distribution was found to have. Will look 237 something like this: 238 239 { Carp => 0.01, strict => 0 } 240 241 Might be undefined if the distribution didn't have any prerequisites. 242 243 =item signature 244 245 Flag indicating, if a signature check was done, whether it was OK or 246 not. 247 248 =item extract 249 250 The directory this distribution was extracted to. 251 252 =item fetch 253 254 The location this distribution was fetched to. 255 256 =item readme 257 258 The text of this distributions README file. 259 260 =item uninstall 261 262 Flag indicating if an uninstall call was done successfully. 263 264 =item created 265 266 Flag indicating if the C<create> call to your dist object was done 267 successfully. 268 269 =item installed 270 271 Flag indicating if the C<install> call to your dist object was done 272 successfully. 273 274 =item checksums 275 276 The location of this distributions CHECKSUMS file. 277 278 =item checksum_ok 279 280 Flag indicating if the checksums check was done successfully. 281 282 =item checksum_value 283 284 The checksum value this distribution is expected to have 285 286 =back 287 288 =head1 METHODS 289 290 =head2 $self = CPANPLUS::Module::new( OPTIONS ) 291 292 This method returns a C<CPANPLUS::Module> object. Normal users 293 should never call this method directly, but instead use the 294 C<CPANPLUS::Backend> to obtain module objects. 295 296 This example illustrates a C<new()> call with all required arguments: 297 298 CPANPLUS::Module->new( 299 module => 'Foo', 300 path => 'authors/id/A/AA/AAA', 301 package => 'Foo-1.0.tgz', 302 author => $author_object, 303 _id => INTERNALS_OBJECT_ID, 304 ); 305 306 Every accessor is also a valid option to pass to C<new>. 307 308 Returns a module object on success and false on failure. 309 310 =cut 311 312 313 sub new { 314 my($class, %hash) = @_; 315 316 ### don't check the template for sanity 317 ### -- we know it's good and saves a lot of performance 318 local $Params::Check::SANITY_CHECK_TEMPLATE = 0; 319 320 my $object = check( $tmpl, \%hash ) or return; 321 322 bless $object, $class; 323 324 return $object; 325 } 326 327 ### only create status objects when they're actually asked for 328 sub status { 329 my $self = shift; 330 return $self->_status if $self->_status; 331 332 my $acc = Object::Accessor->new; 333 $acc->mk_accessors( qw[ installer_type dist_cpan dist prereqs 334 signature extract fetch readme uninstall 335 created installed prepared checksums files 336 checksum_ok checksum_value _fetch_from] ); 337 338 $self->_status( $acc ); 339 340 return $self->_status; 341 } 342 343 344 ### flush the cache of this object ### 345 sub _flush { 346 my $self = shift; 347 $self->status->mk_flush; 348 return 1; 349 } 350 351 =head2 $mod->package_name 352 353 Returns the name of the package a module is in. For C<Acme::Bleach> 354 that might be C<Acme-Bleach>. 355 356 =head2 $mod->package_version 357 358 Returns the version of the package a module is in. For a module 359 in the package C<Acme-Bleach-1.1.tar.gz> this would be C<1.1>. 360 361 =head2 $mod->package_extension 362 363 Returns the suffix added by the compression method of a package a 364 certain module is in. For a module in C<Acme-Bleach-1.1.tar.gz>, this 365 would be C<tar.gz>. 366 367 =head2 $mod->package_is_perl_core 368 369 Returns a boolean indicating of the package a particular module is in, 370 is actually a core perl distribution. 371 372 =head2 $mod->module_is_supplied_with_perl_core( [version => $]] ) 373 374 Returns a boolean indicating whether C<ANY VERSION> of this module 375 was supplied with the current running perl's core package. 376 377 =head2 $mod->is_bundle 378 379 Returns a boolean indicating if the module you are looking at, is 380 actually a bundle. Bundles are identified as modules whose name starts 381 with C<Bundle::>. 382 383 =head2 $mod->is_third_party 384 385 Returns a boolean indicating whether the package is a known third-party 386 module (i.e. it's not provided by the standard Perl distribution and 387 is not available on the CPAN, but on a third party software provider). 388 See L<Module::ThirdParty> for more details. 389 390 =head2 $mod->third_party_information 391 392 Returns a reference to a hash with more information about a third-party 393 module. See the documentation about C<module_information()> in 394 L<Module::ThirdParty> for more details. 395 396 =cut 397 398 { ### fetches the test reports for a certain module ### 399 my %map = ( 400 name => 0, 401 version => 1, 402 extension => 2, 403 ); 404 405 while ( my($type, $index) = each %map ) { 406 my $name = 'package_' . $type; 407 408 no strict 'refs'; 409 *$name = sub { 410 my $self = shift; 411 my @res = $self->parent->_split_package_string( 412 package => $self->package 413 ); 414 415 ### return the corresponding index from the result 416 return $res[$index] if @res; 417 return; 418 }; 419 } 420 421 sub package_is_perl_core { 422 my $self = shift; 423 424 ### check if the package looks like a perl core package 425 return 1 if $self->package_name eq PERL_CORE; 426 427 my $core = $self->module_is_supplied_with_perl_core; 428 ### ok, so it's found in the core, BUT it could be dual-lifed 429 if ($core) { 430 ### if the package is newer than installed, then it's dual-lifed 431 return if $self->version > $self->installed_version; 432 433 ### if the package is newer or equal to the corelist, 434 ### then it's dual-lifed 435 return if $self->version >= $core; 436 437 ### otherwise, it's older than corelist, thus unsuitable. 438 return 1; 439 } 440 441 ### not in corelist, not a perl core package. 442 return; 443 } 444 445 sub module_is_supplied_with_perl_core { 446 my $self = shift; 447 my $ver = shift || $]; 448 449 ### check Module::CoreList to see if it's a core package 450 require Module::CoreList; 451 my $core = $Module::CoreList::version{ $ver }->{ $self->module }; 452 453 return $core; 454 } 455 456 ### make sure Bundle-Foo also gets flagged as bundle 457 sub is_bundle { 458 return shift->module =~ /^bundle(?:-|::)/i ? 1 : 0; 459 } 460 461 sub is_third_party { 462 my $self = shift; 463 464 return unless can_load( modules => { 'Module::ThirdParty' => 0 } ); 465 466 return Module::ThirdParty::is_3rd_party( $self->name ); 467 } 468 469 sub third_party_information { 470 my $self = shift; 471 472 return unless $self->is_third_party; 473 474 return Module::ThirdParty::module_information( $self->name ); 475 } 476 } 477 478 =pod 479 480 =head2 $clone = $self->clone 481 482 Clones the current module object for tinkering with. 483 It will have a clean C<CPANPLUS::Module::Status> object, as well as 484 a fake C<CPANPLUS::Module::Author> object. 485 486 =cut 487 488 sub clone { 489 my $self = shift; 490 491 ### clone the object ### 492 my %data; 493 for my $acc ( grep !/status/, __PACKAGE__->accessors() ) { 494 $data{$acc} = $self->$acc(); 495 } 496 497 my $obj = CPANPLUS::Module::Fake->new( %data ); 498 499 return $obj; 500 } 501 502 =pod 503 504 =head2 $where = $self->fetch 505 506 Fetches the module from a CPAN mirror. 507 Look at L<CPANPLUS::Internals::Fetch::_fetch()> for details on the 508 options you can pass. 509 510 =cut 511 512 sub fetch { 513 my $self = shift; 514 my $cb = $self->parent; 515 516 ### custom args 517 my %args = ( module => $self ); 518 519 ### if a custom fetch location got specified before, add that here 520 $args{fetch_from} = $self->status->_fetch_from 521 if $self->status->_fetch_from; 522 523 my $where = $cb->_fetch( @_, %args ) or return; 524 525 ### do an md5 check ### 526 if( !$self->status->_fetch_from and 527 $cb->configure_object->get_conf('md5') and 528 $self->package ne CHECKSUMS 529 ) { 530 unless( $self->_validate_checksum ) { 531 error( loc( "Checksum error for '%1' -- will not trust package", 532 $self->package) ); 533 return; 534 } 535 } 536 537 return $where; 538 } 539 540 =pod 541 542 =head2 $path = $self->extract 543 544 Extracts the fetched module. 545 Look at L<CPANPLUS::Internals::Extract::_extract()> for details on 546 the options you can pass. 547 548 =cut 549 550 sub extract { 551 my $self = shift; 552 my $cb = $self->parent; 553 554 unless( $self->status->fetch ) { 555 error( loc( "You have not fetched '%1' yet -- cannot extract", 556 $self->module) ); 557 return; 558 } 559 560 return $cb->_extract( @_, module => $self ); 561 } 562 563 =head2 $type = $self->get_installer_type([prefer_makefile => BOOL]) 564 565 Gets the installer type for this module. This may either be C<build> or 566 C<makemaker>. If C<Module::Build> is unavailable or no installer type 567 is available, it will fall back to C<makemaker>. If both are available, 568 it will pick the one indicated by your config, or by the 569 C<prefer_makefile> option you can pass to this function. 570 571 Returns the installer type on success, and false on error. 572 573 =cut 574 575 sub get_installer_type { 576 my $self = shift; 577 my $cb = $self->parent; 578 my $conf = $cb->configure_object; 579 my %hash = @_; 580 581 my $prefer_makefile; 582 my $tmpl = { 583 prefer_makefile => { default => $conf->get_conf('prefer_makefile'), 584 store => \$prefer_makefile, allow => BOOLEANS }, 585 }; 586 587 check( $tmpl, \%hash ) or return; 588 589 my $extract = $self->status->extract(); 590 unless( $extract ) { 591 error(loc("Cannot determine installer type of unextracted module '%1'", 592 $self->module)); 593 return; 594 } 595 596 597 ### check if it's a makemaker or a module::build type dist ### 598 my $found_build = -e BUILD_PL->( $extract ); 599 my $found_makefile = -e MAKEFILE_PL->( $extract ); 600 601 my $type; 602 $type = INSTALLER_BUILD if !$prefer_makefile && $found_build; 603 $type = INSTALLER_BUILD if $found_build && !$found_makefile; 604 $type = INSTALLER_MM if $prefer_makefile && $found_makefile; 605 $type = INSTALLER_MM if $found_makefile && !$found_build; 606 607 ### ok, so it's a 'build' installer, but you don't /have/ module build 608 if( $type eq INSTALLER_BUILD and ( 609 not grep { $_ eq INSTALLER_BUILD } CPANPLUS::Dist->dist_types ) 610 ) { 611 error( loc( "This module requires '%1' and '%2' to be installed, ". 612 "but you don't have it! Will fall back to ". 613 "'%3', but might not be able to install!", 614 'Module::Build', INSTALLER_BUILD, INSTALLER_MM ) ); 615 $type = INSTALLER_MM; 616 617 ### ok, actually we found neither ### 618 } elsif ( !$type ) { 619 error( loc( "Unable to find '%1' or '%2' for '%3'; ". 620 "Will default to '%4' but might be unable ". 621 "to install!", BUILD_PL->(), MAKEFILE_PL->(), 622 $self->module, INSTALLER_MM ) ); 623 $type = INSTALLER_MM; 624 } 625 626 return $self->status->installer_type( $type ) if $type; 627 return; 628 } 629 630 =pod 631 632 =head2 $dist = $self->dist([target => 'prepare|create', format => DISTRIBUTION_TYPE, args => {key => val}]); 633 634 Create a distribution object, ready to be installed. 635 Distribution type defaults to your config settings 636 637 The optional C<args> hashref is passed on to the specific distribution 638 types' C<create> method after being dereferenced. 639 640 Returns a distribution object on success, false on failure. 641 642 See C<CPANPLUS::Dist> for details. 643 644 =cut 645 646 sub dist { 647 my $self = shift; 648 my $cb = $self->parent; 649 my $conf = $cb->configure_object; 650 my %hash = @_; 651 652 ### have you determined your installer type yet? if not, do it here, 653 ### we need the info 654 $self->get_installer_type unless $self->status->installer_type; 655 656 657 my($type,$args,$target); 658 my $tmpl = { 659 format => { default => $conf->get_conf('dist_type') || 660 $self->status->installer_type, 661 store => \$type }, 662 target => { default => TARGET_CREATE, store => \$target }, 663 args => { default => {}, store => \$args }, 664 }; 665 666 check( $tmpl, \%hash ) or return; 667 668 my $dist = CPANPLUS::Dist->new( 669 format => $type, 670 module => $self 671 ) or return; 672 673 my $dist_cpan = $type eq $self->status->installer_type 674 ? $dist 675 : CPANPLUS::Dist->new( 676 format => $self->status->installer_type, 677 module => $self, 678 ); 679 680 ### store the dists 681 $self->status->dist_cpan( $dist_cpan ); 682 $self->status->dist( $dist ); 683 684 DIST: { 685 ### first prepare the dist 686 $dist->prepare( %$args ) or return; 687 $self->status->prepared(1); 688 689 ### you just wanted us to prepare? 690 last DIST if $target eq TARGET_PREPARE; 691 692 $dist->create( %$args ) or return; 693 $self->status->created(1); 694 } 695 696 return $dist; 697 } 698 699 =pod 700 701 =head2 $bool = $mod->prepare( ) 702 703 Convenience method around C<install()> that prepares a module 704 without actually building it. This is equivalent to invoking C<install> 705 with C<target> set to C<prepare> 706 707 Returns true on success, false on failure. 708 709 =cut 710 711 sub prepare { 712 my $self = shift; 713 return $self->install( @_, target => TARGET_PREPARE ); 714 } 715 716 =head2 $bool = $mod->create( ) 717 718 Convenience method around C<install()> that creates a module. 719 This is equivalent to invoking C<install> with C<target> set to 720 C<create> 721 722 Returns true on success, false on failure. 723 724 =cut 725 726 sub create { 727 my $self = shift; 728 return $self->install( @_, target => TARGET_CREATE ); 729 } 730 731 =head2 $bool = $mod->test( ) 732 733 Convenience wrapper around C<install()> that tests a module, without 734 installing it. 735 It's the equivalent to invoking C<install()> with C<target> set to 736 C<create> and C<skiptest> set to C<0>. 737 738 Returns true on success, false on failure. 739 740 =cut 741 742 sub test { 743 my $self = shift; 744 return $self->install( @_, target => TARGET_CREATE, skiptest => 0 ); 745 } 746 747 =pod 748 749 =head2 $bool = $self->install([ target => 'prepare|create|install', format => FORMAT_TYPE, extractdir => DIRECTORY, fetchdir => DIRECTORY, prefer_bin => BOOL, force => BOOL, verbose => BOOL, ..... ]); 750 751 Installs the current module. This includes fetching it and extracting 752 it, if this hasn't been done yet, as well as creating a distribution 753 object for it. 754 755 This means you can pass it more arguments than described above, which 756 will be passed on to the relevant methods as they are called. 757 758 See C<CPANPLUS::Internals::Fetch>, C<CPANPLUS::Internals::Extract> and 759 C<CPANPLUS::Dist> for details. 760 761 Returns true on success, false on failure. 762 763 =cut 764 765 sub install { 766 my $self = shift; 767 my $cb = $self->parent; 768 my $conf = $cb->configure_object; 769 my %hash = @_; 770 771 my $args; my $target; my $format; 772 { ### so we can use the rest of the args to the create calls etc ### 773 local $Params::Check::NO_DUPLICATES = 1; 774 local $Params::Check::ALLOW_UNKNOWN = 1; 775 776 ### targets 'dist' and 'test' are now completely ignored ### 777 my $tmpl = { 778 ### match this allow list with Dist->_resolve_prereqs 779 target => { default => TARGET_INSTALL, store => \$target, 780 allow => [TARGET_PREPARE, TARGET_CREATE, 781 TARGET_INSTALL] }, 782 force => { default => $conf->get_conf('force'), }, 783 verbose => { default => $conf->get_conf('verbose'), }, 784 format => { default => $conf->get_conf('dist_type'), 785 store => \$format }, 786 }; 787 788 $args = check( $tmpl, \%hash ) or return; 789 } 790 791 792 ### if this target isn't 'install', we will need to at least 'create' 793 ### every prereq, so it can build 794 ### XXX prereq_target of 'prepare' will do weird things here, and is 795 ### not supported. 796 $args->{'prereq_target'} ||= TARGET_CREATE if $target ne TARGET_INSTALL; 797 798 ### check if it's already upto date ### 799 if( $target eq TARGET_INSTALL and !$args->{'force'} and 800 !$self->package_is_perl_core() and # separate rules apply 801 ( $self->status->installed() or $self->is_uptodate ) and 802 !INSTALL_VIA_PACKAGE_MANAGER->($format) 803 ) { 804 msg(loc("Module '%1' already up to date, won't install without force", 805 $self->module), $args->{'verbose'} ); 806 return $self->status->installed(1); 807 } 808 809 # if it's a non-installable core package, abort the install. 810 if( $self->package_is_perl_core() ) { 811 # if the installed is newer, say so. 812 if( $self->installed_version > $self->version ) { 813 error(loc("The core Perl %1 module '%2' (%3) is more ". 814 "recent than the latest release on CPAN (%4). ". 815 "Aborting install.", 816 $], $self->module, $self->installed_version, 817 $self->version ) ); 818 # if the installed matches, say so. 819 } elsif( $self->installed_version == $self->version ) { 820 error(loc("The core Perl %1 module '%2' (%3) can only ". 821 "be installed by Perl itself. ". 822 "Aborting install.", 823 $], $self->module, $self->installed_version ) ); 824 # otherwise, the installed is older; say so. 825 } else { 826 error(loc("The core Perl %1 module '%2' can only be ". 827 "upgraded from %3 to %4 by Perl itself (%5). ". 828 "Aborting install.", 829 $], $self->module, $self->installed_version, 830 $self->version, $self->package ) ); 831 } 832 return; 833 834 ### it might be a known 3rd party module 835 } elsif ( $self->is_third_party ) { 836 my $info = $self->third_party_information; 837 error(loc( 838 "%1 is a known third-party module.\n\n". 839 "As it isn't available on the CPAN, CPANPLUS can't install " . 840 "it automatically. Therefore you need to install it manually " . 841 "before proceeding.\n\n". 842 "%2 is part of %3, published by %4, and should be available ". 843 "for download at the following address:\n\t%5", 844 $self->name, $self->name, $info->{name}, $info->{author}, 845 $info->{url} 846 )); 847 848 return; 849 } 850 851 ### fetch it if need be ### 852 unless( $self->status->fetch ) { 853 my $params; 854 for (qw[prefer_bin fetchdir]) { 855 $params->{$_} = $args->{$_} if exists $args->{$_}; 856 } 857 for (qw[force verbose]) { 858 $params->{$_} = $args->{$_} if defined $args->{$_}; 859 } 860 $self->fetch( %$params ) or return; 861 } 862 863 ### extract it if need be ### 864 unless( $self->status->extract ) { 865 my $params; 866 for (qw[prefer_bin extractdir]) { 867 $params->{$_} = $args->{$_} if exists $args->{$_}; 868 } 869 for (qw[force verbose]) { 870 $params->{$_} = $args->{$_} if defined $args->{$_}; 871 } 872 $self->extract( %$params ) or return; 873 } 874 875 $format ||= $self->status->installer_type; 876 877 unless( $format ) { 878 error( loc( "Don't know what installer to use; " . 879 "Couldn't find either '%1' or '%2' in the extraction " . 880 "directory '%3' -- will be unable to install", 881 BUILD_PL->(), MAKEFILE_PL->(), $self->status->extract ) ); 882 883 $self->status->installed(0); 884 return; 885 } 886 887 888 ### do SIGNATURE checks? ### 889 if( $conf->get_conf('signature') ) { 890 unless( $self->check_signature( verbose => $args->{verbose} ) ) { 891 error( loc( "Signature check failed for module '%1' ". 892 "-- Not trusting this module, aborting install", 893 $self->module ) ); 894 $self->status->signature(0); 895 896 ### send out test report on broken sig 897 if( $conf->get_conf('cpantest') ) { 898 $cb->_send_report( 899 module => $self, 900 failed => 1, 901 buffer => CPANPLUS::Error->stack_as_string, 902 verbose => $args->{verbose}, 903 force => $args->{force}, 904 ) or error(loc("Failed to send test report for '%1'", 905 $self->module ) ); 906 } 907 908 return; 909 910 } else { 911 ### signature OK ### 912 $self->status->signature(1); 913 } 914 } 915 916 ### a target of 'create' basically means not to run make test ### 917 ### eh, no it /doesn't/.. skiptest => 1 means skiptest => 1. 918 #$args->{'skiptest'} = 1 if $target eq 'create'; 919 920 ### bundle rules apply ### 921 if( $self->is_bundle ) { 922 ### check what we need to install ### 923 my @prereqs = $self->bundle_modules(); 924 unless( @prereqs ) { 925 error( loc( "Bundle '%1' does not specify any modules to install", 926 $self->module ) ); 927 928 ### XXX mark an error here? ### 929 } 930 } 931 932 my $dist = $self->dist( format => $format, 933 target => $target, 934 args => $args ); 935 unless( $dist ) { 936 error( loc( "Unable to create a new distribution object for '%1' " . 937 "-- cannot continue", $self->module ) ); 938 return; 939 } 940 941 return 1 if $target ne TARGET_INSTALL; 942 943 my $ok = $dist->install( %$args ) ? 1 : 0; 944 945 $self->status->installed($ok); 946 947 return 1 if $ok; 948 return; 949 } 950 951 =pod @list = $self->bundle_modules() 952 953 Returns a list of module objects the Bundle specifies. 954 955 This requires you to have extracted the bundle already, using the 956 C<extract()> method. 957 958 Returns false on error. 959 960 =cut 961 962 sub bundle_modules { 963 my $self = shift; 964 my $cb = $self->parent; 965 966 unless( $self->is_bundle ) { 967 error( loc("'%1' is not a bundle", $self->module ) ); 968 return; 969 } 970 971 my $dir; 972 unless( $dir = $self->status->extract ) { 973 error( loc("Don't know where '%1' was extracted to", $self->module ) ); 974 return; 975 } 976 977 my @files; 978 find( { 979 wanted => sub { push @files, File::Spec->rel2abs($_) if /\.pm/i; }, 980 no_chdir => 1, 981 }, $dir ); 982 983 my $prereqs = {}; my @list; my $seen = {}; 984 for my $file ( @files ) { 985 my $fh = FileHandle->new($file) 986 or( error(loc("Could not open '%1' for reading: %2", 987 $file,$!)), next ); 988 989 my $flag; 990 while(<$fh>) { 991 ### quick hack to read past the header of the file ### 992 last if $flag && m|^=head|i; 993 994 ### from perldoc cpan: 995 ### =head1 CONTENTS 996 ### In this pod section each line obeys the format 997 ### Module_Name [Version_String] [- optional text] 998 $flag = 1 if m|^=head1 CONTENTS|i; 999 1000 if ($flag && /^(?!=)(\S+)\s*(\S+)?/) { 1001 my $module = $1; 1002 my $version = $2 || '0'; 1003 1004 my $obj = $cb->module_tree($module); 1005 1006 unless( $obj ) { 1007 error(loc("Cannot find bundled module '%1'", $module), 1008 loc("-- it does not seem to exist") ); 1009 next; 1010 } 1011 1012 ### make sure we list no duplicates ### 1013 unless( $seen->{ $obj->module }++ ) { 1014 push @list, $obj; 1015 $prereqs->{ $module } = 1016 $cb->_version_to_number( version => $version ); 1017 } 1018 } 1019 } 1020 } 1021 1022 ### store the prereqs we just found ### 1023 $self->status->prereqs( $prereqs ); 1024 1025 return @list; 1026 } 1027 1028 =pod 1029 1030 =head2 $text = $self->readme 1031 1032 Fetches the readme belonging to this module and stores it under 1033 C<< $obj->status->readme >>. Returns the readme as a string on 1034 success and returns false on failure. 1035 1036 =cut 1037 1038 sub readme { 1039 my $self = shift; 1040 my $conf = $self->parent->configure_object; 1041 1042 ### did we already dl the readme once? ### 1043 return $self->status->readme() if $self->status->readme(); 1044 1045 ### this should be core ### 1046 return unless can_load( modules => { FileHandle => '0.0' }, 1047 verbose => 1, 1048 ); 1049 1050 ### get a clone of the current object, with a fresh status ### 1051 my $obj = $self->clone or return; 1052 1053 ### munge the package name 1054 my $pkg = README->( $obj ); 1055 $obj->package($pkg); 1056 1057 my $file; 1058 { ### disable checksum fetches on readme downloads 1059 1060 my $tmp = $conf->get_conf( 'md5' ); 1061 $conf->set_conf( md5 => 0 ); 1062 1063 $file = $obj->fetch; 1064 1065 $conf->set_conf( md5 => $tmp ); 1066 1067 return unless $file; 1068 } 1069 1070 ### read the file into a scalar, to store in the original object ### 1071 my $fh = new FileHandle; 1072 unless( $fh->open($file) ) { 1073 error( loc( "Could not open file '%1': %2", $file, $! ) ); 1074 return; 1075 } 1076 1077 my $in; 1078 { local $/; $in = <$fh> }; 1079 $fh->close; 1080 1081 return $self->status->readme( $in ); 1082 } 1083 1084 =pod 1085 1086 =head2 $version = $self->installed_version() 1087 1088 Returns the currently installed version of this module, if any. 1089 1090 =head2 $where = $self->installed_file() 1091 1092 Returns the location of the currently installed file of this module, 1093 if any. 1094 1095 =head2 $bool = $self->is_uptodate([version => VERSION_NUMBER]) 1096 1097 Returns a boolean indicating if this module is uptodate or not. 1098 1099 =cut 1100 1101 ### uptodate/installed functions 1102 { my $map = { # hashkey, alternate rv 1103 installed_version => ['version', 0 ], 1104 installed_file => ['file', ''], 1105 is_uptodate => ['uptodate', 0 ], 1106 }; 1107 1108 while( my($method, $aref) = each %$map ) { 1109 my($key,$alt_rv) = @$aref; 1110 1111 no strict 'refs'; 1112 *$method = sub { 1113 ### never use the @INC hooks to find installed versions of 1114 ### modules -- they're just there in case they're not on the 1115 ### perl install, but the user shouldn't trust them for *other* 1116 ### modules! 1117 ### XXX CPANPLUS::inc is now obsolete, so this should not 1118 ### be needed anymore 1119 #local @INC = CPANPLUS::inc->original_inc; 1120 1121 my $self = shift; 1122 1123 ### make sure check_install is not looking in %INC, as 1124 ### that may contain some of our sneakily loaded modules 1125 ### that aren't installed as such. -- kane 1126 local $Module::Load::Conditional::CHECK_INC_HASH = 0; 1127 my $href = check_install( 1128 module => $self->module, 1129 version => $self->version, 1130 @_, 1131 ); 1132 1133 return $href->{$key} || $alt_rv; 1134 } 1135 } 1136 } 1137 1138 1139 1140 =pod 1141 1142 =head2 $href = $self->details() 1143 1144 Returns a hashref with key/value pairs offering more information about 1145 a particular module. For example, for C<Time::HiRes> it might look like 1146 this: 1147 1148 Author Jarkko Hietaniemi (jhi@iki.fi) 1149 Description High resolution time, sleep, and alarm 1150 Development Stage Released 1151 Installed File /usr/local/perl/lib/Time/Hires.pm 1152 Interface Style plain Functions, no references used 1153 Language Used C and perl, a C compiler will be needed 1154 Package Time-HiRes-1.65.tar.gz 1155 Public License Unknown 1156 Support Level Developer 1157 Version Installed 1.52 1158 Version on CPAN 1.65 1159 1160 =cut 1161 1162 sub details { 1163 my $self = shift; 1164 my $conf = $self->parent->configure_object(); 1165 my $cb = $self->parent; 1166 my %hash = @_; 1167 1168 my $res = { 1169 Author => loc("%1 (%2)", $self->author->author(), 1170 $self->author->email() ), 1171 Package => $self->package, 1172 Description => $self->description || loc('None given'), 1173 'Version on CPAN' => $self->version, 1174 }; 1175 1176 ### check if we have the module installed 1177 ### if so, add version have and version on cpan 1178 $res->{'Version Installed'} = $self->installed_version 1179 if $self->installed_version; 1180 $res->{'Installed File'} = $self->installed_file if $self->installed_file; 1181 1182 my $i = 0; 1183 for my $item( split '', $self->dslip ) { 1184 $res->{ $cb->_dslip_defs->[$i]->[0] } = 1185 $cb->_dslip_defs->[$i]->[1]->{$item} || loc('Unknown'); 1186 $i++; 1187 } 1188 1189 return $res; 1190 } 1191 1192 =head2 @list = $self->contains() 1193 1194 Returns a list of module objects that represent the modules also 1195 present in the package of this module. 1196 1197 For example, for C<Archive::Tar> this might return: 1198 1199 Archive::Tar 1200 Archive::Tar::Constant 1201 Archive::Tar::File 1202 1203 =cut 1204 1205 sub contains { 1206 my $self = shift; 1207 my $cb = $self->parent; 1208 my $pkg = $self->package; 1209 1210 my @mods = $cb->search( type => 'package', allow => [qr/^$pkg$/] ); 1211 1212 return @mods; 1213 } 1214 1215 =pod 1216 1217 =head2 @list_of_hrefs = $self->fetch_report() 1218 1219 This function queries the CPAN testers database at 1220 I<http://testers.cpan.org/> for test results of specified module 1221 objects, module names or distributions. 1222 1223 Look at L<CPANPLUS::Internals::Report::_query_report()> for details on 1224 the options you can pass and the return value to expect. 1225 1226 =cut 1227 1228 sub fetch_report { 1229 my $self = shift; 1230 my $cb = $self->parent; 1231 1232 return $cb->_query_report( @_, module => $self ); 1233 } 1234 1235 =pod 1236 1237 =head2 $bool = $self->uninstall([type => [all|man|prog]) 1238 1239 This function uninstalls the specified module object. 1240 1241 You can install 2 types of files, either C<man> pages or C<prog>ram 1242 files. Alternately you can specify C<all> to uninstall both (which 1243 is the default). 1244 1245 Returns true on success and false on failure. 1246 1247 Do note that this does an uninstall via the so-called C<.packlist>, 1248 so if you used a module installer like say, C<ports> or C<apt>, you 1249 should not use this, but use your package manager instead. 1250 1251 =cut 1252 1253 sub uninstall { 1254 my $self = shift; 1255 my $conf = $self->parent->configure_object(); 1256 my %hash = @_; 1257 1258 my ($type,$verbose); 1259 my $tmpl = { 1260 type => { default => 'all', allow => [qw|man prog all|], 1261 store => \$type }, 1262 verbose => { default => $conf->get_conf('verbose'), 1263 store => \$verbose }, 1264 force => { default => $conf->get_conf('force') }, 1265 }; 1266 1267 ### XXX add a warning here if your default install dist isn't 1268 ### makefile or build -- that means you are using a package manager 1269 ### and this will not do what you think! 1270 1271 my $args = check( $tmpl, \%hash ) or return; 1272 1273 if( $conf->get_conf('dist_type') and ( 1274 ($conf->get_conf('dist_type') ne INSTALLER_BUILD) or 1275 ($conf->get_conf('dist_type') ne INSTALLER_MM)) 1276 ) { 1277 msg(loc("You have a default installer type set (%1) ". 1278 "-- you should probably use that package manager to " . 1279 "uninstall modules", $conf->get_conf('dist_type')), $verbose); 1280 } 1281 1282 ### check if we even have the module installed -- no point in continuing 1283 ### otherwise 1284 unless( $self->installed_version ) { 1285 error( loc( "Module '%1' is not installed, so cannot uninstall", 1286 $self->module ) ); 1287 return; 1288 } 1289 1290 ### nothing to uninstall ### 1291 my $files = $self->files( type => $type ) or return; 1292 my $dirs = $self->directory_tree( type => $type ) or return; 1293 my $sudo = $conf->get_program('sudo'); 1294 1295 ### just in case there's no file; M::B doensn't provide .packlists yet ### 1296 my $pack = $self->packlist; 1297 $pack = $pack->[0]->packlist_file() if $pack; 1298 1299 ### first remove the files, then the dirs if they are empty ### 1300 my $flag = 0; 1301 for my $file( @$files, $pack ) { 1302 next unless defined $file && -f $file; 1303 1304 msg(loc("Unlinking '%1'", $file), $verbose); 1305 1306 my @cmd = ($^X, "-eunlink+q[$file]"); 1307 unshift @cmd, $sudo if $sudo; 1308 1309 my $buffer; 1310 unless ( run( command => \@cmd, 1311 verbose => $verbose, 1312 buffer => \$buffer ) 1313 ) { 1314 error(loc("Failed to unlink '%1': '%2'",$file, $buffer)); 1315 $flag++; 1316 } 1317 } 1318 1319 for my $dir ( sort @$dirs ) { 1320 local *DIR; 1321 open DIR, $dir or next; 1322 my @count = readdir(DIR); 1323 close DIR; 1324 1325 next unless @count == 2; # . and .. 1326 1327 msg(loc("Removing '%1'", $dir), $verbose); 1328 1329 ### this fails on my win2k machines.. it indeed leaves the 1330 ### dir, but it's not a critical error, since the files have 1331 ### been removed. --kane 1332 #unless( rmdir $dir ) { 1333 # error( loc( "Could not remove '%1': %2", $dir, $! ) ) 1334 # unless $^O eq 'MSWin32'; 1335 #} 1336 1337 my @cmd = ($^X, "-ermdir+q[$dir]"); 1338 unshift @cmd, $sudo if $sudo; 1339 1340 my $buffer; 1341 unless ( run( command => \@cmd, 1342 verbose => $verbose, 1343 buffer => \$buffer ) 1344 ) { 1345 error(loc("Failed to rmdir '%1': %2",$dir,$buffer)); 1346 $flag++; 1347 } 1348 } 1349 1350 $self->status->uninstall(!$flag); 1351 $self->status->installed( $flag ? 1 : undef); 1352 1353 return !$flag; 1354 } 1355 1356 =pod 1357 1358 =head2 @modobj = $self->distributions() 1359 1360 Returns a list of module objects representing all releases for this 1361 module on success, false on failure. 1362 1363 =cut 1364 1365 sub distributions { 1366 my $self = shift; 1367 my %hash = @_; 1368 1369 my @list = $self->author->distributions( %hash, module => $self ) or return; 1370 1371 ### it's another release then by the same author ### 1372 return grep { $_->package_name eq $self->package_name } @list; 1373 } 1374 1375 =pod 1376 1377 =head2 @list = $self->files () 1378 1379 Returns a list of files used by this module, if it is installed. 1380 1381 =cut 1382 1383 sub files { 1384 return shift->_extutils_installed( @_, method => 'files' ); 1385 } 1386 1387 =pod 1388 1389 =head2 @list = $self->directory_tree () 1390 1391 Returns a list of directories used by this module. 1392 1393 =cut 1394 1395 sub directory_tree { 1396 return shift->_extutils_installed( @_, method => 'directory_tree' ); 1397 } 1398 1399 =pod 1400 1401 =head2 @list = $self->packlist () 1402 1403 Returns the C<ExtUtils::Packlist> object for this module. 1404 1405 =cut 1406 1407 sub packlist { 1408 return shift->_extutils_installed( @_, method => 'packlist' ); 1409 } 1410 1411 =pod 1412 1413 =head2 @list = $self->validate () 1414 1415 Returns a list of files that are missing for this modules, but 1416 are present in the .packlist file. 1417 1418 =cut 1419 1420 sub validate { 1421 return shift->_extutils_installed( method => 'validate' ); 1422 } 1423 1424 ### generic method to call an ExtUtils::Installed method ### 1425 sub _extutils_installed { 1426 my $self = shift; 1427 my $conf = $self->parent->configure_object(); 1428 my %hash = @_; 1429 1430 my ($verbose,$type,$method); 1431 my $tmpl = { 1432 verbose => { default => $conf->get_conf('verbose'), 1433 store => \$verbose, }, 1434 type => { default => 'all', 1435 allow => [qw|prog man all|], 1436 store => \$type, }, 1437 method => { required => 1, 1438 store => \$method, 1439 allow => [qw|files directory_tree packlist 1440 validate|], 1441 }, 1442 }; 1443 1444 my $args = check( $tmpl, \%hash ) or return; 1445 1446 ### old versions of cygwin + perl < 5.8 are buggy here. bail out if we 1447 ### find we're being used by them 1448 { my $err = ON_OLD_CYGWIN; 1449 if($err) { error($err); return }; 1450 } 1451 1452 return unless can_load( 1453 modules => { 'ExtUtils::Installed' => '0.0' }, 1454 verbose => $verbose, 1455 ); 1456 1457 my $inst; 1458 unless( $inst = ExtUtils::Installed->new() ) { 1459 error( loc("Could not create an '%1' object", 'ExtUtils::Installed' ) ); 1460 1461 ### in case it's being used directly... ### 1462 return; 1463 } 1464 1465 1466 { ### EU::Installed can die =/ 1467 my @files; 1468 eval { @files = $inst->$method( $self->module, $type ) }; 1469 1470 if( $@ ) { 1471 chomp $@; 1472 error( loc("Could not get '%1' for '%2': %3", 1473 $method, $self->module, $@ ) ); 1474 return; 1475 } 1476 1477 return wantarray ? @files : \@files; 1478 } 1479 } 1480 1481 =head2 $bool = $self->add_to_includepath; 1482 1483 Adds the current modules path to C<@INC> and C<$PERL5LIB>. This allows 1484 you to add the module from it's build dir to your path. 1485 1486 You can reset C<@INC> and C<$PERL5LIB> to it's original state when you 1487 started the program, by calling: 1488 1489 $self->parent->flush('lib'); 1490 1491 =cut 1492 1493 sub add_to_includepath { 1494 my $self = shift; 1495 my $cb = $self->parent; 1496 1497 if( my $dir = $self->status->extract ) { 1498 1499 $cb->_add_to_includepath( 1500 directories => [ 1501 File::Spec->catdir(BLIB->($dir), LIB), 1502 File::Spec->catdir(BLIB->($dir), ARCH), 1503 BLIB->($dir), 1504 ] 1505 ) or return; 1506 1507 } else { 1508 error(loc( "No extract dir registered for '%1' -- can not add ". 1509 "add builddir to search path!", $self->module )); 1510 return; 1511 } 1512 1513 return 1; 1514 1515 } 1516 1517 =pod 1518 1519 =head2 $path = $self->best_path_to_module_build(); 1520 1521 B<OBSOLETE> 1522 1523 If a newer version of Module::Build is found in your path, it will 1524 return this C<special> path. If the newest version of C<Module::Build> 1525 is found in your regular C<@INC>, the method will return false. This 1526 indicates you do not need to add a special directory to your C<@INC>. 1527 1528 Note that this is only relevant if you're building your own 1529 C<CPANPLUS::Dist::*> plugin -- the built-in dist types already have 1530 this taken care of. 1531 1532 =cut 1533 1534 ### make sure we're always running 'perl Build.PL' and friends 1535 ### against the highest version of module::build available 1536 sub best_path_to_module_build { 1537 my $self = shift; 1538 1539 ### Since M::B will actually shell out and run the Build.PL, we must 1540 ### make sure it refinds the proper version of M::B in the path. 1541 ### that may be either in our cp::inc or in site_perl, or even a 1542 ### new M::B being installed. 1543 ### don't add anything else here, as that might screw up prereq checks 1544 1545 ### XXX this might be needed for Dist::MM too, if a makefile.pl is 1546 ### masquerading as a Build.PL 1547 1548 ### did we find the most recent module::build in our installer path? 1549 1550 ### XXX can't do changes to @INC, they're being ignored by 1551 ### new_from_context when writing a Build script. see ticket: 1552 ### #8826 Module::Build ignores changes to @INC when writing Build 1553 ### from new_from_context 1554 ### XXX applied schwern's patches (as seen on CPANPLUS::Devel 10/12/04) 1555 ### and upped the version to 0.26061 of the bundled version, and things 1556 ### work again 1557 1558 ### this functionality is now obsolete -- prereqs should be installed 1559 ### and we no longer use the CPANPLUS::inc magic.. so comment this out. 1560 # require Module::Build; 1561 # if( CPANPLUS::inc->path_to('Module::Build') and ( 1562 # CPANPLUS::inc->path_to('Module::Build') eq 1563 # CPANPLUS::inc->installer_path ) 1564 # ) { 1565 # 1566 # ### if the module being installed is *not* Module::Build 1567 # ### itself -- as that would undoubtedly be newer -- add 1568 # ### the path to the installers to @INC 1569 # ### if it IS module::build itself, add 'lib' to its path, 1570 # ### as the Build.PL would do as well, but the API doesn't. 1571 # ### this makes self updates possible 1572 # return $self->module eq 'Module::Build' 1573 # ? 'lib' 1574 # : CPANPLUS::inc->installer_path; 1575 # } 1576 1577 ### otherwise, the path was found through a 'normal' way of 1578 ### scanning @INC. 1579 return; 1580 } 1581 1582 =pod 1583 1584 =head1 BUG REPORTS 1585 1586 Please report bugs or other issues to E<lt>bug-cpanplus@rt.cpan.org<gt>. 1587 1588 =head1 AUTHOR 1589 1590 This module by Jos Boumans E<lt>kane@cpan.orgE<gt>. 1591 1592 =head1 COPYRIGHT 1593 1594 The CPAN++ interface (of which this module is a part of) is copyright (c) 1595 2001 - 2007, Jos Boumans E<lt>kane@cpan.orgE<gt>. All rights reserved. 1596 1597 This library is free software; you may redistribute and/or modify it 1598 under the same terms as Perl itself. 1599 1600 =cut 1601 1602 # Local variables: 1603 # c-indentation-style: bsd 1604 # c-basic-offset: 4 1605 # indent-tabs-mode: nil 1606 # End: 1607 # vim: expandtab shiftwidth=4: 1608 1609 1; 1610 1611 __END__ 1612 1613 todo: 1614 reports();
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 |