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 ### first prepare the dist
812 $dist->prepare( %$args ) or return;
813 $self->status->prepared(1);
815 ### you just wanted us to prepare?
816 last DIST if $target eq TARGET_PREPARE;
818 $dist->create( %$args ) or return;
819 $self->status->created(1);
827 =head2 $bool = $mod->prepare( )
829 Convenience method around C<install()> that prepares a module
830 without actually building it. This is equivalent to invoking C<install>
831 with C<target> set to C<prepare>
833 Returns true on success, false on failure.
839 return $self->install( @_, target => TARGET_PREPARE );
842 =head2 $bool = $mod->create( )
844 Convenience method around C<install()> that creates a module.
845 This is equivalent to invoking C<install> with C<target> set to
848 Returns true on success, false on failure.
854 return $self->install( @_, target => TARGET_CREATE );
857 =head2 $bool = $mod->test( )
859 Convenience wrapper around C<install()> that tests a module, without
861 It's the equivalent to invoking C<install()> with C<target> set to
862 C<create> and C<skiptest> set to C<0>.
864 Returns true on success, false on failure.
870 return $self->install( @_, target => TARGET_CREATE, skiptest => 0 );
875 =head2 $bool = $self->install([ target => 'prepare|create|install', format => FORMAT_TYPE, extractdir => DIRECTORY, fetchdir => DIRECTORY, prefer_bin => BOOL, force => BOOL, verbose => BOOL, ..... ]);
877 Installs the current module. This includes fetching it and extracting
878 it, if this hasn't been done yet, as well as creating a distribution
881 This means you can pass it more arguments than described above, which
882 will be passed on to the relevant methods as they are called.
884 See C<CPANPLUS::Internals::Fetch>, C<CPANPLUS::Internals::Extract> and
885 C<CPANPLUS::Dist> for details.
887 Returns true on success, false on failure.
893 my $cb = $self->parent;
894 my $conf = $cb->configure_object;
897 my $args; my $target; my $format;
898 { ### so we can use the rest of the args to the create calls etc ###
899 local $Params::Check::NO_DUPLICATES = 1;
900 local $Params::Check::ALLOW_UNKNOWN = 1;
902 ### targets 'dist' and 'test' are now completely ignored ###
904 ### match this allow list with Dist->_resolve_prereqs
905 target => { default => TARGET_INSTALL, store => \$target,
906 allow => [TARGET_PREPARE, TARGET_CREATE,
908 force => { default => $conf->get_conf('force'), },
909 verbose => { default => $conf->get_conf('verbose'), },
910 format => { default => $conf->get_conf('dist_type'),
914 $args = check( $tmpl, \%hash ) or return;
918 ### if this target isn't 'install', we will need to at least 'create'
919 ### every prereq, so it can build
920 ### XXX prereq_target of 'prepare' will do weird things here, and is
922 $args->{'prereq_target'} ||= TARGET_CREATE if $target ne TARGET_INSTALL;
924 ### check if it's already upto date ###
925 if( $target eq TARGET_INSTALL and !$args->{'force'} and
926 !$self->package_is_perl_core() and # separate rules apply
927 ( $self->status->installed() or $self->is_uptodate ) and
928 !INSTALL_VIA_PACKAGE_MANAGER->($format)
930 msg(loc("Module '%1' already up to date, won't install without force",
931 $self->module), $args->{'verbose'} );
932 return $self->status->installed(1);
935 # if it's a non-installable core package, abort the install.
936 if( $self->package_is_perl_core() ) {
937 # if the installed is newer, say so.
938 if( $self->installed_version > $self->version ) {
939 error(loc("The core Perl %1 module '%2' (%3) is more ".
940 "recent than the latest release on CPAN (%4). ".
942 $], $self->module, $self->installed_version,
944 # if the installed matches, say so.
945 } elsif( $self->installed_version == $self->version ) {
946 error(loc("The core Perl %1 module '%2' (%3) can only ".
947 "be installed by Perl itself. ".
949 $], $self->module, $self->installed_version ) );
950 # otherwise, the installed is older; say so.
952 error(loc("The core Perl %1 module '%2' can only be ".
953 "upgraded from %3 to %4 by Perl itself (%5). ".
955 $], $self->module, $self->installed_version,
956 $self->version, $self->package ) );
960 ### it might be a known 3rd party module
961 } elsif ( $self->is_third_party ) {
962 my $info = $self->third_party_information;
964 "%1 is a known third-party module.\n\n".
965 "As it isn't available on the CPAN, CPANPLUS can't install " .
966 "it automatically. Therefore you need to install it manually " .
967 "before proceeding.\n\n".
968 "%2 is part of %3, published by %4, and should be available ".
969 "for download at the following address:\n\t%5",
970 $self->name, $self->name, $info->{name}, $info->{author},
977 ### fetch it if need be ###
978 unless( $self->status->fetch ) {
980 for (qw[prefer_bin fetchdir]) {
981 $params->{$_} = $args->{$_} if exists $args->{$_};
983 for (qw[force verbose]) {
984 $params->{$_} = $args->{$_} if defined $args->{$_};
986 $self->fetch( %$params ) or return;
989 ### extract it if need be ###
990 unless( $self->status->extract ) {
992 for (qw[prefer_bin extractdir]) {
993 $params->{$_} = $args->{$_} if exists $args->{$_};
995 for (qw[force verbose]) {
996 $params->{$_} = $args->{$_} if defined $args->{$_};
998 $self->extract( %$params ) or return;
1001 $format ||= $self->status->installer_type;
1004 error( loc( "Don't know what installer to use; " .
1005 "Couldn't find either '%1' or '%2' in the extraction " .
1006 "directory '%3' -- will be unable to install",
1007 BUILD_PL->(), MAKEFILE_PL->(), $self->status->extract ) );
1009 $self->status->installed(0);
1014 ### do SIGNATURE checks? ###
1015 ### XXX check status and not recheck EVERY time?
1016 if( $conf->get_conf('signature') ) {
1017 unless( $self->check_signature( verbose => $args->{verbose} ) ) {
1018 error( loc( "Signature check failed for module '%1' ".
1019 "-- Not trusting this module, aborting install",
1021 $self->status->signature(0);
1023 ### send out test report on broken sig
1024 if( $conf->get_conf('cpantest') ) {
1028 buffer => CPANPLUS::Error->stack_as_string,
1029 verbose => $args->{verbose},
1030 force => $args->{force},
1031 ) or error(loc("Failed to send test report for '%1'",
1038 ### signature OK ###
1039 $self->status->signature(1);
1043 ### a target of 'create' basically means not to run make test ###
1044 ### eh, no it /doesn't/.. skiptest => 1 means skiptest => 1.
1045 #$args->{'skiptest'} = 1 if $target eq 'create';
1047 ### bundle rules apply ###
1048 if( $self->is_bundle ) {
1049 ### check what we need to install ###
1050 my @prereqs = $self->bundle_modules();
1051 unless( @prereqs ) {
1052 error( loc( "Bundle '%1' does not specify any modules to install",
1055 ### XXX mark an error here? ###
1059 my $dist = $self->dist( format => $format,
1063 error( loc( "Unable to create a new distribution object for '%1' " .
1064 "-- cannot continue", $self->module ) );
1068 return 1 if $target ne TARGET_INSTALL;
1070 my $ok = $dist->install( %$args ) ? 1 : 0;
1072 $self->status->installed($ok);
1078 =pod @list = $self->bundle_modules()
1080 Returns a list of module objects the Bundle specifies.
1082 This requires you to have extracted the bundle already, using the
1083 C<extract()> method.
1085 Returns false on error.
1089 sub bundle_modules {
1091 my $cb = $self->parent;
1093 unless( $self->is_bundle ) {
1094 error( loc("'%1' is not a bundle", $self->module ) );
1100 ### autobundles are special files generated by CPANPLUS. If we can
1101 ### read the file, we can determine the prereqs
1102 if( $self->is_autobundle ) {
1104 unless( $where = $self->status->fetch ) {
1105 error(loc("Don't know where '%1' was fetched to", $self->package));
1111 ### regular bundle::* upload
1114 unless( $dir = $self->status->extract ) {
1115 error(loc("Don't know where '%1' was extracted to", $self->module));
1120 wanted => sub { push @files, File::Spec->rel2abs($_) if /\.pm/i },
1125 my $prereqs = {}; my @list; my $seen = {};
1126 for my $file ( @files ) {
1127 my $fh = FileHandle->new($file)
1128 or( error(loc("Could not open '%1' for reading: %2",
1132 while( local $_ = <$fh> ) {
1133 ### quick hack to read past the header of the file ###
1134 last if $flag && m|^=head|i;
1136 ### from perldoc cpan:
1138 ### In this pod section each line obeys the format
1139 ### Module_Name [Version_String] [- optional text]
1140 $flag = 1 if m|^=head1 CONTENTS|i;
1142 if ($flag && /^(?!=)(\S+)\s*(\S+)?/) {
1144 my $version = $cb->_version_to_number( version => $2 );
1146 my $obj = $cb->module_tree($module);
1149 error(loc("Cannot find bundled module '%1'", $module),
1150 loc("-- it does not seem to exist") );
1154 ### make sure we list no duplicates ###
1155 unless( $seen->{ $obj->module }++ ) {
1157 $prereqs->{ $module } =
1158 $cb->_version_to_number( version => $version );
1164 ### store the prereqs we just found ###
1165 $self->status->prereqs( $prereqs );
1172 =head2 $text = $self->readme
1174 Fetches the readme belonging to this module and stores it under
1175 C<< $obj->status->readme >>. Returns the readme as a string on
1176 success and returns false on failure.
1182 my $conf = $self->parent->configure_object;
1184 ### did we already dl the readme once? ###
1185 return $self->status->readme() if $self->status->readme();
1187 ### this should be core ###
1188 return unless can_load( modules => { FileHandle => '0.0' },
1192 ### get a clone of the current object, with a fresh status ###
1193 my $obj = $self->clone or return;
1195 ### munge the package name
1196 my $pkg = README->( $obj );
1197 $obj->package($pkg);
1200 { ### disable checksum fetches on readme downloads
1202 my $tmp = $conf->get_conf( 'md5' );
1203 $conf->set_conf( md5 => 0 );
1205 $file = $obj->fetch;
1207 $conf->set_conf( md5 => $tmp );
1209 return unless $file;
1212 ### read the file into a scalar, to store in the original object ###
1213 my $fh = new FileHandle;
1214 unless( $fh->open($file) ) {
1215 error( loc( "Could not open file '%1': %2", $file, $! ) );
1219 my $in = do{ local $/; <$fh> };
1222 return $self->status->readme( $in );
1227 =head2 $version = $self->installed_version()
1229 Returns the currently installed version of this module, if any.
1231 =head2 $where = $self->installed_file()
1233 Returns the location of the currently installed file of this module,
1236 =head2 $dir = $self->installed_dir()
1238 Returns the directory (or more accurately, the C<@INC> handle) from
1239 which this module was loaded, if any.
1241 =head2 $bool = $self->is_uptodate([version => VERSION_NUMBER])
1243 Returns a boolean indicating if this module is uptodate or not.
1247 ### uptodate/installed functions
1248 { my $map = { # hashkey, alternate rv
1249 installed_version => ['version', 0 ],
1250 installed_file => ['file', ''],
1251 installed_dir => ['dir', ''],
1252 is_uptodate => ['uptodate', 0 ],
1255 while( my($method, $aref) = each %$map ) {
1256 my($key,$alt_rv) = @$aref;
1260 ### never use the @INC hooks to find installed versions of
1261 ### modules -- they're just there in case they're not on the
1262 ### perl install, but the user shouldn't trust them for *other*
1264 ### XXX CPANPLUS::inc is now obsolete, so this should not
1265 ### be needed anymore
1266 #local @INC = CPANPLUS::inc->original_inc;
1270 ### make sure check_install is not looking in %INC, as
1271 ### that may contain some of our sneakily loaded modules
1272 ### that aren't installed as such. -- kane
1273 local $Module::Load::Conditional::CHECK_INC_HASH = 0;
1274 my $href = check_install(
1275 module => $self->module,
1276 version => $self->version,
1280 return $href->{$key} || $alt_rv;
1289 =head2 $href = $self->details()
1291 Returns a hashref with key/value pairs offering more information about
1292 a particular module. For example, for C<Time::HiRes> it might look like
1295 Author Jarkko Hietaniemi (jhi@iki.fi)
1296 Description High resolution time, sleep, and alarm
1297 Development Stage Released
1298 Installed File /usr/local/perl/lib/Time/Hires.pm
1299 Interface Style plain Functions, no references used
1300 Language Used C and perl, a C compiler will be needed
1301 Package Time-HiRes-1.65.tar.gz
1302 Public License Unknown
1303 Support Level Developer
1304 Version Installed 1.52
1305 Version on CPAN 1.65
1311 my $conf = $self->parent->configure_object();
1312 my $cb = $self->parent;
1316 Author => loc("%1 (%2)", $self->author->author(),
1317 $self->author->email() ),
1318 Package => $self->package,
1319 Description => $self->description || loc('None given'),
1320 'Version on CPAN' => $self->version,
1323 ### check if we have the module installed
1324 ### if so, add version have and version on cpan
1325 $res->{'Version Installed'} = $self->installed_version
1326 if $self->installed_version;
1327 $res->{'Installed File'} = $self->installed_file if $self->installed_file;
1330 for my $item( split '', $self->dslip ) {
1331 $res->{ $cb->_dslip_defs->[$i]->[0] } =
1332 $cb->_dslip_defs->[$i]->[1]->{$item} || loc('Unknown');
1339 =head2 @list = $self->contains()
1341 Returns a list of module objects that represent the modules also
1342 present in the package of this module.
1344 For example, for C<Archive::Tar> this might return:
1347 Archive::Tar::Constant
1354 my $cb = $self->parent;
1355 my $pkg = $self->package;
1357 my @mods = $cb->search( type => 'package', allow => [qr/^$pkg$/] );
1364 =head2 @list_of_hrefs = $self->fetch_report()
1366 This function queries the CPAN testers database at
1367 I<http://testers.cpan.org/> for test results of specified module
1368 objects, module names or distributions.
1370 Look at L<CPANPLUS::Internals::Report::_query_report()> for details on
1371 the options you can pass and the return value to expect.
1377 my $cb = $self->parent;
1379 return $cb->_query_report( @_, module => $self );
1384 =head2 $bool = $self->uninstall([type => [all|man|prog])
1386 This function uninstalls the specified module object.
1388 You can install 2 types of files, either C<man> pages or C<prog>ram
1389 files. Alternately you can specify C<all> to uninstall both (which
1392 Returns true on success and false on failure.
1394 Do note that this does an uninstall via the so-called C<.packlist>,
1395 so if you used a module installer like say, C<ports> or C<apt>, you
1396 should not use this, but use your package manager instead.
1402 my $conf = $self->parent->configure_object();
1405 my ($type,$verbose);
1407 type => { default => 'all', allow => [qw|man prog all|],
1409 verbose => { default => $conf->get_conf('verbose'),
1410 store => \$verbose },
1411 force => { default => $conf->get_conf('force') },
1414 ### XXX add a warning here if your default install dist isn't
1415 ### makefile or build -- that means you are using a package manager
1416 ### and this will not do what you think!
1418 my $args = check( $tmpl, \%hash ) or return;
1420 if( $conf->get_conf('dist_type') and (
1421 ($conf->get_conf('dist_type') ne INSTALLER_BUILD) or
1422 ($conf->get_conf('dist_type') ne INSTALLER_MM))
1424 msg(loc("You have a default installer type set (%1) ".
1425 "-- you should probably use that package manager to " .
1426 "uninstall modules", $conf->get_conf('dist_type')), $verbose);
1429 ### check if we even have the module installed -- no point in continuing
1431 unless( $self->installed_version ) {
1432 error( loc( "Module '%1' is not installed, so cannot uninstall",
1437 ### nothing to uninstall ###
1438 my $files = $self->files( type => $type ) or return;
1439 my $dirs = $self->directory_tree( type => $type ) or return;
1440 my $sudo = $conf->get_program('sudo');
1442 ### just in case there's no file; M::B doensn't provide .packlists yet ###
1443 my $pack = $self->packlist;
1444 $pack = $pack->[0]->packlist_file() if $pack;
1446 ### first remove the files, then the dirs if they are empty ###
1448 for my $file( @$files, $pack ) {
1449 next unless defined $file && -f $file;
1451 msg(loc("Unlinking '%1'", $file), $verbose);
1453 my @cmd = ($^X, "-eunlink+q[$file]");
1454 unshift @cmd, $sudo if $sudo;
1457 unless ( run( command => \@cmd,
1458 verbose => $verbose,
1459 buffer => \$buffer )
1461 error(loc("Failed to unlink '%1': '%2'",$file, $buffer));
1466 for my $dir ( sort @$dirs ) {
1468 opendir DIR, $dir or next;
1469 my @count = readdir(DIR);
1472 next unless @count == 2; # . and ..
1474 msg(loc("Removing '%1'", $dir), $verbose);
1476 ### this fails on my win2k machines.. it indeed leaves the
1477 ### dir, but it's not a critical error, since the files have
1478 ### been removed. --kane
1479 #unless( rmdir $dir ) {
1480 # error( loc( "Could not remove '%1': %2", $dir, $! ) )
1481 # unless $^O eq 'MSWin32';
1484 my @cmd = ($^X, "-e", "rmdir q[$dir]");
1485 unshift @cmd, $sudo if $sudo;
1488 unless ( run( command => \@cmd,
1489 verbose => $verbose,
1490 buffer => \$buffer )
1492 error(loc("Failed to rmdir '%1': %2",$dir,$buffer));
1497 $self->status->uninstall(!$flag);
1498 $self->status->installed( $flag ? 1 : undef);
1505 =head2 @modobj = $self->distributions()
1507 Returns a list of module objects representing all releases for this
1508 module on success, false on failure.
1516 my @list = $self->author->distributions( %hash, module => $self ) or return;
1518 ### it's another release then by the same author ###
1519 return grep { $_->package_name eq $self->package_name } @list;
1524 =head2 @list = $self->files ()
1526 Returns a list of files used by this module, if it is installed.
1528 =head2 @list = $self->directory_tree ()
1530 Returns a list of directories used by this module.
1532 =head2 @list = $self->packlist ()
1534 Returns the C<ExtUtils::Packlist> object for this module.
1536 =head2 @list = $self->validate ()
1538 Returns a list of files that are missing for this modules, but
1539 are present in the .packlist file.
1543 for my $sub (qw[files directory_tree packlist validate]) {
1546 return shift->_extutils_installed( @_, method => $sub );
1550 ### generic method to call an ExtUtils::Installed method ###
1551 sub _extutils_installed {
1553 my $cb = $self->parent;
1554 my $conf = $cb->configure_object;
1555 my $home = $cb->_home_dir; # may be needed to fix up prefixes
1558 my ($verbose,$type,$method);
1560 verbose => { default => $conf->get_conf('verbose'),
1561 store => \$verbose, },
1562 type => { default => 'all',
1563 allow => [qw|prog man all|],
1565 method => { required => 1,
1567 allow => [qw|files directory_tree packlist
1572 my $args = check( $tmpl, \%hash ) or return;
1574 ### old versions of cygwin + perl < 5.8 are buggy here. bail out if we
1575 ### find we're being used by them
1576 { my $err = ON_OLD_CYGWIN;
1577 if($err) { error($err); return };
1580 return unless can_load(
1581 modules => { 'ExtUtils::Installed' => '0.0' },
1582 verbose => $verbose,
1585 my @config_names = (
1587 { lib => 'privlib', # perl-only
1588 arch => 'archlib', # compiled code
1589 prefix => 'prefix', # prefix to both
1594 prefix => 'siteprefix',
1597 { lib => 'vendorlib',
1598 arch => 'vendorarch',
1599 prefix => 'vendorprefix',
1603 ### search in your regular @INC, and anything you added to your config.
1604 ### this lets EU::Installed find .packlists that are *not* in the standard
1605 ### compiled in @INC path. Requires EU::I 1.42 or up. this addresses #33438
1606 ### make sure the archname path is also added, as that's where the .packlist
1607 ### files are written
1609 for my $lib ( @{ $conf->get_conf('lib') } ) {
1612 ### and just the standard dir
1615 ### figure out what an MM prefix expands to. Basically, it's the
1616 ### site install target from %Config, ie: /opt/lib/perl5/site_perl/5.8.8
1617 ### minus the site wide prefix, ie: /opt
1618 ### this lets users add the dir they have set as their EU::MM PREFIX
1619 ### to our 'lib' config and it Just Works
1620 ### the arch specific dir, ie:
1621 ### /opt/lib/perl5/site_perl/5.8.8/darwin-2level
1622 ### XXX is this the right thing to do?
1624 ### we add all 6 dir combos for prefixes:
1628 ### /foo/site/lib/arch
1630 ### /foo/vendor/lib/arch
1631 for my $href ( @config_names ) {
1632 for my $key ( qw[lib arch] ) {
1634 ### look up the config value -- use EXP for the EXPANDED
1635 ### version, so no ~ etc are found in there
1636 my $dir = $Config::Config{ $href->{ $key } .'exp' } or next;
1637 my $prefix = $Config::Config{ $href->{prefix} };
1639 ### prefix may be relative to home, and contain a ~
1640 ### if so, fix it up.
1641 $prefix =~ s/^~/$home/;
1643 ### remove the prefix from it, so we can append to our $lib
1644 $dir =~ s/^\Q$prefix\E//;
1646 ### do the appending
1647 push @libs, File::Spec->catdir( $lib, $dir );
1654 unless( $inst = ExtUtils::Installed->new( extra_libs => \@libs ) ) {
1655 error( loc("Could not create an '%1' object", 'ExtUtils::Installed' ) );
1657 ### in case it's being used directly... ###
1662 { ### EU::Installed can die =/
1664 eval { @files = $inst->$method( $self->module, $type ) };
1668 error( loc("Could not get '%1' for '%2': %3",
1669 $method, $self->module, $@ ) );
1673 return wantarray ? @files : \@files;
1677 =head2 $bool = $self->add_to_includepath;
1679 Adds the current modules path to C<@INC> and C<$PERL5LIB>. This allows
1680 you to add the module from its build dir to your path.
1682 You can reset C<@INC> and C<$PERL5LIB> to its original state when you
1683 started the program, by calling:
1685 $self->parent->flush('lib');
1689 sub add_to_includepath {
1691 my $cb = $self->parent;
1693 if( my $dir = $self->status->extract ) {
1695 $cb->_add_to_includepath(
1697 File::Spec->catdir(BLIB->($dir), LIB),
1698 File::Spec->catdir(BLIB->($dir), ARCH),
1704 error(loc( "No extract dir registered for '%1' -- can not add ".
1705 "add builddir to search path!", $self->module ));
1715 =head2 $path = $self->best_path_to_module_build();
1719 If a newer version of Module::Build is found in your path, it will
1720 return this C<special> path. If the newest version of C<Module::Build>
1721 is found in your regular C<@INC>, the method will return false. This
1722 indicates you do not need to add a special directory to your C<@INC>.
1724 Note that this is only relevant if you're building your own
1725 C<CPANPLUS::Dist::*> plugin -- the built-in dist types already have
1730 ### make sure we're always running 'perl Build.PL' and friends
1731 ### against the highest version of module::build available
1732 sub best_path_to_module_build {
1735 ### Since M::B will actually shell out and run the Build.PL, we must
1736 ### make sure it refinds the proper version of M::B in the path.
1737 ### that may be either in our cp::inc or in site_perl, or even a
1738 ### new M::B being installed.
1739 ### don't add anything else here, as that might screw up prereq checks
1741 ### XXX this might be needed for Dist::MM too, if a makefile.pl is
1742 ### masquerading as a Build.PL
1744 ### did we find the most recent module::build in our installer path?
1746 ### XXX can't do changes to @INC, they're being ignored by
1747 ### new_from_context when writing a Build script. see ticket:
1748 ### #8826 Module::Build ignores changes to @INC when writing Build
1749 ### from new_from_context
1750 ### XXX applied schwern's patches (as seen on CPANPLUS::Devel 10/12/04)
1751 ### and upped the version to 0.26061 of the bundled version, and things
1754 ### this functionality is now obsolete -- prereqs should be installed
1755 ### and we no longer use the CPANPLUS::inc magic.. so comment this out.
1756 # require Module::Build;
1757 # if( CPANPLUS::inc->path_to('Module::Build') and (
1758 # CPANPLUS::inc->path_to('Module::Build') eq
1759 # CPANPLUS::inc->installer_path )
1762 # ### if the module being installed is *not* Module::Build
1763 # ### itself -- as that would undoubtedly be newer -- add
1764 # ### the path to the installers to @INC
1765 # ### if it IS module::build itself, add 'lib' to its path,
1766 # ### as the Build.PL would do as well, but the API doesn't.
1767 # ### this makes self updates possible
1768 # return $self->module eq 'Module::Build'
1770 # : CPANPLUS::inc->installer_path;
1773 ### otherwise, the path was found through a 'normal' way of
1782 Please report bugs or other issues to E<lt>bug-cpanplus@rt.cpan.org<gt>.
1786 This module by Jos Boumans E<lt>kane@cpan.orgE<gt>.
1790 The CPAN++ interface (of which this module is a part of) is copyright (c)
1791 2001 - 2007, Jos Boumans E<lt>kane@cpan.orgE<gt>. All rights reserved.
1793 This library is free software; you may redistribute and/or modify it
1794 under the same terms as Perl itself.
1799 # c-indentation-style: bsd
1801 # indent-tabs-mode: nil
1803 # vim: expandtab shiftwidth=4: