diff options
Diffstat (limited to 'Master/tlpkg/tlperl/lib/CPANPLUS/Dist.pm')
-rw-r--r-- | Master/tlpkg/tlperl/lib/CPANPLUS/Dist.pm | 808 |
1 files changed, 0 insertions, 808 deletions
diff --git a/Master/tlpkg/tlperl/lib/CPANPLUS/Dist.pm b/Master/tlpkg/tlperl/lib/CPANPLUS/Dist.pm deleted file mode 100644 index 51ee5fb9caa..00000000000 --- a/Master/tlpkg/tlperl/lib/CPANPLUS/Dist.pm +++ /dev/null @@ -1,808 +0,0 @@ -package CPANPLUS::Dist; -use deprecate; - -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 vars qw[$VERSION]; -$VERSION = "0.9135"; - -use base 'Object::Accessor'; - -local $Params::Check::VERBOSE = 1; - -=pod - -=head1 NAME - -CPANPLUS::Dist - base class for plugins - -=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 exclusively 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 or META.json -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 %hash = @_; - - my ($meta); - my $href = {}; - - my $tmpl = { - file => { store => \$meta }, - }; - - check( $tmpl, \%hash ) or return; - - my $meth = 'configure_requires'; - - { - - ### the prereqs as we have them now - my @args = ( - defaults => $mod->status->$meth || {}, - ); - - my @possibles = do { defined $mod->status->extract - ? ( META_JSON->( $mod->status->extract ), - META_YML->( $mod->status->extract ) ) - : () - }; - - unshift @possibles, $meta if $meta; - - META: foreach my $mfile ( grep { -e } @possibles ) { - push @args, ( file => $mfile ); - if ( $mfile =~ /\.json/ ) { - $href = $self->_prereqs_from_meta_json( @args, keys => [ 'configure' ] ); - } - else { - $href = $self->_prereqs_from_meta_file( @args, keys => [ $meth ] ); - } - last META; - } - - } - - ### and store it in the module - $mod->status->$meth( $href ); - - return { %$href }; -} - -sub find_mymeta_requires { - my $self = shift; - my $mod = $self->parent; - my %hash = @_; - - my ($meta); - my $href = {}; - - my $tmpl = { - file => { store => \$meta }, - }; - - check( $tmpl, \%hash ) or return; - - my $meth = 'prereqs'; - - { - - ### the prereqs as we have them now - my @args = ( - defaults => $mod->status->$meth || {}, - ); - - my @possibles = do { defined $mod->status->extract - ? ( MYMETA_JSON->( $mod->status->extract ), - MYMETA_YML->( $mod->status->extract ) ) - : () - }; - - unshift @possibles, $meta if $meta; - - META: foreach my $mfile ( grep { -e } @possibles ) { - push @args, ( file => $mfile ); - if ( $mfile =~ /\.json/ ) { - $href = $self->_prereqs_from_meta_json( @args, - keys => [ qw|build test runtime| ] ); - } - else { - $href = $self->_prereqs_from_meta_file( @args, - keys => [ qw|build_requires requires| ] ); - } - last META; - } - - } - - ### 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!!! - - local $ENV{PERL_JSON_BACKEND}; - - 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 }; -} - -sub _prereqs_from_meta_json { - 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_JSON->( $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!!! - - local $ENV{PERL_JSON_BACKEND}; - - my ($doc) = eval { Parse::CPAN::Meta->load_file( $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 }; - #} - my $prereqs = $doc->{prereqs} || {}; - for my $key ( @$keys ) { - $defaults = { - %$defaults, - %{ $prereqs->{$key}->{requires} }, - } if $prereqs->{ $key }->{requires}; - } - } - - ### 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,$tolerant); - 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 }, - tolerant => { default => $conf->get_conf('allow_unknown_prereqs'), - store => \$tolerant }, - }; - - 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; - - my $flag; - - for my $mod ( @sorted_prereqs ) { - ( my $version = $prereqs->{$mod} ) =~ s#[^0-9\._]+##g; - - ### 'perl' is a special case, there's no mod object for it - if( $mod eq PERL_CORE ) { - - unless( $cb->_vcmp( sprintf('v%vd',$^V), $version ) >= 0 ) { - 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 ( defined $core ) { - error( loc( "No such module '%1' found on CPAN", $mod ) ); - $flag++ unless $tolerant; - 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; - } - } - - 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. -- Note that the overall ". - "install may fail due to this.", - $modobj->module, $modobj->package ) ); - next; - } - - ### 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: |