NG4R3P

Linux 4gvps.4gvps.com 3.10.0-1127.18.2.vz7.163.46 #1 SMP Fri Nov 20 21:47:55 MSK 2020 x86_64
SOFT : Apache PHP : 7.4.33
/usr/share/perl5/vendor_perl/CPANPLUS/

38.135.39.45

[ NAME ]	[ SIZE ]	[ PERM ]	[ DATE ]	[ ACT ]
+FILE +DIR
Backend	dir	drwxr-xr-x	2016-08-05 21:27	R D
Config	dir	drwxr-xr-x	2016-08-05 21:27	R D
Configure	dir	drwxr-xr-x	2016-08-05 21:27	R D
Dist	dir	drwxr-xr-x	2016-08-05 21:27	R D
Internals	dir	drwxr-xr-x	2016-08-05 21:27	R D
Module	dir	drwxr-xr-x	2016-08-05 21:27	R D
Shell	dir	drwxr-xr-x	2016-08-05 21:27	R D
Backend.pm	39.393 KB	-rw-r--r--	2013-05-20 21:46	R E G D
Config.pm	23.212 KB	-rw-r--r--	2013-05-20 21:46	R E G D
Configure.pm	15.945 KB	-rw-r--r--	2013-05-20 21:46	R E G D
Dist.pm	24.625 KB	-rw-r--r--	2013-05-20 21:46	R E G D
Error.pm	5.127 KB	-rw-r--r--	2013-05-20 21:46	R E G D
FAQ.pod	0.642 KB	-rw-r--r--	2013-05-12 15:22	R E G D
Hacking.pod	3.667 KB	-rw-r--r--	2013-05-12 15:22	R E G D
Internals.pm	14.936 KB	-rw-r--r--	2013-05-20 21:46	R E G D
Module.pm	53.599 KB	-rw-r--r--	2013-05-20 21:46	R E G D
Selfupdate.pm	16.485 KB	-rw-r--r--	2013-05-20 21:46	R E G D
Shell.pm	9.421 KB	-rw-r--r--	2013-05-20 21:46	R E G D
REQUEST EXIT

package CPANPLUS::Module; use strict; use vars qw[@ISA $VERSION]; $VERSION = "0.9138"; use CPANPLUS::Dist; use CPANPLUS::Error; use CPANPLUS::Module::Signature; use CPANPLUS::Module::Checksums; use CPANPLUS::Internals::Constants; use FileHandle; use Locale::Maketext::Simple Class => 'CPANPLUS', Style => 'gettext'; use IPC::Cmd qw[can_run run]; use File::Find qw[find]; use Params::Check qw[check]; use File::Basename qw[dirname]; use Module::Load::Conditional qw[can_load check_install]; $Params::Check::VERBOSE = 1; @ISA = qw[ CPANPLUS::Module::Signature CPANPLUS::Module::Checksums]; =pod =head1 NAME CPANPLUS::Module - CPAN module objects for CPANPLUS =head1 SYNOPSIS ### get a module object from the CPANPLUS::Backend object my $mod = $cb->module_tree('Some::Module'); ### accessors $mod->version; $mod->package; ### methods $mod->fetch; $mod->extract; $mod->install; =head1 DESCRIPTION C creates objects from the information in the source files. These can then be used to query and perform actions on, like fetching or installing. These objects should only be created internally. For C objects, there's the C class. To obtain a module object consult the C documentation. =cut my $tmpl = { module => { default => '', required => 1 }, # full module name version => { default => '0.0' }, # version number path => { default => '', required => 1 }, # extended path on the # cpan mirror, like # /author/id/K/KA/KANE comment => { default => ''}, # comment on module package => { default => '', required => 1 }, # package name, like # 'bar-baz-1.03.tgz' description => { default => '' }, # description of the # module dslip => { default => EMPTY_DSLIP }, # dslip information _id => { required => 1 }, # id of the Internals # parent object _status => { no_override => 1 }, # stores status object author => { default => '', required => 1, allow => IS_AUTHOBJ }, # module author mtime => { default => '' }, }; ### some of these will be resolved by wrapper functions that ### do Clever Things to find the actual value, so don't create ### an autogenerated sub for that just here, take an alternate ### name to allow for a wrapper { my %rename = ( dslip => '_dslip' ); ### autogenerate accessors ### for my $key ( keys %$tmpl ) { no strict 'refs'; my $sub = $rename{$key} || $key; *{__PACKAGE__."::$sub"} = sub { $_[0]->{$key} = $_[1] if @_ > 1; return $_[0]->{$key}; } } } =pod =head1 CLASS METHODS =head2 accessors () Returns a list of all accessor methods to the object =cut ### *name is an alias, include it explicitly sub accessors { return ('name', keys %$tmpl) }; =head1 ACCESSORS An objects of this class has the following accessors: =over 4 =item name Name of the module. =item module Name of the module. =item version Version of the module. Defaults to '0.0' if none was provided. =item path Extended path on the mirror. =item comment Any comment about the module -- largely unused. =item package The name of the package. =item description Description of the module -- only registered modules have this. =item dslip The five character dslip string, that represents meta-data of the module -- again, only registered modules have this. =cut sub dslip { my $self = shift; ### if this module has relevant dslip info, return it return $self->_dslip if $self->_dslip ne EMPTY_DSLIP; ### if not, look at other modules in the same package, ### see if *they* have any dslip info for my $mod ( $self->contains ) { return $mod->_dslip if $mod->_dslip ne EMPTY_DSLIP; } ### ok, really no dslip info found, return the default return EMPTY_DSLIP; } =pod =item status The C object associated with this object. (see below). =item author The C object associated with this object. =item parent The C object that spawned this module object. =back =cut ### Alias ->name to ->module, for human beings. *name = *module; sub parent { my $self = shift; my $obj = CPANPLUS::Internals->_retrieve_id( $self->_id ); return $obj; } =head1 STATUS ACCESSORS C caches a lot of results from method calls and saves data it collected along the road for later reuse. C uses this internally, but it is also available for the end user. You can get a status object by calling: $modobj->status You can then query the object as follows: =over 4 =item installer_type The installer type used for this distribution. Will be one of 'makemaker' or 'build'. This determines whether C or C will be used to build this distribution. =item dist_cpan The dist object used to do the CPAN-side of the installation. Either a C or C object. =item dist The custom dist object used to do the operating specific side of the installation, if you've chosen to use this. For example, if you've chosen to install using the C format, this may be a C object. Undefined if you didn't specify a separate format to install through. =item prereqs | requires A hashref of prereqs this distribution was found to have. Will look something like this: { Carp => 0.01, strict => 0 } Might be undefined if the distribution didn't have any prerequisites. =item configure_requires Like prereqs, but these are necessary to be installed before the build process can even begin. =item signature Flag indicating, if a signature check was done, whether it was OK or not. =item extract The directory this distribution was extracted to. =item fetch The location this distribution was fetched to. =item readme The text of this distributions README file. =item uninstall Flag indicating if an uninstall call was done successfully. =item created Flag indicating if the C call to your dist object was done successfully. =item installed Flag indicating if the C call to your dist object was done successfully. =item checksums The location of this distributions CHECKSUMS file. =item checksum_ok Flag indicating if the checksums check was done successfully. =item checksum_value The checksum value this distribution is expected to have =back =head1 METHODS =head2 $self = CPANPLUS::Module->new( OPTIONS ) This method returns a C object. Normal users should never call this method directly, but instead use the C to obtain module objects. This example illustrates a C call with all required arguments: CPANPLUS::Module->new( module => 'Foo', path => 'authors/id/A/AA/AAA', package => 'Foo-1.0.tgz', author => $author_object, _id => INTERNALS_OBJECT_ID, ); Every accessor is also a valid option to pass to C. Returns a module object on success and false on failure. =cut sub new { my($class, %hash) = @_; ### don't check the template for sanity ### -- we know it's good and saves a lot of performance local $Params::Check::SANITY_CHECK_TEMPLATE = 0; my $object = check( $tmpl, \%hash ) or return; bless $object, $class; return $object; } ### only create status objects when they're actually asked for sub status { my $self = shift; return $self->_status if $self->_status; my $acc = Object::Accessor->new; $acc->mk_accessors( qw[ installer_type dist_cpan dist prereqs signature extract fetch readme uninstall created installed prepared checksums files checksum_ok checksum_value _fetch_from configure_requires ] ); ### create an alias from 'requires' to 'prereqs', so it's more in ### line with 'configure_requires'; $acc->mk_aliases( requires => 'prereqs' ); $self->_status( $acc ); return $self->_status; } ### flush the cache of this object ### sub _flush { my $self = shift; $self->status->mk_flush; return 1; } =head2 $mod->package_name( [$package_string] ) Returns the name of the package a module is in. For C that might be C. =head2 $mod->package_version( [$package_string] ) Returns the version of the package a module is in. For a module in the package C this would be C<1.1>. =head2 $mod->package_extension( [$package_string] ) Returns the suffix added by the compression method of a package a certain module is in. For a module in C, this would be C. =head2 $mod->package_is_perl_core Returns a boolean indicating of the package a particular module is in, is actually a core perl distribution. =head2 $mod->module_is_supplied_with_perl_core( [version => $]] ) Returns a boolean indicating whether C of this module was supplied with the current running perl's core package. =head2 $mod->is_bundle Returns a boolean indicating if the module you are looking at, is actually a bundle. Bundles are identified as modules whose name starts with C. =head2 $mod->is_autobundle; Returns a boolean indicating if the module you are looking at, is actually an autobundle as generated by C<< $cb->autobundle >>. =head2 $mod->is_third_party Returns a boolean indicating whether the package is a known third-party module (i.e. it's not provided by the standard Perl distribution and is not available on the CPAN, but on a third party software provider). See L for more details. =head2 $mod->third_party_information Returns a reference to a hash with more information about a third-party module. See the documentation about C in L for more details. =cut { ### fetches the test reports for a certain module ### my %map = ( name => 0, version => 1, extension => 2, ); while ( my($type, $index) = each %map ) { my $name = 'package_' . $type; no strict 'refs'; *$name = sub { my $self = shift; my $val = shift || $self->package; my @res = $self->parent->_split_package_string( package => $val ); ### return the corresponding index from the result return $res[$index] if @res; return; }; } sub package_is_perl_core { my $self = shift; my $cb = $self->parent; ### check if the package looks like a perl core package return 1 if $self->package_name eq PERL_CORE; ### address #44562: ::Module->package_is_perl_code : problem comparing ### version strings -- use $cb->_vcmp to avoid warnings when version ### have _ in them my $core = $self->module_is_supplied_with_perl_core; ### ok, so it's found in the core, BUT it could be dual-lifed if (defined $core) { ### if the package is newer than installed, then it's dual-lifed return if $cb->_vcmp($self->version, $self->installed_version) > 0; ### if the package is newer or equal to the corelist, ### then it's dual-lifed return if $cb->_vcmp( $self->version, $core ) >= 0; ### otherwise, it's older than corelist, thus unsuitable. return 1; } ### not in corelist, not a perl core package. return; } sub module_is_supplied_with_perl_core { my $self = shift; my $ver = shift || $]; ### allow it to be called as a package function as well like: ### CPANPLUS::Module::module_is_supplied_with_perl_core('Config') ### so that we can check the status of modules that aren't released ### to CPAN, but are part of the core. my $name = ref $self ? $self->module : $self; ### check Module::CoreList to see if it's a core package require Module::CoreList; ### Address #41157: Module::module_is_supplied_with_perl_core() ### broken for perl 5.10: Module::CoreList's version key for the ### hash has a different number of trailing zero than $] aka ### $PERL_VERSION. my $core; if ( exists $Module::CoreList::version{ 0+$ver }->{ $name } ) { $core = $Module::CoreList::version{ 0+$ver }->{ $name }; $core = 0 unless $core; } return $core; } ### make sure Bundle-Foo also gets flagged as bundle sub is_bundle { my $self = shift; ### cpan'd bundle return 1 if $self->module =~ /^bundle(?:-|::)/i; ### autobundle return 1 if $self->is_autobundle; ### neither return; } ### full path to a generated autobundle sub is_autobundle { my $self = shift; my $conf = $self->parent->configure_object; my $prefix = $conf->_get_build('autobundle_prefix'); return 1 if $self->module eq $prefix; return; } sub is_third_party { my $self = shift; return unless can_load( modules => { 'Module::ThirdParty' => 0 } ); return Module::ThirdParty::is_3rd_party( $self->name ); } sub third_party_information { my $self = shift; return unless $self->is_third_party; return Module::ThirdParty::module_information( $self->name ); } } =pod =head2 $clone = $self->clone Clones the current module object for tinkering with. It will have a clean C object, as well as a fake C object. =cut { ### accessors dont change during run time, so only compute once my @acc = grep !/status/, __PACKAGE__->accessors(); sub clone { my $self = shift; ### clone the object ### my %data = map { $_ => $self->$_ } @acc; my $obj = CPANPLUS::Module::Fake->new( %data ); return $obj; } } =pod =head2 $where = $self->fetch Fetches the module from a CPAN mirror. Look at L for details on the options you can pass. =cut sub fetch { my $self = shift; my $cb = $self->parent; ### custom args my %args = ( module => $self ); ### if a custom fetch location got specified before, add that here $args{fetch_from} = $self->status->_fetch_from if $self->status->_fetch_from; my $where = $cb->_fetch( @_, %args ) or return; ### do an md5 check ### if( !$self->status->_fetch_from and $cb->configure_object->get_conf('md5') and $self->package ne CHECKSUMS ) { unless( $self->_validate_checksum ) { error( loc( "Checksum error for '%1' -- will not trust package", $self->package) ); return; } } return $where; } =pod =head2 $path = $self->extract Extracts the fetched module. Look at L for details on the options you can pass. =cut sub extract { my $self = shift; my $cb = $self->parent; unless( $self->status->fetch ) { error( loc( "You have not fetched '%1' yet -- cannot extract", $self->module) ); return; } ### can't extract these, so just use the basedir for the file if( $self->is_autobundle ) { ### this is expected to be set after an extract call $self->get_installer_type; return $self->status->extract( dirname( $self->status->fetch ) ); } return $cb->_extract( @_, module => $self ); } =head2 $type = $self->get_installer_type([prefer_makefile => BOOL]) Gets the installer type for this module. This may either be C or C. If C is unavailable or no installer type is available, it will fall back to C. If both are available, it will pick the one indicated by your config, or by the C option you can pass to this function. Returns the installer type on success, and false on error. =cut sub get_installer_type { my $self = shift; my $cb = $self->parent; my $conf = $cb->configure_object; my %hash = @_; my ($prefer_makefile,$verbose); my $tmpl = { prefer_makefile => { default => $conf->get_conf('prefer_makefile'), store => \$prefer_makefile, allow => BOOLEANS }, verbose => { default => $conf->get_conf('verbose'), store => \$verbose }, }; check( $tmpl, \%hash ) or return; my $type; ### autobundles use their own installer, so return that if( $self->is_autobundle ) { $type = INSTALLER_AUTOBUNDLE; } else { my $extract = $self->status->extract(); unless( $extract ) { error(loc( "Cannot determine installer type of unextracted module '%1'", $self->module )); return; } ### check if it's a makemaker or a module::build type dist ### my $found_build = -e BUILD_PL->( $extract ); my $found_makefile = -e MAKEFILE_PL->( $extract ); $type = INSTALLER_BUILD if !$prefer_makefile && $found_build; $type = INSTALLER_BUILD if $found_build && !$found_makefile; $type = INSTALLER_MM if $prefer_makefile && $found_makefile; $type = INSTALLER_MM if $found_makefile && !$found_build; # Special case Module::Build to always use INSTALLER_MM $type = INSTALLER_MM if $self->package =~ m{^Module-Build-\d}; } ### ok, so it's a 'build' installer, but you don't /have/ module build ### XXX duplicated from CPANPLUS::Selfupdate. fix somehow? if( $type and $type eq INSTALLER_BUILD and ( not CPANPLUS::Dist->has_dist_type( INSTALLER_BUILD ) or not $cb->module_tree( INSTALLER_BUILD ) ->is_uptodate( version => '0.60' ) ) ) { ### XXX this is for recording purposes only. We *have* to install ### these before even creating a dist object, or we'll get an error ### saying 'no such dist type'; ### XXX duplicated from CPANPLUS::Selfupdate. fix somehow? my $href = $self->status->configure_requires || {}; my $deps = { INSTALLER_BUILD, '0.60', %$href }; $self->status->configure_requires( $deps ); msg(loc("This module requires '%1' and '%2' to be installed first. ". "Adding these modules to your prerequisites list", 'Module::Build', INSTALLER_BUILD ), $verbose ); ### ok, actually we found neither ### } elsif ( !$type ) { error( loc( "Unable to find '%1' or '%2' for '%3'; ". "Will default to '%4' but might be unable ". "to install!", BUILD_PL->(), MAKEFILE_PL->(), $self->module, INSTALLER_MM ) ); $type = INSTALLER_MM; } return $self->status->installer_type( $type ) if $type; return; } =pod =head2 $dist = $self->dist([target => 'prepare|create', format => DISTRIBUTION_TYPE, args => {key => val}]); Create a distribution object, ready to be installed. Distribution type defaults to your config settings The optional C hashref is passed on to the specific distribution types' C method after being dereferenced. Returns a distribution object on success, false on failure. See C for details. =cut sub dist { my $self = shift; my $cb = $self->parent; my $conf = $cb->configure_object; my %hash = @_; ### have you determined your installer type yet? if not, do it here, ### we need the info $self->get_installer_type unless $self->status->installer_type; my($type,$args,$target); my $tmpl = { format => { default => $conf->get_conf('dist_type') || $self->status->installer_type, store => \$type }, target => { default => TARGET_CREATE, store => \$target }, args => { default => {}, store => \$args }, }; check( $tmpl, \%hash ) or return; ### ok, check for $type. Do we have it? unless( CPANPLUS::Dist->has_dist_type( $type ) ) { ### ok, we don't have it. Is it C::D::Build? if so we can install the ### whole thing now ### XXX we _could_ do this for any type we dont have actually... if( $type eq INSTALLER_BUILD ) { msg(loc("Bootstrapping installer '%1'", $type)); ### don't propagate the format, it's the one we're trying to ### bootstrap, so it'll be an infinite loop if we do $cb->module_tree( $type )->install( target => $target, %$args ) or do { error(loc("Could not bootstrap installer '%1' -- ". "can not continue", $type)); return; }; ### re-scan for available modules now CPANPLUS::Dist->rescan_dist_types; unless( CPANPLUS::Dist->has_dist_type( $type ) ) { error(loc("Newly installed installer type '%1' should be ". "available, but is not! -- aborting", $type)); return; } else { msg(loc("Installer '%1' successfully bootstrapped", $type)); } ### some other plugin you dont have. Abort } else { error(loc("Installer type '%1' not found. Please verify your ". "installation -- aborting", $type )); return; } } ### make sure we don't overwrite it, just in case we came ### back from a ->save_state. This allows restoration to ### work correctly my( $dist, $dist_cpan ); unless( $dist = $self->status->dist ) { $dist = $type->new( module => $self ) or return; $self->status->dist( $dist ); } unless( $dist_cpan = $self->status->dist_cpan ) { $dist_cpan = $type eq $self->status->installer_type ? $self->status->dist : $self->status->installer_type->new( module => $self ); $self->status->dist_cpan( $dist_cpan ); } DIST: { ### just wanted the $dist object? last DIST if $target eq TARGET_INIT; ### first prepare the dist $dist->prepare( %$args ) or return; $self->status->prepared(1); ### you just wanted us to prepare? last DIST if $target eq TARGET_PREPARE; $dist->create( %$args ) or return; $self->status->created(1); } return $dist; } =pod =head2 $bool = $mod->prepare( ) Convenience method around C that prepares a module without actually building it. This is equivalent to invoking C with C set to C Returns true on success, false on failure. =cut sub prepare { my $self = shift; return $self->install( @_, target => TARGET_PREPARE ); } =head2 $bool = $mod->create( ) Convenience method around C that creates a module. This is equivalent to invoking C with C set to C Returns true on success, false on failure. =cut sub create { my $self = shift; return $self->install( @_, target => TARGET_CREATE ); } =head2 $bool = $mod->test( ) Convenience wrapper around C that tests a module, without installing it. It's the equivalent to invoking C with C set to C and C set to C<0>. Returns true on success, false on failure. =cut sub test { my $self = shift; return $self->install( @_, target => TARGET_CREATE, skiptest => 0 ); } =pod =head2 $bool = $self->install([ target => 'init|prepare|create|install', format => FORMAT_TYPE, extractdir => DIRECTORY, fetchdir => DIRECTORY, prefer_bin => BOOL, force => BOOL, verbose => BOOL, ..... ]); Installs the current module. This includes fetching it and extracting it, if this hasn't been done yet, as well as creating a distribution object for it. This means you can pass it more arguments than described above, which will be passed on to the relevant methods as they are called. See C, C and C for details. Returns true on success, false on failure. =cut sub install { my $self = shift; my $cb = $self->parent; my $conf = $cb->configure_object; my %hash = @_; my $args; my $target; my $format; { ### so we can use the rest of the args to the create calls etc ### local $Params::Check::NO_DUPLICATES = 1; local $Params::Check::ALLOW_UNKNOWN = 1; ### targets 'dist' and 'test' are now completely ignored ### my $tmpl = { ### match this allow list with Dist->_resolve_prereqs target => { default => TARGET_INSTALL, store => \$target, allow => [TARGET_PREPARE, TARGET_CREATE, TARGET_INSTALL, TARGET_INIT ] }, force => { default => $conf->get_conf('force'), }, verbose => { default => $conf->get_conf('verbose'), }, format => { default => $conf->get_conf('dist_type'), store => \$format }, }; $args = check( $tmpl, \%hash ) or return; } ### if this target isn't 'install', we will need to at least 'create' ### every prereq, so it can build ### XXX prereq_target of 'prepare' will do weird things here, and is ### not supported. $args->{'prereq_target'} ||= TARGET_CREATE if $target ne TARGET_INSTALL; ### check if it's already upto date ### if( $target eq TARGET_INSTALL and !$args->{'force'} and !$self->package_is_perl_core() and # separate rules apply ( $self->status->installed() or $self->is_uptodate ) and !INSTALL_VIA_PACKAGE_MANAGER->($format) ) { msg(loc("Module '%1' already up to date, won't install without force", $self->module), $args->{'verbose'} ); return $self->status->installed(1); } # if it's a non-installable core package, abort the install. if( $self->package_is_perl_core() ) { # if the installed is newer, say so. if( $self->installed_version > $self->version ) { error(loc("The core Perl %1 module '%2' (%3) is more ". "recent than the latest release on CPAN (%4). ". "Aborting install.", $], $self->module, $self->installed_version, $self->version ) ); # if the installed matches, say so. } elsif( $self->installed_version == $self->version ) { error(loc("The core Perl %1 module '%2' (%3) can only ". "be installed by Perl itself. ". "Aborting install.", $], $self->module, $self->installed_version ) ); # otherwise, the installed is older; say so. } else { error(loc("The core Perl %1 module '%2' can only be ". "upgraded from %3 to %4 by Perl itself (%5). ". "Aborting install.", $], $self->module, $self->installed_version, $self->version, $self->package ) ); } return; ### it might be a known 3rd party module } elsif ( $self->is_third_party ) { my $info = $self->third_party_information; error(loc( "%1 is a known third-party module.\n\n". "As it isn't available on the CPAN, CPANPLUS can't install " . "it automatically. Therefore you need to install it manually " . "before proceeding.\n\n". "%2 is part of %3, published by %4, and should be available ". "for download at the following address:\n\t%5", $self->name, $self->name, $info->{name}, $info->{author}, $info->{url} )); return; } ### fetch it if need be ### unless( $self->status->fetch ) { my $params; for (qw[prefer_bin fetchdir]) { $params->{$_} = $args->{$_} if exists $args->{$_}; } for (qw[force verbose]) { $params->{$_} = $args->{$_} if defined $args->{$_}; } $self->fetch( %$params ) or return; } ### extract it if need be ### unless( $self->status->extract ) { my $params; for (qw[prefer_bin extractdir]) { $params->{$_} = $args->{$_} if exists $args->{$_}; } for (qw[force verbose]) { $params->{$_} = $args->{$_} if defined $args->{$_}; } $self->extract( %$params ) or return; } $args->{'prereq_format'} = $format if $format; $format ||= $self->status->installer_type; unless( $format ) { error( loc( "Don't know what installer to use; " . "Couldn't find either '%1' or '%2' in the extraction " . "directory '%3' -- will be unable to install", BUILD_PL->(), MAKEFILE_PL->(), $self->status->extract ) ); $self->status->installed(0); return; } ### do SIGNATURE checks? ### ### XXX check status and not recheck EVERY time? if( $conf->get_conf('signature') ) { unless( $self->check_signature( verbose => $args->{verbose} ) ) { error( loc( "Signature check failed for module '%1' ". "-- Not trusting this module, aborting install", $self->module ) ); $self->status->signature(0); ### send out test report on broken sig if( $conf->get_conf('cpantest') ) { $cb->_send_report( module => $self, failed => 1, buffer => CPANPLUS::Error->stack_as_string, verbose => $args->{verbose}, force => $args->{force}, ) or error(loc("Failed to send test report for '%1'", $self->module ) ); } return; } else { ### signature OK ### $self->status->signature(1); } } ### a target of 'create' basically means not to run make test ### ### eh, no it /doesn't/.. skiptest => 1 means skiptest => 1. #$args->{'skiptest'} = 1 if $target eq 'create'; ### bundle rules apply ### if( $self->is_bundle ) { ### check what we need to install ### my @prereqs = $self->bundle_modules(); unless( @prereqs ) { error( loc( "Bundle '%1' does not specify any modules to install", $self->module ) ); ### XXX mark an error here? ### } } my $dist = $self->dist( format => $format, target => $target, args => $args ); unless( $dist ) { error( loc( "Unable to create a new distribution object for '%1' " . "-- cannot continue", $self->module ) ); return; } return 1 if $target ne TARGET_INSTALL; my $ok = $dist->install( %$args ) ? 1 : 0; $self->status->installed($ok); return 1 if $ok; return; } =pod =head2 @list = $self->bundle_modules() Returns a list of module objects the Bundle specifies. This requires you to have extracted the bundle already, using the C method. Returns false on error. =cut sub bundle_modules { my $self = shift; my $cb = $self->parent; unless( $self->is_bundle ) { error( loc("'%1' is not a bundle", $self->module ) ); return; } my @files; ### autobundles are special files generated by CPANPLUS. If we can ### read the file, we can determine the prereqs if( $self->is_autobundle ) { my $where; unless( $where = $self->status->fetch ) { error(loc("Don't know where '%1' was fetched to", $self->package)); return; } push @files, $where ### regular bundle::* upload } else { my $dir; unless( $dir = $self->status->extract ) { error(loc("Don't know where '%1' was extracted to", $self->module)); return; } find( { wanted => sub { push @files, File::Spec->rel2abs($_) if /\.pm/i }, no_chdir => 1, }, $dir ); } my $prereqs = {}; my @list; my $seen = {}; for my $file ( @files ) { my $fh = FileHandle->new($file) or( error(loc("Could not open '%1' for reading: %2", $file,$!)), next ); my $flag; while( local $_ = <$fh> ) { ### quick hack to read past the header of the file ### last if $flag && m|^=head|i; ### from perldoc cpan: ### =head1 CONTENTS ### In this pod section each line obeys the format ### Module_Name [Version_String] [- optional text] $flag = 1 if m|^=head1 CONTENTS|i; if ($flag && /^(?!=)(\S+)\s*(\S+)?/) { my $module = $1; my $version = $cb->_version_to_number( version => $2 ); my $obj = $cb->module_tree($module); unless( $obj ) { error(loc("Cannot find bundled module '%1'", $module), loc("-- it does not seem to exist") ); next; } ### make sure we list no duplicates ### unless( $seen->{ $obj->module }++ ) { push @list, $obj; $prereqs->{ $module } = $cb->_version_to_number( version => $version ); } } } } ### store the prereqs we just found ### $self->status->prereqs( $prereqs ); return @list; } =pod =head2 $text = $self->readme Fetches the readme belonging to this module and stores it under C<< $obj->status->readme >>. Returns the readme as a string on success and returns false on failure. =cut sub readme { my $self = shift; my $conf = $self->parent->configure_object; ### did we already dl the readme once? ### return $self->status->readme() if $self->status->readme(); ### this should be core ### return unless can_load( modules => { FileHandle => '0.0' }, verbose => 1, ); ### get a clone of the current object, with a fresh status ### my $obj = $self->clone or return; ### munge the package name my $pkg = README->( $obj ); $obj->package($pkg); my $file; { ### disable checksum fetches on readme downloads my $tmp = $conf->get_conf( 'md5' ); $conf->set_conf( md5 => 0 ); $file = $obj->fetch; $conf->set_conf( md5 => $tmp ); return unless $file; } ### read the file into a scalar, to store in the original object ### my $fh = new FileHandle; unless( $fh->open($file) ) { error( loc( "Could not open file '%1': %2", $file, $! ) ); return; } my $in = do{ local $/; <$fh> }; $fh->close; return $self->status->readme( $in ); } =pod =head2 $version = $self->installed_version() Returns the currently installed version of this module, if any. =head2 $where = $self->installed_file() Returns the location of the currently installed file of this module, if any. =head2 $dir = $self->installed_dir() Returns the directory (or more accurately, the C<@INC> handle) from which this module was loaded, if any. =head2 $bool = $self->is_uptodate([version => VERSION_NUMBER]) Returns a boolean indicating if this module is uptodate or not. =cut ### uptodate/installed functions { my $map = { # hashkey, alternate rv installed_version => ['version', 0 ], installed_file => ['file', ''], installed_dir => ['dir', ''], is_uptodate => ['uptodate', 0 ], }; while( my($method, $aref) = each %$map ) { my($key,$alt_rv) = @$aref; no strict 'refs'; *$method = sub { ### never use the @INC hooks to find installed versions of ### modules -- they're just there in case they're not on the ### perl install, but the user shouldn't trust them for *other* ### modules! ### XXX CPANPLUS::inc is now obsolete, so this should not ### be needed anymore #local @INC = CPANPLUS::inc->original_inc; my $self = shift; ### make sure check_install is not looking in %INC, as ### that may contain some of our sneakily loaded modules ### that aren't installed as such. -- kane local $Module::Load::Conditional::CHECK_INC_HASH = 0; ### this should all that is required for deprecated core modules local $Module::Load::Conditional::DEPRECATED = 1; my $href = check_install( module => $self->module, version => $self->version, @_, ); ### Don't trust modules which are the result of @INC hooks ### FatPacker uses this trickery and it causes WTF moments return $alt_rv if defined $href->{dir} && ref $href->{dir}; return $href->{$key} || $alt_rv; } } } =pod =head2 $href = $self->details() Returns a hashref with key/value pairs offering more information about a particular module. For example, for C it might look like this: Author Jarkko Hietaniemi (jhi@iki.fi) Description High resolution time, sleep, and alarm Development Stage Released Installed File /usr/local/perl/lib/Time/Hires.pm Interface Style plain Functions, no references used Language Used C and perl, a C compiler will be needed Package Time-HiRes-1.65.tar.gz Public License Unknown Support Level Developer Version Installed 1.52 Version on CPAN 1.65 =cut sub details { my $self = shift; my $conf = $self->parent->configure_object(); my $cb = $self->parent; my %hash = @_; my $res = { Author => loc("%1 (%2)", $self->author->author(), $self->author->email() ), Package => $self->package, Description => $self->description || loc('None given'), 'Version on CPAN' => $self->version, }; ### check if we have the module installed ### if so, add version have and version on cpan $res->{'Version Installed'} = $self->installed_version if $self->installed_version; $res->{'Installed File'} = $self->installed_file if $self->installed_file; my $i = 0; for my $item( split '', $self->dslip ) { $res->{ $cb->_dslip_defs->[$i]->[0] } = $cb->_dslip_defs->[$i]->[1]->{$item} || loc('Unknown'); $i++; } return $res; } =head2 @list = $self->contains() Returns a list of module objects that represent the modules also present in the package of this module. For example, for C this might return: Archive::Tar Archive::Tar::Constant Archive::Tar::File =cut sub contains { my $self = shift; my $cb = $self->parent; my $pkg = $self->package; my @mods = $cb->search( type => 'package', allow => [qr/^$pkg$/] ); return @mods; } =pod =head2 @list_of_hrefs = $self->fetch_report() This function queries the CPAN testers database at I for test results of specified module objects, module names or distributions. Look at L for details on the options you can pass and the return value to expect. =cut sub fetch_report { my $self = shift; my $cb = $self->parent; return $cb->_query_report( @_, module => $self ); } =pod =head2 $bool = $self->uninstall([type => [all|man|prog]) This function uninstalls the specified module object. You can install 2 types of files, either C pages or Cram files. Alternately you can specify C to uninstall both (which is the default). Returns true on success and false on failure. Do note that this does an uninstall via the so-called C<.packlist>, so if you used a module installer like say, C or C, you should not use this, but use your package manager instead. =cut sub uninstall { my $self = shift; my $conf = $self->parent->configure_object(); my %hash = @_; my ($type,$verbose); my $tmpl = { type => { default => 'all', allow => [qw|man prog all|], store => \$type }, verbose => { default => $conf->get_conf('verbose'), store => \$verbose }, force => { default => $conf->get_conf('force') }, }; ### XXX add a warning here if your default install dist isn't ### makefile or build -- that means you are using a package manager ### and this will not do what you think! my $args = check( $tmpl, \%hash ) or return; if( $conf->get_conf('dist_type') and ( ($conf->get_conf('dist_type') ne INSTALLER_BUILD) or ($conf->get_conf('dist_type') ne INSTALLER_MM)) ) { msg(loc("You have a default installer type set (%1) ". "-- you should probably use that package manager to " . "uninstall modules", $conf->get_conf('dist_type')), $verbose); } ### check if we even have the module installed -- no point in continuing ### otherwise unless( $self->installed_version ) { error( loc( "Module '%1' is not installed, so cannot uninstall", $self->module ) ); return; } ### nothing to uninstall ### my $files = $self->files( type => $type ) or return; my $dirs = $self->directory_tree( type => $type ) or return; my $sudo = $conf->get_program('sudo'); ### just in case there's no file; M::B doesn't provide .packlists yet ### my $pack = $self->packlist; $pack = $pack->[0]->packlist_file() if $pack; ### first remove the files, then the dirs if they are empty ### my $flag = 0; for my $file( @$files, $pack ) { next unless defined $file && -f $file; msg(loc("Unlinking '%1'", $file), $verbose); my @cmd = ($^X, "-eunlink+q[$file]"); unshift @cmd, $sudo if $sudo; my $buffer; unless ( run( command => \@cmd, verbose => $verbose, buffer => \$buffer ) ) { error(loc("Failed to unlink '%1': '%2'",$file, $buffer)); $flag++; } } for my $dir ( sort @$dirs ) { local *DIR; opendir DIR, $dir or next; my @count = readdir(DIR); close DIR; next unless @count == 2; # . and .. msg(loc("Removing '%1'", $dir), $verbose); ### this fails on my win2k machines.. it indeed leaves the ### dir, but it's not a critical error, since the files have ### been removed. --kane #unless( rmdir $dir ) { # error( loc( "Could not remove '%1': %2", $dir, $! ) ) # unless $^O eq 'MSWin32'; #} my @cmd = ($^X, "-e", "rmdir q[$dir]"); unshift @cmd, $sudo if $sudo; my $buffer; unless ( run( command => \@cmd, verbose => $verbose, buffer => \$buffer ) ) { error(loc("Failed to rmdir '%1': %2",$dir,$buffer)); $flag++; } } $self->status->uninstall(!$flag); $self->status->installed( $flag ? 1 : undef); return !$flag; } =pod =head2 @modobj = $self->distributions() Returns a list of module objects representing all releases for this module on success, false on failure. =cut sub distributions { my $self = shift; my %hash = @_; my @list = $self->author->distributions( %hash, module => $self ) or return; ### it's another release then by the same author ### return grep { $_->package_name eq $self->package_name } @list; } =pod =head2 @list = $self->files () Returns a list of files used by this module, if it is installed. =head2 @list = $self->directory_tree () Returns a list of directories used by this module. =head2 @list = $self->packlist () Returns the C object for this module. =head2 @list = $self->validate () Returns a list of files that are missing for this modules, but are present in the .packlist file. =cut for my $sub (qw[files directory_tree packlist validate]) { no strict 'refs'; *$sub = sub { return shift->_extutils_installed( @_, method => $sub ); } } ### generic method to call an ExtUtils::Installed method ### sub _extutils_installed { my $self = shift; my $cb = $self->parent; my $conf = $cb->configure_object; my $home = $cb->_home_dir; # may be needed to fix up prefixes my %hash = @_; my ($verbose,$type,$method); my $tmpl = { verbose => { default => $conf->get_conf('verbose'), store => \$verbose, }, type => { default => 'all', allow => [qw|prog man all|], store => \$type, }, method => { required => 1, store => \$method, allow => [qw|files directory_tree packlist validate|], }, }; my $args = check( $tmpl, \%hash ) or return; ### old versions of cygwin + perl < 5.8 are buggy here. bail out if we ### find we're being used by them { my $err = ON_OLD_CYGWIN; if($err) { error($err); return }; } return unless can_load( modules => { 'ExtUtils::Installed' => '0.0' }, verbose => $verbose, ); my @config_names = ( ### lib { lib => 'privlib', # perl-only arch => 'archlib', # compiled code prefix => 'prefix', # prefix to both }, ### site { lib => 'sitelib', arch => 'sitearch', prefix => 'siteprefix', }, ### vendor { lib => 'vendorlib', arch => 'vendorarch', prefix => 'vendorprefix', }, ); ### search in your regular @INC, and anything you added to your config. ### this lets EU::Installed find .packlists that are *not* in the standard ### compiled in @INC path. Requires EU::I 1.42 or up. this addresses #33438 ### make sure the archname path is also added, as that's where the .packlist ### files are written my @libs; for my $lib ( @{ $conf->get_conf('lib') } ) { require Config; ### and just the standard dir push @libs, $lib; ### figure out what an MM prefix expands to. Basically, it's the ### site install target from %Config, ie: /opt/lib/perl5/site_perl/5.8.8 ### minus the site wide prefix, ie: /opt ### this lets users add the dir they have set as their EU::MM PREFIX ### to our 'lib' config and it Just Works ### the arch specific dir, ie: ### /opt/lib/perl5/site_perl/5.8.8/darwin-2level ### XXX is this the right thing to do? ### we add all 6 dir combos for prefixes: ### /foo/lib ### /foo/lib/arch ### /foo/site/lib ### /foo/site/lib/arch ### /foo/vendor/lib ### /foo/vendor/lib/arch for my $href ( @config_names ) { for my $key ( qw[lib arch] ) { ### look up the config value -- use EXP for the EXPANDED ### version, so no ~ etc are found in there my $dir = $Config::Config{ $href->{ $key } .'exp' } or next; my $prefix = $Config::Config{ $href->{prefix} }; ### prefix may be relative to home, and contain a ~ ### if so, fix it up. $prefix =~ s/^~/$home/; ### remove the prefix from it, so we can append to our $lib $dir =~ s/^\Q$prefix\E//; ### do the appending push @libs, File::Spec->catdir( $lib, $dir ); } } } my $inst; unless( $inst = ExtUtils::Installed->new( extra_libs => \@libs ) ) { error( loc("Could not create an '%1' object", 'ExtUtils::Installed' ) ); ### in case it's being used directly... ### return; } { ### EU::Installed can die =/ my @files; eval { @files = $inst->$method( $self->module, $type ) }; if( $@ ) { chomp $@; error( loc("Could not get '%1' for '%2': %3", $method, $self->module, $@ ) ); return; } return wantarray ? @files : \@files; } } =head2 $bool = $self->add_to_includepath; Adds the current modules path to C<@INC> and C<$PERL5LIB>. This allows you to add the module from its build dir to your path. It also adds the current modules C and/or C