1 package CPANPLUS::Module;
9 use CPANPLUS::Module::Signature;
10 use CPANPLUS::Module::Checksums;
11 use CPANPLUS::Internals::Constants;
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 File::Basename qw[dirname];
20 use Module::Load::Conditional qw[can_load check_install];
22 $Params::Check::VERBOSE = 1;
24 @ISA = qw[ CPANPLUS::Module::Signature CPANPLUS::Module::Checksums];
34 ### get a module object from the CPANPLUS::Backend object
35 my $mod = $cb->module_tree('Some::Module');
49 C<CPANPLUS::Module> creates objects from the information in the
50 source files. These can then be used to query and perform actions
51 on, like fetching or installing.
53 These objects should only be created internally. For C<fake> objects,
54 there's the C<CPANPLUS::Module::Fake> class. To obtain a module object
55 consult the C<CPANPLUS::Backend> documentation.
60 module => { default => '', required => 1 }, # full module name
61 version => { default => '0.0' }, # version number
62 path => { default => '', required => 1 }, # extended path on the
64 # /author/id/K/KA/KANE
65 comment => { default => ''}, # comment on module
66 package => { default => '', required => 1 }, # package name, like
68 description => { default => '' }, # description of the
70 dslip => { default => EMPTY_DSLIP }, # dslip information
71 _id => { required => 1 }, # id of the Internals
73 _status => { no_override => 1 }, # stores status object
74 author => { default => '', required => 1,
75 allow => IS_AUTHOBJ }, # module author
76 mtime => { default => '' },
79 ### some of these will be resolved by wrapper functions that
80 ### do Clever Things to find the actual value, so don't create
81 ### an autogenerated sub for that just here, take an alternate
82 ### name to allow for a wrapper
87 ### autogenerate accessors ###
88 for my $key ( keys %$tmpl ) {
91 my $sub = $rename{$key} || $key;
93 *{__PACKAGE__."::$sub"} = sub {
94 $_[0]->{$key} = $_[1] if @_ > 1;
107 Returns a list of all accessor methods to the object
111 ### *name is an alias, include it explicitly
112 sub accessors { return ('name', keys %$tmpl) };
116 An objects of this class has the following accessors:
130 Version of the module. Defaults to '0.0' if none was provided.
134 Extended path on the mirror.
138 Any comment about the module -- largely unused.
142 The name of the package.
146 Description of the module -- only registered modules have this.
150 The five character dslip string, that represents meta-data of the
151 module -- again, only registered modules have this.
158 ### if this module has relevant dslip info, return it
159 return $self->_dslip if $self->_dslip ne EMPTY_DSLIP;
161 ### if not, look at other modules in the same package,
162 ### see if *they* have any dslip info
163 for my $mod ( $self->contains ) {
164 return $mod->_dslip if $mod->_dslip ne EMPTY_DSLIP;
167 ### ok, really no dslip info found, return the default
176 The C<CPANPLUS::Module::Status> object associated with this object.
181 The C<CPANPLUS::Module::Author> object associated with this object.
185 The C<CPANPLUS::Internals> object that spawned this module object.
191 ### Alias ->name to ->module, for human beings.
196 my $obj = CPANPLUS::Internals->_retrieve_id( $self->_id );
201 =head1 STATUS ACCESSORS
203 C<CPANPLUS> caches a lot of results from method calls and saves data
204 it collected along the road for later reuse.
206 C<CPANPLUS> uses this internally, but it is also available for the end
207 user. You can get a status object by calling:
211 You can then query the object as follows:
217 The installer type used for this distribution. Will be one of
218 'makemaker' or 'build'. This determines whether C<CPANPLUS::Dist::MM>
219 or C<CPANPLUS::Dist::Build> will be used to build this distribution.
223 The dist object used to do the CPAN-side of the installation. Either
224 a C<CPANPLUS::Dist::MM> or C<CPANPLUS::Dist::Build> object.
228 The custom dist object used to do the operating specific side of the
229 installation, if you've chosen to use this. For example, if you've
230 chosen to install using the C<ports> format, this may be a
231 C<CPANPLUS::Dist::Ports> object.
233 Undefined if you didn't specify a separate format to install through.
235 =item prereqs | requires
237 A hashref of prereqs this distribution was found to have. Will look
240 { Carp => 0.01, strict => 0 }
242 Might be undefined if the distribution didn't have any prerequisites.
244 =item configure_requires
246 Like prereqs, but these are necessary to be installed before the
247 build process can even begin.
251 Flag indicating, if a signature check was done, whether it was OK or
256 The directory this distribution was extracted to.
260 The location this distribution was fetched to.
264 The text of this distributions README file.
268 Flag indicating if an uninstall call was done successfully.
272 Flag indicating if the C<create> call to your dist object was done
277 Flag indicating if the C<install> call to your dist object was done
282 The location of this distributions CHECKSUMS file.
286 Flag indicating if the checksums check was done successfully.
290 The checksum value this distribution is expected to have
296 =head2 $self = CPANPLUS::Module->new( OPTIONS )
298 This method returns a C<CPANPLUS::Module> object. Normal users
299 should never call this method directly, but instead use the
300 C<CPANPLUS::Backend> to obtain module objects.
302 This example illustrates a C<new()> call with all required arguments:
304 CPANPLUS::Module->new(
306 path => 'authors/id/A/AA/AAA',
307 package => 'Foo-1.0.tgz',
308 author => $author_object,
309 _id => INTERNALS_OBJECT_ID,
312 Every accessor is also a valid option to pass to C<new>.
314 Returns a module object on success and false on failure.
320 my($class, %hash) = @_;
322 ### don't check the template for sanity
323 ### -- we know it's good and saves a lot of performance
324 local $Params::Check::SANITY_CHECK_TEMPLATE = 0;
326 my $object = check( $tmpl, \%hash ) or return;
328 bless $object, $class;
333 ### only create status objects when they're actually asked for
336 return $self->_status if $self->_status;
338 my $acc = Object::Accessor->new;
339 $acc->mk_accessors( qw[ installer_type dist_cpan dist prereqs
340 signature extract fetch readme uninstall
341 created installed prepared checksums files
342 checksum_ok checksum_value _fetch_from
346 ### create an alias from 'requires' to 'prereqs', so it's more in
347 ### line with 'configure_requires';
348 $acc->mk_aliases( requires => 'prereqs' );
350 $self->_status( $acc );
352 return $self->_status;
356 ### flush the cache of this object ###
359 $self->status->mk_flush;
363 =head2 $mod->package_name( [$package_string] )
365 Returns the name of the package a module is in. For C<Acme::Bleach>
366 that might be C<Acme-Bleach>.
368 =head2 $mod->package_version( [$package_string] )
370 Returns the version of the package a module is in. For a module
371 in the package C<Acme-Bleach-1.1.tar.gz> this would be C<1.1>.
373 =head2 $mod->package_extension( [$package_string] )
375 Returns the suffix added by the compression method of a package a
376 certain module is in. For a module in C<Acme-Bleach-1.1.tar.gz>, this
379 =head2 $mod->package_is_perl_core
381 Returns a boolean indicating of the package a particular module is in,
382 is actually a core perl distribution.
384 =head2 $mod->module_is_supplied_with_perl_core( [version => $]] )
386 Returns a boolean indicating whether C<ANY VERSION> of this module
387 was supplied with the current running perl's core package.
389 =head2 $mod->is_bundle
391 Returns a boolean indicating if the module you are looking at, is
392 actually a bundle. Bundles are identified as modules whose name starts
395 =head2 $mod->is_autobundle;
397 Returns a boolean indicating if the module you are looking at, is
398 actually an autobundle as generated by C<< $cb->autobundle >>.
400 =head2 $mod->is_third_party
402 Returns a boolean indicating whether the package is a known third-party
403 module (i.e. it's not provided by the standard Perl distribution and
404 is not available on the CPAN, but on a third party software provider).
405 See L<Module::ThirdParty> for more details.
407 =head2 $mod->third_party_information
409 Returns a reference to a hash with more information about a third-party
410 module. See the documentation about C<module_information()> in
411 L<Module::ThirdParty> for more details.
415 { ### fetches the test reports for a certain module ###
422 while ( my($type, $index) = each %map ) {
423 my $name = 'package_' . $type;
428 my $val = shift || $self->package;
429 my @res = $self->parent->_split_package_string( package => $val );
431 ### return the corresponding index from the result
432 return $res[$index] if @res;
437 sub package_is_perl_core {
439 my $cb = $self->parent;
441 ### check if the package looks like a perl core package
442 return 1 if $self->package_name eq PERL_CORE;
444 ### address #44562: ::Module->package_is_perl_code : problem comparing
445 ### version strings -- use $cb->_vcmp to avoid warnings when version
448 my $core = $self->module_is_supplied_with_perl_core;
449 ### ok, so it's found in the core, BUT it could be dual-lifed
451 ### if the package is newer than installed, then it's dual-lifed
452 return if $cb->_vcmp($self->version, $self->installed_version) > 0;
454 ### if the package is newer or equal to the corelist,
455 ### then it's dual-lifed
456 return if $cb->_vcmp( $self->version, $core ) >= 0;
458 ### otherwise, it's older than corelist, thus unsuitable.
462 ### not in corelist, not a perl core package.
466 sub module_is_supplied_with_perl_core {
468 my $ver = shift || $];
470 ### allow it to be called as a package function as well like:
471 ### CPANPLUS::Module::module_is_supplied_with_perl_core('Config')
472 ### so that we can check the status of modules that aren't released
473 ### to CPAN, but are part of the core.
474 my $name = ref $self ? $self->module : $self;
476 ### check Module::CoreList to see if it's a core package
477 require Module::CoreList;
479 ### Address #41157: Module::module_is_supplied_with_perl_core()
480 ### broken for perl 5.10: Module::CoreList's version key for the
481 ### hash has a different number of trailing zero than $] aka
483 my $core = $Module::CoreList::version{ 0+$ver }->{ $name };
488 ### make sure Bundle-Foo also gets flagged as bundle
493 return 1 if $self->module =~ /^bundle(?:-|::)/i;
496 return 1 if $self->is_autobundle;
502 ### full path to a generated autobundle
505 my $conf = $self->parent->configure_object;
506 my $prefix = $conf->_get_build('autobundle_prefix');
508 return 1 if $self->module eq $prefix;
515 return unless can_load( modules => { 'Module::ThirdParty' => 0 } );
517 return Module::ThirdParty::is_3rd_party( $self->name );
520 sub third_party_information {
523 return unless $self->is_third_party;
525 return Module::ThirdParty::module_information( $self->name );
531 =head2 $clone = $self->clone
533 Clones the current module object for tinkering with.
534 It will have a clean C<CPANPLUS::Module::Status> object, as well as
535 a fake C<CPANPLUS::Module::Author> object.
539 { ### accessors dont change during run time, so only compute once
540 my @acc = grep !/status/, __PACKAGE__->accessors();
545 ### clone the object ###
546 my %data = map { $_ => $self->$_ } @acc;
548 my $obj = CPANPLUS::Module::Fake->new( %data );
556 =head2 $where = $self->fetch
558 Fetches the module from a CPAN mirror.
559 Look at L<CPANPLUS::Internals::Fetch::_fetch()> for details on the
560 options you can pass.
566 my $cb = $self->parent;
569 my %args = ( module => $self );
571 ### if a custom fetch location got specified before, add that here
572 $args{fetch_from} = $self->status->_fetch_from
573 if $self->status->_fetch_from;
575 my $where = $cb->_fetch( @_, %args ) or return;
577 ### do an md5 check ###
578 if( !$self->status->_fetch_from and
579 $cb->configure_object->get_conf('md5') and
580 $self->package ne CHECKSUMS
582 unless( $self->_validate_checksum ) {
583 error( loc( "Checksum error for '%1' -- will not trust package",
594 =head2 $path = $self->extract
596 Extracts the fetched module.
597 Look at L<CPANPLUS::Internals::Extract::_extract()> for details on
598 the options you can pass.
604 my $cb = $self->parent;
606 unless( $self->status->fetch ) {
607 error( loc( "You have not fetched '%1' yet -- cannot extract",
612 ### can't extract these, so just use the basedir for the file
613 if( $self->is_autobundle ) {
615 ### this is expected to be set after an extract call
616 $self->get_installer_type;
618 return $self->status->extract( dirname( $self->status->fetch ) );
621 return $cb->_extract( @_, module => $self );
624 =head2 $type = $self->get_installer_type([prefer_makefile => BOOL])
626 Gets the installer type for this module. This may either be C<build> or
627 C<makemaker>. If C<Module::Build> is unavailable or no installer type
628 is available, it will fall back to C<makemaker>. If both are available,
629 it will pick the one indicated by your config, or by the
630 C<prefer_makefile> option you can pass to this function.
632 Returns the installer type on success, and false on error.
636 sub get_installer_type {
638 my $cb = $self->parent;
639 my $conf = $cb->configure_object;
642 my ($prefer_makefile,$verbose);
644 prefer_makefile => { default => $conf->get_conf('prefer_makefile'),
645 store => \$prefer_makefile, allow => BOOLEANS },
646 verbose => { default => $conf->get_conf('verbose'),
647 store => \$verbose },
650 check( $tmpl, \%hash ) or return;
654 ### autobundles use their own installer, so return that
655 if( $self->is_autobundle ) {
656 $type = INSTALLER_AUTOBUNDLE;
659 my $extract = $self->status->extract();
662 "Cannot determine installer type of unextracted module '%1'",
668 ### check if it's a makemaker or a module::build type dist ###
669 my $found_build = -e BUILD_PL->( $extract );
670 my $found_makefile = -e MAKEFILE_PL->( $extract );
672 $type = INSTALLER_BUILD if !$prefer_makefile && $found_build;
673 $type = INSTALLER_BUILD if $found_build && !$found_makefile;
674 $type = INSTALLER_MM if $prefer_makefile && $found_makefile;
675 $type = INSTALLER_MM if $found_makefile && !$found_build;
678 ### ok, so it's a 'build' installer, but you don't /have/ module build
679 ### XXX duplicated from CPANPLUS::Selfupdate. fix somehow?
680 if( $type and $type eq INSTALLER_BUILD and (
681 not CPANPLUS::Dist->has_dist_type( INSTALLER_BUILD )
682 or not $cb->module_tree( INSTALLER_BUILD )
683 ->is_uptodate( version => '0.24' )
686 ### XXX this is for recording purposes only. We *have* to install
687 ### these before even creating a dist object, or we'll get an error
688 ### saying 'no such dist type';
689 ### XXX duplicated from CPANPLUS::Selfupdate. fix somehow?
690 my $href = $self->status->configure_requires || {};
691 my $deps = { INSTALLER_BUILD, '0.24', %$href };
693 $self->status->configure_requires( $deps );
695 msg(loc("This module requires '%1' and '%2' to be installed first. ".
696 "Adding these modules to your prerequisites list",
697 'Module::Build', INSTALLER_BUILD
701 ### ok, actually we found neither ###
703 error( loc( "Unable to find '%1' or '%2' for '%3'; ".
704 "Will default to '%4' but might be unable ".
705 "to install!", BUILD_PL->(), MAKEFILE_PL->(),
706 $self->module, INSTALLER_MM ) );
707 $type = INSTALLER_MM;
710 return $self->status->installer_type( $type ) if $type;
716 =head2 $dist = $self->dist([target => 'prepare|create', format => DISTRIBUTION_TYPE, args => {key => val}]);
718 Create a distribution object, ready to be installed.
719 Distribution type defaults to your config settings
721 The optional C<args> hashref is passed on to the specific distribution
722 types' C<create> method after being dereferenced.
724 Returns a distribution object on success, false on failure.
726 See C<CPANPLUS::Dist> for details.
732 my $cb = $self->parent;
733 my $conf = $cb->configure_object;
736 ### have you determined your installer type yet? if not, do it here,
738 $self->get_installer_type unless $self->status->installer_type;
740 my($type,$args,$target);
742 format => { default => $conf->get_conf('dist_type') ||
743 $self->status->installer_type,
745 target => { default => TARGET_CREATE, store => \$target },
746 args => { default => {}, store => \$args },
749 check( $tmpl, \%hash ) or return;
751 ### ok, check for $type. Do we have it?
752 unless( CPANPLUS::Dist->has_dist_type( $type ) ) {
754 ### ok, we don't have it. Is it C::D::Build? if so we can install the
756 ### XXX we _could_ do this for any type we dont have actually...
757 if( $type eq INSTALLER_BUILD ) {
758 msg(loc("Bootstrapping installer '%1'", $type));
760 ### don't propagate the format, it's the one we're trying to
761 ### bootstrap, so it'll be an infinite loop if we do
763 $cb->module_tree( $type )->install( target => $target, %$args ) or
765 error(loc("Could not bootstrap installer '%1' -- ".
766 "can not continue", $type));
770 ### re-scan for available modules now
771 CPANPLUS::Dist->rescan_dist_types;
773 unless( CPANPLUS::Dist->has_dist_type( $type ) ) {
774 error(loc("Newly installed installer type '%1' should be ".
775 "available, but is not! -- aborting", $type));
778 msg(loc("Installer '%1' succesfully bootstrapped", $type));
781 ### some other plugin you dont have. Abort
783 error(loc("Installer type '%1' not found. Please verify your ".
784 "installation -- aborting", $type ));
789 ### make sure we don't overwrite it, just in case we came
790 ### back from a ->save_state. This allows restoration to
792 my( $dist, $dist_cpan );
794 unless( $dist = $self->status->dist ) {
795 $dist = $type->new( module => $self ) or return;
796 $self->status->dist( $dist );
799 unless( $dist_cpan = $self->status->dist_cpan ) {
801 $dist_cpan = $type eq $self->status->installer_type
802 ? $self->status->dist
803 : $self->status->installer_type->new( module => $self );
806 $self->status->dist_cpan( $dist_cpan );
811 ### just wanted the $dist object?
812 last DIST if $target eq TARGET_INIT;
814 ### first prepare the dist
815 $dist->prepare( %$args ) or return;
816 $self->status->prepared(1);
818 ### you just wanted us to prepare?
819 last DIST if $target eq TARGET_PREPARE;
821 $dist->create( %$args ) or return;
822 $self->status->created(1);
830 =head2 $bool = $mod->prepare( )
832 Convenience method around C<install()> that prepares a module
833 without actually building it. This is equivalent to invoking C<install>
834 with C<target> set to C<prepare>
836 Returns true on success, false on failure.
842 return $self->install( @_, target => TARGET_PREPARE );
845 =head2 $bool = $mod->create( )
847 Convenience method around C<install()> that creates a module.
848 This is equivalent to invoking C<install> with C<target> set to
851 Returns true on success, false on failure.
857 return $self->install( @_, target => TARGET_CREATE );
860 =head2 $bool = $mod->test( )
862 Convenience wrapper around C<install()> that tests a module, without
864 It's the equivalent to invoking C<install()> with C<target> set to
865 C<create> and C<skiptest> set to C<0>.
867 Returns true on success, false on failure.
873 return $self->install( @_, target => TARGET_CREATE, skiptest => 0 );
878 =head2 $bool = $self->install([ target => 'init|prepare|create|install', format => FORMAT_TYPE, extractdir => DIRECTORY, fetchdir => DIRECTORY, prefer_bin => BOOL, force => BOOL, verbose => BOOL, ..... ]);
880 Installs the current module. This includes fetching it and extracting
881 it, if this hasn't been done yet, as well as creating a distribution
884 This means you can pass it more arguments than described above, which
885 will be passed on to the relevant methods as they are called.
887 See C<CPANPLUS::Internals::Fetch>, C<CPANPLUS::Internals::Extract> and
888 C<CPANPLUS::Dist> for details.
890 Returns true on success, false on failure.
896 my $cb = $self->parent;
897 my $conf = $cb->configure_object;
900 my $args; my $target; my $format;
901 { ### so we can use the rest of the args to the create calls etc ###
902 local $Params::Check::NO_DUPLICATES = 1;
903 local $Params::Check::ALLOW_UNKNOWN = 1;
905 ### targets 'dist' and 'test' are now completely ignored ###
907 ### match this allow list with Dist->_resolve_prereqs
908 target => { default => TARGET_INSTALL, store => \$target,
909 allow => [TARGET_PREPARE, TARGET_CREATE,
910 TARGET_INSTALL, TARGET_INIT ] },
911 force => { default => $conf->get_conf('force'), },
912 verbose => { default => $conf->get_conf('verbose'), },
913 format => { default => $conf->get_conf('dist_type'),
917 $args = check( $tmpl, \%hash ) or return;
921 ### if this target isn't 'install', we will need to at least 'create'
922 ### every prereq, so it can build
923 ### XXX prereq_target of 'prepare' will do weird things here, and is
925 $args->{'prereq_target'} ||= TARGET_CREATE if $target ne TARGET_INSTALL;
927 ### check if it's already upto date ###
928 if( $target eq TARGET_INSTALL and !$args->{'force'} and
929 !$self->package_is_perl_core() and # separate rules apply
930 ( $self->status->installed() or $self->is_uptodate ) and
931 !INSTALL_VIA_PACKAGE_MANAGER->($format)
933 msg(loc("Module '%1' already up to date, won't install without force",
934 $self->module), $args->{'verbose'} );
935 return $self->status->installed(1);
938 # if it's a non-installable core package, abort the install.
939 if( $self->package_is_perl_core() ) {
940 # if the installed is newer, say so.
941 if( $self->installed_version > $self->version ) {
942 error(loc("The core Perl %1 module '%2' (%3) is more ".
943 "recent than the latest release on CPAN (%4). ".
945 $], $self->module, $self->installed_version,
947 # if the installed matches, say so.
948 } elsif( $self->installed_version == $self->version ) {
949 error(loc("The core Perl %1 module '%2' (%3) can only ".
950 "be installed by Perl itself. ".
952 $], $self->module, $self->installed_version ) );
953 # otherwise, the installed is older; say so.
955 error(loc("The core Perl %1 module '%2' can only be ".
956 "upgraded from %3 to %4 by Perl itself (%5). ".
958 $], $self->module, $self->installed_version,
959 $self->version, $self->package ) );
963 ### it might be a known 3rd party module
964 } elsif ( $self->is_third_party ) {
965 my $info = $self->third_party_information;
967 "%1 is a known third-party module.\n\n".
968 "As it isn't available on the CPAN, CPANPLUS can't install " .
969 "it automatically. Therefore you need to install it manually " .
970 "before proceeding.\n\n".
971 "%2 is part of %3, published by %4, and should be available ".
972 "for download at the following address:\n\t%5",
973 $self->name, $self->name, $info->{name}, $info->{author},
980 ### fetch it if need be ###
981 unless( $self->status->fetch ) {
983 for (qw[prefer_bin fetchdir]) {
984 $params->{$_} = $args->{$_} if exists $args->{$_};
986 for (qw[force verbose]) {
987 $params->{$_} = $args->{$_} if defined $args->{$_};
989 $self->fetch( %$params ) or return;
992 ### extract it if need be ###
993 unless( $self->status->extract ) {
995 for (qw[prefer_bin extractdir]) {
996 $params->{$_} = $args->{$_} if exists $args->{$_};
998 for (qw[force verbose]) {
999 $params->{$_} = $args->{$_} if defined $args->{$_};
1001 $self->extract( %$params ) or return;
1004 $format ||= $self->status->installer_type;
1007 error( loc( "Don't know what installer to use; " .
1008 "Couldn't find either '%1' or '%2' in the extraction " .
1009 "directory '%3' -- will be unable to install",
1010 BUILD_PL->(), MAKEFILE_PL->(), $self->status->extract ) );
1012 $self->status->installed(0);
1017 ### do SIGNATURE checks? ###
1018 ### XXX check status and not recheck EVERY time?
1019 if( $conf->get_conf('signature') ) {
1020 unless( $self->check_signature( verbose => $args->{verbose} ) ) {
1021 error( loc( "Signature check failed for module '%1' ".
1022 "-- Not trusting this module, aborting install",
1024 $self->status->signature(0);
1026 ### send out test report on broken sig
1027 if( $conf->get_conf('cpantest') ) {
1031 buffer => CPANPLUS::Error->stack_as_string,
1032 verbose => $args->{verbose},
1033 force => $args->{force},
1034 ) or error(loc("Failed to send test report for '%1'",
1041 ### signature OK ###
1042 $self->status->signature(1);
1046 ### a target of 'create' basically means not to run make test ###
1047 ### eh, no it /doesn't/.. skiptest => 1 means skiptest => 1.
1048 #$args->{'skiptest'} = 1 if $target eq 'create';
1050 ### bundle rules apply ###
1051 if( $self->is_bundle ) {
1052 ### check what we need to install ###
1053 my @prereqs = $self->bundle_modules();
1054 unless( @prereqs ) {
1055 error( loc( "Bundle '%1' does not specify any modules to install",
1058 ### XXX mark an error here? ###
1062 my $dist = $self->dist( format => $format,
1066 error( loc( "Unable to create a new distribution object for '%1' " .
1067 "-- cannot continue", $self->module ) );
1071 return 1 if $target ne TARGET_INSTALL;
1073 my $ok = $dist->install( %$args ) ? 1 : 0;
1075 $self->status->installed($ok);
1081 =pod @list = $self->bundle_modules()
1083 Returns a list of module objects the Bundle specifies.
1085 This requires you to have extracted the bundle already, using the
1086 C<extract()> method.
1088 Returns false on error.
1092 sub bundle_modules {
1094 my $cb = $self->parent;
1096 unless( $self->is_bundle ) {
1097 error( loc("'%1' is not a bundle", $self->module ) );
1103 ### autobundles are special files generated by CPANPLUS. If we can
1104 ### read the file, we can determine the prereqs
1105 if( $self->is_autobundle ) {
1107 unless( $where = $self->status->fetch ) {
1108 error(loc("Don't know where '%1' was fetched to", $self->package));
1114 ### regular bundle::* upload
1117 unless( $dir = $self->status->extract ) {
1118 error(loc("Don't know where '%1' was extracted to", $self->module));
1123 wanted => sub { push @files, File::Spec->rel2abs($_) if /\.pm/i },
1128 my $prereqs = {}; my @list; my $seen = {};
1129 for my $file ( @files ) {
1130 my $fh = FileHandle->new($file)
1131 or( error(loc("Could not open '%1' for reading: %2",
1135 while( local $_ = <$fh> ) {
1136 ### quick hack to read past the header of the file ###
1137 last if $flag && m|^=head|i;
1139 ### from perldoc cpan:
1141 ### In this pod section each line obeys the format
1142 ### Module_Name [Version_String] [- optional text]
1143 $flag = 1 if m|^=head1 CONTENTS|i;
1145 if ($flag && /^(?!=)(\S+)\s*(\S+)?/) {
1147 my $version = $cb->_version_to_number( version => $2 );
1149 my $obj = $cb->module_tree($module);
1152 error(loc("Cannot find bundled module '%1'", $module),
1153 loc("-- it does not seem to exist") );
1157 ### make sure we list no duplicates ###
1158 unless( $seen->{ $obj->module }++ ) {
1160 $prereqs->{ $module } =
1161 $cb->_version_to_number( version => $version );
1167 ### store the prereqs we just found ###
1168 $self->status->prereqs( $prereqs );
1175 =head2 $text = $self->readme
1177 Fetches the readme belonging to this module and stores it under
1178 C<< $obj->status->readme >>. Returns the readme as a string on
1179 success and returns false on failure.
1185 my $conf = $self->parent->configure_object;
1187 ### did we already dl the readme once? ###
1188 return $self->status->readme() if $self->status->readme();
1190 ### this should be core ###
1191 return unless can_load( modules => { FileHandle => '0.0' },
1195 ### get a clone of the current object, with a fresh status ###
1196 my $obj = $self->clone or return;
1198 ### munge the package name
1199 my $pkg = README->( $obj );
1200 $obj->package($pkg);
1203 { ### disable checksum fetches on readme downloads
1205 my $tmp = $conf->get_conf( 'md5' );
1206 $conf->set_conf( md5 => 0 );
1208 $file = $obj->fetch;
1210 $conf->set_conf( md5 => $tmp );
1212 return unless $file;
1215 ### read the file into a scalar, to store in the original object ###
1216 my $fh = new FileHandle;
1217 unless( $fh->open($file) ) {
1218 error( loc( "Could not open file '%1': %2", $file, $! ) );
1222 my $in = do{ local $/; <$fh> };
1225 return $self->status->readme( $in );
1230 =head2 $version = $self->installed_version()
1232 Returns the currently installed version of this module, if any.
1234 =head2 $where = $self->installed_file()
1236 Returns the location of the currently installed file of this module,
1239 =head2 $dir = $self->installed_dir()
1241 Returns the directory (or more accurately, the C<@INC> handle) from
1242 which this module was loaded, if any.
1244 =head2 $bool = $self->is_uptodate([version => VERSION_NUMBER])
1246 Returns a boolean indicating if this module is uptodate or not.
1250 ### uptodate/installed functions
1251 { my $map = { # hashkey, alternate rv
1252 installed_version => ['version', 0 ],
1253 installed_file => ['file', ''],
1254 installed_dir => ['dir', ''],
1255 is_uptodate => ['uptodate', 0 ],
1258 while( my($method, $aref) = each %$map ) {
1259 my($key,$alt_rv) = @$aref;
1263 ### never use the @INC hooks to find installed versions of
1264 ### modules -- they're just there in case they're not on the
1265 ### perl install, but the user shouldn't trust them for *other*
1267 ### XXX CPANPLUS::inc is now obsolete, so this should not
1268 ### be needed anymore
1269 #local @INC = CPANPLUS::inc->original_inc;
1273 ### make sure check_install is not looking in %INC, as
1274 ### that may contain some of our sneakily loaded modules
1275 ### that aren't installed as such. -- kane
1276 local $Module::Load::Conditional::CHECK_INC_HASH = 0;
1277 my $href = check_install(
1278 module => $self->module,
1279 version => $self->version,
1283 return $href->{$key} || $alt_rv;
1292 =head2 $href = $self->details()
1294 Returns a hashref with key/value pairs offering more information about
1295 a particular module. For example, for C<Time::HiRes> it might look like
1298 Author Jarkko Hietaniemi (jhi@iki.fi)
1299 Description High resolution time, sleep, and alarm
1300 Development Stage Released
1301 Installed File /usr/local/perl/lib/Time/Hires.pm
1302 Interface Style plain Functions, no references used
1303 Language Used C and perl, a C compiler will be needed
1304 Package Time-HiRes-1.65.tar.gz
1305 Public License Unknown
1306 Support Level Developer
1307 Version Installed 1.52
1308 Version on CPAN 1.65
1314 my $conf = $self->parent->configure_object();
1315 my $cb = $self->parent;
1319 Author => loc("%1 (%2)", $self->author->author(),
1320 $self->author->email() ),
1321 Package => $self->package,
1322 Description => $self->description || loc('None given'),
1323 'Version on CPAN' => $self->version,
1326 ### check if we have the module installed
1327 ### if so, add version have and version on cpan
1328 $res->{'Version Installed'} = $self->installed_version
1329 if $self->installed_version;
1330 $res->{'Installed File'} = $self->installed_file if $self->installed_file;
1333 for my $item( split '', $self->dslip ) {
1334 $res->{ $cb->_dslip_defs->[$i]->[0] } =
1335 $cb->_dslip_defs->[$i]->[1]->{$item} || loc('Unknown');
1342 =head2 @list = $self->contains()
1344 Returns a list of module objects that represent the modules also
1345 present in the package of this module.
1347 For example, for C<Archive::Tar> this might return:
1350 Archive::Tar::Constant
1357 my $cb = $self->parent;
1358 my $pkg = $self->package;
1360 my @mods = $cb->search( type => 'package', allow => [qr/^$pkg$/] );
1367 =head2 @list_of_hrefs = $self->fetch_report()
1369 This function queries the CPAN testers database at
1370 I<http://testers.cpan.org/> for test results of specified module
1371 objects, module names or distributions.
1373 Look at L<CPANPLUS::Internals::Report::_query_report()> for details on
1374 the options you can pass and the return value to expect.
1380 my $cb = $self->parent;
1382 return $cb->_query_report( @_, module => $self );
1387 =head2 $bool = $self->uninstall([type => [all|man|prog])
1389 This function uninstalls the specified module object.
1391 You can install 2 types of files, either C<man> pages or C<prog>ram
1392 files. Alternately you can specify C<all> to uninstall both (which
1395 Returns true on success and false on failure.
1397 Do note that this does an uninstall via the so-called C<.packlist>,
1398 so if you used a module installer like say, C<ports> or C<apt>, you
1399 should not use this, but use your package manager instead.
1405 my $conf = $self->parent->configure_object();
1408 my ($type,$verbose);
1410 type => { default => 'all', allow => [qw|man prog all|],
1412 verbose => { default => $conf->get_conf('verbose'),
1413 store => \$verbose },
1414 force => { default => $conf->get_conf('force') },
1417 ### XXX add a warning here if your default install dist isn't
1418 ### makefile or build -- that means you are using a package manager
1419 ### and this will not do what you think!
1421 my $args = check( $tmpl, \%hash ) or return;
1423 if( $conf->get_conf('dist_type') and (
1424 ($conf->get_conf('dist_type') ne INSTALLER_BUILD) or
1425 ($conf->get_conf('dist_type') ne INSTALLER_MM))
1427 msg(loc("You have a default installer type set (%1) ".
1428 "-- you should probably use that package manager to " .
1429 "uninstall modules", $conf->get_conf('dist_type')), $verbose);
1432 ### check if we even have the module installed -- no point in continuing
1434 unless( $self->installed_version ) {
1435 error( loc( "Module '%1' is not installed, so cannot uninstall",
1440 ### nothing to uninstall ###
1441 my $files = $self->files( type => $type ) or return;
1442 my $dirs = $self->directory_tree( type => $type ) or return;
1443 my $sudo = $conf->get_program('sudo');
1445 ### just in case there's no file; M::B doensn't provide .packlists yet ###
1446 my $pack = $self->packlist;
1447 $pack = $pack->[0]->packlist_file() if $pack;
1449 ### first remove the files, then the dirs if they are empty ###
1451 for my $file( @$files, $pack ) {
1452 next unless defined $file && -f $file;
1454 msg(loc("Unlinking '%1'", $file), $verbose);
1456 my @cmd = ($^X, "-eunlink+q[$file]");
1457 unshift @cmd, $sudo if $sudo;
1460 unless ( run( command => \@cmd,
1461 verbose => $verbose,
1462 buffer => \$buffer )
1464 error(loc("Failed to unlink '%1': '%2'",$file, $buffer));
1469 for my $dir ( sort @$dirs ) {
1471 opendir DIR, $dir or next;
1472 my @count = readdir(DIR);
1475 next unless @count == 2; # . and ..
1477 msg(loc("Removing '%1'", $dir), $verbose);
1479 ### this fails on my win2k machines.. it indeed leaves the
1480 ### dir, but it's not a critical error, since the files have
1481 ### been removed. --kane
1482 #unless( rmdir $dir ) {
1483 # error( loc( "Could not remove '%1': %2", $dir, $! ) )
1484 # unless $^O eq 'MSWin32';
1487 my @cmd = ($^X, "-e", "rmdir q[$dir]");
1488 unshift @cmd, $sudo if $sudo;
1491 unless ( run( command => \@cmd,
1492 verbose => $verbose,
1493 buffer => \$buffer )
1495 error(loc("Failed to rmdir '%1': %2",$dir,$buffer));
1500 $self->status->uninstall(!$flag);
1501 $self->status->installed( $flag ? 1 : undef);
1508 =head2 @modobj = $self->distributions()
1510 Returns a list of module objects representing all releases for this
1511 module on success, false on failure.
1519 my @list = $self->author->distributions( %hash, module => $self ) or return;
1521 ### it's another release then by the same author ###
1522 return grep { $_->package_name eq $self->package_name } @list;
1527 =head2 @list = $self->files ()
1529 Returns a list of files used by this module, if it is installed.
1531 =head2 @list = $self->directory_tree ()
1533 Returns a list of directories used by this module.
1535 =head2 @list = $self->packlist ()
1537 Returns the C<ExtUtils::Packlist> object for this module.
1539 =head2 @list = $self->validate ()
1541 Returns a list of files that are missing for this modules, but
1542 are present in the .packlist file.
1546 for my $sub (qw[files directory_tree packlist validate]) {
1549 return shift->_extutils_installed( @_, method => $sub );
1553 ### generic method to call an ExtUtils::Installed method ###
1554 sub _extutils_installed {
1556 my $cb = $self->parent;
1557 my $conf = $cb->configure_object;
1558 my $home = $cb->_home_dir; # may be needed to fix up prefixes
1561 my ($verbose,$type,$method);
1563 verbose => { default => $conf->get_conf('verbose'),
1564 store => \$verbose, },
1565 type => { default => 'all',
1566 allow => [qw|prog man all|],
1568 method => { required => 1,
1570 allow => [qw|files directory_tree packlist
1575 my $args = check( $tmpl, \%hash ) or return;
1577 ### old versions of cygwin + perl < 5.8 are buggy here. bail out if we
1578 ### find we're being used by them
1579 { my $err = ON_OLD_CYGWIN;
1580 if($err) { error($err); return };
1583 return unless can_load(
1584 modules => { 'ExtUtils::Installed' => '0.0' },
1585 verbose => $verbose,
1588 my @config_names = (
1590 { lib => 'privlib', # perl-only
1591 arch => 'archlib', # compiled code
1592 prefix => 'prefix', # prefix to both
1597 prefix => 'siteprefix',
1600 { lib => 'vendorlib',
1601 arch => 'vendorarch',
1602 prefix => 'vendorprefix',
1606 ### search in your regular @INC, and anything you added to your config.
1607 ### this lets EU::Installed find .packlists that are *not* in the standard
1608 ### compiled in @INC path. Requires EU::I 1.42 or up. this addresses #33438
1609 ### make sure the archname path is also added, as that's where the .packlist
1610 ### files are written
1612 for my $lib ( @{ $conf->get_conf('lib') } ) {
1615 ### and just the standard dir
1618 ### figure out what an MM prefix expands to. Basically, it's the
1619 ### site install target from %Config, ie: /opt/lib/perl5/site_perl/5.8.8
1620 ### minus the site wide prefix, ie: /opt
1621 ### this lets users add the dir they have set as their EU::MM PREFIX
1622 ### to our 'lib' config and it Just Works
1623 ### the arch specific dir, ie:
1624 ### /opt/lib/perl5/site_perl/5.8.8/darwin-2level
1625 ### XXX is this the right thing to do?
1627 ### we add all 6 dir combos for prefixes:
1631 ### /foo/site/lib/arch
1633 ### /foo/vendor/lib/arch
1634 for my $href ( @config_names ) {
1635 for my $key ( qw[lib arch] ) {
1637 ### look up the config value -- use EXP for the EXPANDED
1638 ### version, so no ~ etc are found in there
1639 my $dir = $Config::Config{ $href->{ $key } .'exp' } or next;
1640 my $prefix = $Config::Config{ $href->{prefix} };
1642 ### prefix may be relative to home, and contain a ~
1643 ### if so, fix it up.
1644 $prefix =~ s/^~/$home/;
1646 ### remove the prefix from it, so we can append to our $lib
1647 $dir =~ s/^\Q$prefix\E//;
1649 ### do the appending
1650 push @libs, File::Spec->catdir( $lib, $dir );
1657 unless( $inst = ExtUtils::Installed->new( extra_libs => \@libs ) ) {
1658 error( loc("Could not create an '%1' object", 'ExtUtils::Installed' ) );
1660 ### in case it's being used directly... ###
1665 { ### EU::Installed can die =/
1667 eval { @files = $inst->$method( $self->module, $type ) };
1671 error( loc("Could not get '%1' for '%2': %3",
1672 $method, $self->module, $@ ) );
1676 return wantarray ? @files : \@files;
1680 =head2 $bool = $self->add_to_includepath;
1682 Adds the current modules path to C<@INC> and C<$PERL5LIB>. This allows
1683 you to add the module from its build dir to your path.
1685 You can reset C<@INC> and C<$PERL5LIB> to its original state when you
1686 started the program, by calling:
1688 $self->parent->flush('lib');
1692 sub add_to_includepath {
1694 my $cb = $self->parent;
1696 if( my $dir = $self->status->extract ) {
1698 $cb->_add_to_includepath(
1700 File::Spec->catdir(BLIB->($dir), LIB),
1701 File::Spec->catdir(BLIB->($dir), ARCH),
1707 error(loc( "No extract dir registered for '%1' -- can not add ".
1708 "add builddir to search path!", $self->module ));
1718 =head2 $path = $self->best_path_to_module_build();
1722 If a newer version of Module::Build is found in your path, it will
1723 return this C<special> path. If the newest version of C<Module::Build>
1724 is found in your regular C<@INC>, the method will return false. This
1725 indicates you do not need to add a special directory to your C<@INC>.
1727 Note that this is only relevant if you're building your own
1728 C<CPANPLUS::Dist::*> plugin -- the built-in dist types already have
1733 ### make sure we're always running 'perl Build.PL' and friends
1734 ### against the highest version of module::build available
1735 sub best_path_to_module_build {
1738 ### Since M::B will actually shell out and run the Build.PL, we must
1739 ### make sure it refinds the proper version of M::B in the path.
1740 ### that may be either in our cp::inc or in site_perl, or even a
1741 ### new M::B being installed.
1742 ### don't add anything else here, as that might screw up prereq checks
1744 ### XXX this might be needed for Dist::MM too, if a makefile.pl is
1745 ### masquerading as a Build.PL
1747 ### did we find the most recent module::build in our installer path?
1749 ### XXX can't do changes to @INC, they're being ignored by
1750 ### new_from_context when writing a Build script. see ticket:
1751 ### #8826 Module::Build ignores changes to @INC when writing Build
1752 ### from new_from_context
1753 ### XXX applied schwern's patches (as seen on CPANPLUS::Devel 10/12/04)
1754 ### and upped the version to 0.26061 of the bundled version, and things
1757 ### this functionality is now obsolete -- prereqs should be installed
1758 ### and we no longer use the CPANPLUS::inc magic.. so comment this out.
1759 # require Module::Build;
1760 # if( CPANPLUS::inc->path_to('Module::Build') and (
1761 # CPANPLUS::inc->path_to('Module::Build') eq
1762 # CPANPLUS::inc->installer_path )
1765 # ### if the module being installed is *not* Module::Build
1766 # ### itself -- as that would undoubtedly be newer -- add
1767 # ### the path to the installers to @INC
1768 # ### if it IS module::build itself, add 'lib' to its path,
1769 # ### as the Build.PL would do as well, but the API doesn't.
1770 # ### this makes self updates possible
1771 # return $self->module eq 'Module::Build'
1773 # : CPANPLUS::inc->installer_path;
1776 ### otherwise, the path was found through a 'normal' way of
1785 Please report bugs or other issues to E<lt>bug-cpanplus@rt.cpan.org<gt>.
1789 This module by Jos Boumans E<lt>kane@cpan.orgE<gt>.
1793 The CPAN++ interface (of which this module is a part of) is copyright (c)
1794 2001 - 2007, Jos Boumans E<lt>kane@cpan.orgE<gt>. All rights reserved.
1796 This library is free software; you may redistribute and/or modify it
1797 under the same terms as Perl itself.
1802 # c-indentation-style: bsd
1804 # indent-tabs-mode: nil
1806 # vim: expandtab shiftwidth=4: