diff options
Diffstat (limited to 'Master/tlpkg/tlperl0/lib/CPANPLUS/Dist.pm')
-rwxr-xr-x | Master/tlpkg/tlperl0/lib/CPANPLUS/Dist.pm | 688 |
1 files changed, 688 insertions, 0 deletions
diff --git a/Master/tlpkg/tlperl0/lib/CPANPLUS/Dist.pm b/Master/tlpkg/tlperl0/lib/CPANPLUS/Dist.pm new file mode 100755 index 00000000000..00c68c39806 --- /dev/null +++ b/Master/tlpkg/tlperl0/lib/CPANPLUS/Dist.pm @@ -0,0 +1,688 @@ +package CPANPLUS::Dist; + +use strict; + +use CPANPLUS::Error; +use CPANPLUS::Internals::Constants; + +use Cwd (); +use Object::Accessor; +use Parse::CPAN::Meta; + +use IPC::Cmd qw[run]; +use Params::Check qw[check]; +use Module::Load::Conditional qw[can_load check_install]; +use Locale::Maketext::Simple Class => 'CPANPLUS', Style => 'gettext'; + +use base 'Object::Accessor'; + +local $Params::Check::VERBOSE = 1; + +=pod + +=head1 NAME + +CPANPLUS::Dist + +=head1 SYNOPSIS + + my $dist = CPANPLUS::Dist::YOUR_DIST_TYPE_HERE->new( + module => $modobj, + ); + +=head1 DESCRIPTION + +C<CPANPLUS::Dist> is a base class for C<CPANPLUS::Dist::MM> +and C<CPANPLUS::Dist::Build>. Developers of other C<CPANPLUS::Dist::*> +plugins should look at C<CPANPLUS::Dist::Base>. + +=head1 ACCESSORS + +=over 4 + +=item parent() + +Returns the C<CPANPLUS::Module> object that parented this object. + +=item status() + +Returns the C<Object::Accessor> object that keeps the status for +this module. + +=back + +=head1 STATUS ACCESSORS + +All accessors can be accessed as follows: + $deb->status->ACCESSOR + +=over 4 + +=item created() + +Boolean indicating whether the dist was created successfully. +Explicitly set to C<0> when failed, so a value of C<undef> may be +interpreted as C<not yet attempted>. + +=item installed() + +Boolean indicating whether the dist was installed successfully. +Explicitly set to C<0> when failed, so a value of C<undef> may be +interpreted as C<not yet attempted>. + +=item uninstalled() + +Boolean indicating whether the dist was uninstalled successfully. +Explicitly set to C<0> when failed, so a value of C<undef> may be +interpreted as C<not yet attempted>. + +=item dist() + +The location of the final distribution. This may be a file or +directory, depending on how your distribution plug in of choice +works. This will be set upon a successful create. + +=cut + +=back + +=head2 $dist = CPANPLUS::Dist::YOUR_DIST_TYPE_HERE->new( module => MODOBJ ); + +Create a new C<CPANPLUS::Dist::YOUR_DIST_TYPE_HERE> object based on the +provided C<MODOBJ>. + +*** DEPRECATED *** +The optional argument C<format> is used to indicate what type of dist +you would like to create (like C<CPANPLUS::Dist::MM> or +C<CPANPLUS::Dist::Build> and so on ). + +C<< CPANPLUS::Dist->new >> is exlusively meant as a method to be +inherited by C<CPANPLUS::Dist::MM|Build>. + +Returns a C<CPANPLUS::Dist::YOUR_DIST_TYPE_HERE> object on success +and false on failure. + +=cut + +sub new { + my $self = shift; + my $class = ref $self || $self; + my %hash = @_; + + ### first verify we got a module object ### + my( $mod, $format ); + my $tmpl = { + module => { required => 1, allow => IS_MODOBJ, store => \$mod }, + ### for backwards compatibility + format => { default => $class, store => \$format, + allow => [ __PACKAGE__->dist_types ], + }, + }; + check( $tmpl, \%hash ) or return; + + unless( can_load( modules => { $format => '0.0' }, verbose => 1 ) ) { + error(loc("'%1' not found -- you need '%2' version '%3' or higher ". + "to detect plugins", $format, 'Module::Pluggable','2.4')); + return; + } + + ### get an empty o::a object for this class + my $obj = $format->SUPER::new; + + $obj->mk_accessors( qw[parent status] ); + + ### set the parent + $obj->parent( $mod ); + + ### create a status object ### + { my $acc = Object::Accessor->new; + $obj->status($acc); + + ### add minimum supported accessors + $acc->mk_accessors( qw[prepared created installed uninstalled + distdir dist] ); + } + + ### get the conf object ### + my $conf = $mod->parent->configure_object(); + + ### check if the format is available in this environment ### + if( $conf->_get_build('sanity_check') and not $obj->format_available ) { + error( loc( "Format '%1' is not available", $format) ); + return; + } + + ### now initialize it or admit failure + unless( $obj->init ) { + error(loc("Dist initialization of '%1' failed for '%2'", + $format, $mod->module)); + return; + } + + ### return the object + return $obj; +} + +=head2 @dists = CPANPLUS::Dist->dist_types; + +Returns a list of the CPANPLUS::Dist::* classes available + +=cut + +### returns a list of dist_types we support +### will get overridden by Module::Pluggable if loaded +### XXX add support for 'plugin' dir in config as well +{ my $Loaded; + my @Dists = (INSTALLER_MM); + my @Ignore = (); + + ### backdoor method to add more dist types + sub _add_dist_types { my $self = shift; push @Dists, @_ }; + + ### backdoor method to exclude dist types + sub _ignore_dist_types { my $self = shift; push @Ignore, @_ }; + sub _reset_dist_ignore { @Ignore = () }; + + ### locally add the plugins dir to @INC, so we can find extra plugins + #local @INC = @INC, File::Spec->catdir( + # $conf->get_conf('base'), + # $conf->_get_build('plugins') ); + + ### load any possible plugins + sub dist_types { + + if ( !$Loaded++ and check_install( module => 'Module::Pluggable', + version => '2.4') + ) { + require Module::Pluggable; + + my $only_re = __PACKAGE__ . '::\w+$'; + my %except = map { $_ => 1 } + INSTALLER_SAMPLE, + INSTALLER_BASE; + + Module::Pluggable->import( + sub_name => '_dist_types', + search_path => __PACKAGE__, + only => qr/$only_re/, + require => 1, + except => [ keys %except ] + ); + my %ignore = map { $_ => $_ } @Ignore; + + push @Dists, grep { not $ignore{$_} and not $except{$_} } + __PACKAGE__->_dist_types; + } + + return @Dists; + } + +=head2 $bool = CPANPLUS::Dist->rescan_dist_types; + +Rescans C<@INC> for available dist types. Useful if you've installed new +C<CPANPLUS::Dist::*> classes and want to make them available to the +current process. + +=cut + + sub rescan_dist_types { + my $dist = shift; + $Loaded = 0; # reset the flag; + return $dist->dist_types; + } +} + +=head2 $bool = CPANPLUS::Dist->has_dist_type( $type ) + +Returns true if distribution type C<$type> is loaded/supported. + +=cut + +sub has_dist_type { + my $dist = shift; + my $type = shift or return; + + return scalar grep { $_ eq $type } CPANPLUS::Dist->dist_types; +} + +=head2 $bool = $dist->prereq_satisfied( modobj => $modobj, version => $version_spec ) + +Returns true if this prereq is satisfied. Returns false if it's not. +Also issues an error if it seems "unsatisfiable," i.e. if it can't be +found on CPAN or the latest CPAN version doesn't satisfy it. + +=cut + +sub prereq_satisfied { + my $dist = shift; + my $cb = $dist->parent->parent; + my %hash = @_; + + my($mod,$ver); + my $tmpl = { + version => { required => 1, store => \$ver }, + modobj => { required => 1, store => \$mod, allow => IS_MODOBJ }, + }; + + check( $tmpl, \%hash ) or return; + + return 1 if $mod->is_uptodate( version => $ver ); + + if ( $cb->_vcmp( $ver, $mod->version ) > 0 ) { + + error(loc( + "This distribution depends on %1, but the latest version". + " of %2 on CPAN (%3) doesn't satisfy the specific version". + " dependency (%4). You may have to resolve this dependency ". + "manually.", + $mod->module, $mod->module, $mod->version, $ver )); + + } + + return; +} + +=head2 $configure_requires = $dist->find_configure_requires( [file => /path/to/META.yml] ) + +Reads the configure_requires for this distribution from the META.yml +file in the root directory and returns a hashref with module names +and versions required. + +=cut + +sub find_configure_requires { + my $self = shift; + my $mod = $self->parent; + my $meth = 'configure_requires'; + + ### the prereqs as we have them now + my @args = ( + defaults => $mod->status->$meth || {}, + keys => [ $meth ], + ); + + ### the default file to use, which may be overriden + push @args, ( file => META_YML->( $mod->status->extract ) ) + if defined $mod->status->extract; + + my $href = $self->_prereqs_from_meta_file( @args, @_ ); + + ### and store it in the module + $mod->status->$meth( $href ); + + return { %$href }; +} + +sub find_mymeta_requires { + my $self = shift; + my $mod = $self->parent; + my $meth = 'prereqs'; + + ### the prereqs as we have them now + my @args = ( + defaults => $mod->status->$meth || {}, + keys => [qw|requires build_requires|], + ); + + ### the default file to use, which may be overriden + push @args, ( file => MYMETA_YML->( $mod->status->extract ) ) + if defined $mod->status->extract; + + my $href = $self->_prereqs_from_meta_file( @args, @_ ); + + ### and store it in the module + $mod->status->$meth( $href ); + + return { %$href }; +} + +sub _prereqs_from_meta_file { + my $self = shift; + my $mod = $self->parent; + my %hash = @_; + + my( $meta, $defaults, $keys ); + my $tmpl = { ### check if we have an extract path. if not, we + ### get 'undef value' warnings from file::spec + file => { default => do { defined $mod->status->extract + ? META_YML->( $mod->status->extract ) + : '' }, + store => \$meta, + }, + defaults => { required => 1, default => {}, strict_type => 1, + store => \$defaults }, + keys => { required => 1, default => [], strict_type => 1, + store => \$keys }, + }; + + check( $tmpl, \%hash ) or return; + + ### if there's a meta file, we read it; + if( -e $meta ) { + + ### Parse::CPAN::Meta uses exceptions for errors + ### hash returned in list context!!! + my ($doc) = eval { Parse::CPAN::Meta::LoadFile( $meta ) }; + + unless( $doc ) { + error(loc( "Could not read %1: '%2'", $meta, $@ )); + return $defaults; + } + + ### read the keys now, make sure not to throw + ### away anything that was already added + for my $key ( @$keys ) { + $defaults = { + %$defaults, + %{ $doc->{$key} }, + } if $doc->{ $key }; + } + } + + ### and return a copy + return \%{ $defaults }; +} + +=head2 $bool = $dist->_resolve_prereqs( ... ) + +Makes sure prerequisites are resolved + + format The dist class to use to make the prereqs + (ie. CPANPLUS::Dist::MM) + + prereqs Hash of the prerequisite modules and their versions + + target What to do with the prereqs. + create => Just build them + install => Install them + ignore => Ignore them + + prereq_build If true, always build the prereqs even if already + resolved + + verbose Be verbose + + force Force the prereq to be built, even if already resolved + +=cut + +sub _resolve_prereqs { + my $dist = shift; + my $self = $dist->parent; + my $cb = $self->parent; + my $conf = $cb->configure_object; + my %hash = @_; + + my ($prereqs, $format, $verbose, $target, $force, $prereq_build); + my $tmpl = { + ### XXX perhaps this should not be required, since it may not be + ### packaged, just installed... + ### Let it be empty as well -- that means the $modobj->install + ### routine will figure it out, which is fine if we didn't have any + ### very specific wishes (it will even detect the favourite + ### dist_type). + format => { required => 1, store => \$format, + allow => ['',__PACKAGE__->dist_types], }, + prereqs => { required => 1, default => { }, + strict_type => 1, store => \$prereqs }, + verbose => { default => $conf->get_conf('verbose'), + store => \$verbose }, + force => { default => $conf->get_conf('force'), + store => \$force }, + ### make sure allow matches with $mod->install's list + target => { default => '', store => \$target, + allow => ['',qw[create ignore install]] }, + prereq_build => { default => 0, store => \$prereq_build }, + }; + + check( $tmpl, \%hash ) or return; + + ### so there are no prereqs? then don't even bother + return 1 unless keys %$prereqs; + + ### Make sure we wound up where we started. + my $original_wd = Cwd::cwd; + + ### so you didn't provide an explicit target. + ### maybe your config can tell us what to do. + $target ||= { + PREREQ_ASK, TARGET_INSTALL, # we'll bail out if the user says no + PREREQ_BUILD, TARGET_CREATE, + PREREQ_IGNORE, TARGET_IGNORE, + PREREQ_INSTALL, TARGET_INSTALL, + }->{ $conf->get_conf('prereqs') } || ''; + + ### XXX BIG NASTY HACK XXX FIXME at some point. + ### when installing Bundle::CPANPLUS::Dependencies, we want to + ### install all packages matching 'cpanplus' to be installed last, + ### as all CPANPLUS' prereqs are being installed as well, but are + ### being loaded for bootstrapping purposes. This means CPANPLUS + ### can find them, but for example cpanplus::dist::build won't, + ### which gets messy FAST. So, here we sort our prereqs only IF + ### the parent module is Bundle::CPANPLUS::Dependencies. + ### Really, we would wnat some sort of sorted prereq mechanism, + ### but Bundle:: doesn't support it, and we flatten everything + ### to a hash internally. A sorted hash *might* do the trick if + ### we got a transparent implementation.. that would mean we would + ### just have to remove the 'sort' here, and all will be well + my @sorted_prereqs; + + ### use regex, could either be a module name, or a package name + if( $self->module =~ /^Bundle(::|-)CPANPLUS(::|-)Dependencies/ ) { + my (@first, @last); + for my $mod ( sort keys %$prereqs ) { + $mod =~ /CPANPLUS/ + ? push @last, $mod + : push @first, $mod; + } + @sorted_prereqs = (@first, @last); + } else { + @sorted_prereqs = sort keys %$prereqs; + } + + ### first, transfer this key/value pairing into a + ### list of module objects + desired versions + my @install_me; + + for my $mod ( @sorted_prereqs ) { + my $version = $prereqs->{$mod}; + + ### 'perl' is a special case, there's no mod object for it + if( $mod eq PERL_CORE ) { + + ### run a CLI invocation to see if the perl you specified is + ### uptodate + my $ok = run( command => "$^X -M$version -e1", verbose => 0 ); + + unless( $ok ) { + error(loc( "Module '%1' needs perl version '%2', but you ". + "only have version '%3' -- can not proceed", + $self->module, $version, + $cb->_perl_version( perl => $^X ) ) ); + return; + } + + next; + } + + my $modobj = $cb->module_tree($mod); + + #### XXX we ignore the version, and just assume that the latest + #### version from cpan will meet your requirements... dodgy =/ + unless( $modobj ) { + # Check if it is a core module + my $sub = CPANPLUS::Module->can( + 'module_is_supplied_with_perl_core' ); + my $core = $sub->( $mod ); + unless ( $core ) { + error( loc( "No such module '%1' found on CPAN", $mod ) ); + next; + } + if ( $cb->_vcmp( $version, $core ) > 0 ) { + error(loc( "Version of core module '%1' ('%2') is too low for ". + "'%3' (needs '%4') -- carrying on but this may be a problem", + $mod, $core, + $self->module, $version )); + } + next; + } + + ### it's not uptodate, we need to install it + if( !$dist->prereq_satisfied(modobj => $modobj, version => $version)) { + msg(loc("Module '%1' requires '%2' version '%3' to be installed ", + $self->module, $modobj->module, $version), $verbose ); + + push @install_me, [$modobj, $version]; + + ### it's not an MM or Build format, that means it's a package + ### manager... we'll need to install it as well, via the PM + } elsif ( INSTALL_VIA_PACKAGE_MANAGER->($format) and + !$modobj->package_is_perl_core and + ($target ne TARGET_IGNORE) + ) { + msg(loc("Module '%1' depends on '%2', may need to build a '%3' ". + "package for it as well", $self->module, $modobj->module, + $format)); + push @install_me, [$modobj, $version]; + } + } + + + + ### so you just want to ignore prereqs? ### + if( $target eq TARGET_IGNORE ) { + + ### but you have modules you need to install + if( @install_me ) { + msg(loc("Ignoring prereqs, this may mean your install will fail"), + $verbose); + msg(loc("'%1' listed the following dependencies:", $self->module), + $verbose); + + for my $aref (@install_me) { + my ($mod,$version) = @$aref; + + my $str = sprintf "\t%-35s %8s\n", $mod->module, $version; + msg($str,$verbose); + } + + return; + + ### ok, no problem, you have all needed prereqs anyway + } else { + return 1; + } + } + + my $flag; + for my $aref (@install_me) { + my($modobj,$version) = @$aref; + + ### another prereq may have already installed this one... + ### so dont ask again if the module turns out to be uptodate + ### see bug [#11840] + ### if either force or prereq_build are given, the prereq + ### should be built anyway + next if (!$force and !$prereq_build) && + $dist->prereq_satisfied(modobj => $modobj, version => $version); + + ### either we're told to ignore the prereq, + ### or the user wants us to ask him + if( ( $conf->get_conf('prereqs') == PREREQ_ASK and not + $cb->_callbacks->install_prerequisite->($self, $modobj) + ) + ) { + msg(loc("Will not install prerequisite '%1' -- Note " . + "that the overall install may fail due to this", + $modobj->module), $verbose); + next; + } + + ### value set and false -- means failure ### + if( defined $modobj->status->installed + && !$modobj->status->installed + ) { + error( loc( "Prerequisite '%1' failed to install before in " . + "this session", $modobj->module ) ); + $flag++; + last; + } + + ### part of core? + if( $modobj->package_is_perl_core ) { + error(loc("Prerequisite '%1' is perl-core (%2) -- not ". + "installing that. Aborting install", + $modobj->module, $modobj->package ) ); + $flag++; + last; + } + + ### circular dependency code ### + my $pending = $cb->_status->pending_prereqs || {}; + + ### recursive dependency ### + if ( $pending->{ $modobj->module } ) { + error( loc( "Recursive dependency detected (%1) -- skipping", + $modobj->module ) ); + next; + } + + ### register this dependency as pending ### + $pending->{ $modobj->module } = $modobj; + $cb->_status->pending_prereqs( $pending ); + + ### call $modobj->install rather than doing + ### CPANPLUS::Dist->new and the like ourselves, + ### since ->install will take care of fetch && + ### extract as well + my $pa = $dist->status->_prepare_args || {}; + my $ca = $dist->status->_create_args || {}; + my $ia = $dist->status->_install_args || {}; + + unless( $modobj->install( %$pa, %$ca, %$ia, + force => $force, + verbose => $verbose, + format => $format, + target => $target ) + ) { + error(loc("Failed to install '%1' as prerequisite " . + "for '%2'", $modobj->module, $self->module ) ); + $flag++; + } + + ### unregister the pending dependency ### + $pending->{ $modobj->module } = 0; + $cb->_status->pending_prereqs( $pending ); + + last if $flag; + + ### don't want us to install? ### + if( $target ne TARGET_INSTALL ) { + my $dir = $modobj->status->extract + or error(loc("No extraction dir for '%1' found ". + "-- weird", $modobj->module)); + + $modobj->add_to_includepath(); + + next; + } + } + + ### reset the $prereqs iterator, in case we bailed out early ### + keys %$prereqs; + + ### chdir back to where we started + $cb->_chdir( dir => $original_wd ); + + return 1 unless $flag; + return; +} + +1; + +# Local variables: +# c-indentation-style: bsd +# c-basic-offset: 4 +# indent-tabs-mode: nil +# End: +# vim: expandtab shiftwidth=4: |