Initial Commit
This commit is contained in:
Riley Schneider
635
database/perl/vendor/lib/CPANPLUS/Configure.pm
vendored
Normal file
635
database/perl/vendor/lib/CPANPLUS/Configure.pm
vendored
Normal file
@@ -0,0 +1,635 @@
|
||||
package CPANPLUS::Configure;
|
||||
use strict;
|
||||
|
||||
|
||||
use CPANPLUS::Internals::Constants;
|
||||
use CPANPLUS::Error;
|
||||
use CPANPLUS::Config;
|
||||
|
||||
use Log::Message;
|
||||
use Module::Load qw[load];
|
||||
use Params::Check qw[check];
|
||||
use File::Basename qw[dirname];
|
||||
use Module::Loaded ();
|
||||
use Locale::Maketext::Simple Class => 'CPANPLUS', Style => 'gettext';
|
||||
|
||||
use vars qw[$AUTOLOAD $VERSION $MIN_CONFIG_VERSION];
|
||||
use base qw[CPANPLUS::Internals::Utils];
|
||||
|
||||
local $Params::Check::VERBOSE = 1;
|
||||
|
||||
### require, avoid circular use ###
|
||||
require CPANPLUS::Internals;
|
||||
$VERSION = "0.9910";
|
||||
|
||||
### can't use O::A as we're using our own AUTOLOAD to get to
|
||||
### the config options.
|
||||
for my $meth ( qw[conf _lib _perl5lib]) {
|
||||
no strict 'refs';
|
||||
|
||||
*$meth = sub {
|
||||
my $self = shift;
|
||||
$self->{'_'.$meth} = $_[0] if @_;
|
||||
return $self->{'_'.$meth};
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
=pod
|
||||
|
||||
=head1 NAME
|
||||
|
||||
CPANPLUS::Configure - configuration for CPANPLUS
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
$conf = CPANPLUS::Configure->new( );
|
||||
|
||||
$bool = $conf->can_save;
|
||||
$bool = $conf->save( $where );
|
||||
|
||||
@opts = $conf->options( $type );
|
||||
|
||||
$make = $conf->get_program('make');
|
||||
$verbose = $conf->set_conf( verbose => 1 );
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This module deals with all the configuration issues for CPANPLUS.
|
||||
Users can use objects created by this module to alter the behaviour
|
||||
of CPANPLUS.
|
||||
|
||||
Please refer to the C<CPANPLUS::Backend> documentation on how to
|
||||
obtain a C<CPANPLUS::Configure> object.
|
||||
|
||||
=head1 METHODS
|
||||
|
||||
=head2 $Configure = CPANPLUS::Configure->new( load_configs => BOOL )
|
||||
|
||||
This method returns a new object. Normal users will never need to
|
||||
invoke the C<new> method, but instead retrieve the desired object via
|
||||
a method call on a C<CPANPLUS::Backend> object.
|
||||
|
||||
=over 4
|
||||
|
||||
=item load_configs
|
||||
|
||||
Controls whether or not additional user configurations are to be loaded
|
||||
or not. Defaults to C<true>.
|
||||
|
||||
=back
|
||||
|
||||
=cut
|
||||
|
||||
### store the CPANPLUS::Config object in a closure, so we only
|
||||
### initialize it once.. otherwise, on a 2nd ->new, settings
|
||||
### from configs on top of this one will be reset
|
||||
{ my $Config;
|
||||
|
||||
sub new {
|
||||
my $class = shift;
|
||||
my %hash = @_;
|
||||
|
||||
### XXX pass on options to ->init() like rescan?
|
||||
my ($load);
|
||||
my $tmpl = {
|
||||
load_configs => { default => 1, store => \$load },
|
||||
};
|
||||
|
||||
check( $tmpl, \%hash ) or (
|
||||
warn(Params::Check->last_error), return
|
||||
);
|
||||
|
||||
$Config ||= CPANPLUS::Config->new;
|
||||
my $self = bless {}, $class;
|
||||
$self->conf( $Config );
|
||||
|
||||
### you want us to load other configs?
|
||||
### these can override things in the default config
|
||||
$self->init if $load;
|
||||
|
||||
### after processing the config files, check what
|
||||
### @INC and PERL5LIB are set to.
|
||||
$self->_lib( \@INC );
|
||||
$self->_perl5lib( $ENV{'PERL5LIB'} );
|
||||
|
||||
return $self;
|
||||
}
|
||||
}
|
||||
|
||||
=head2 $bool = $Configure->init( [rescan => BOOL])
|
||||
|
||||
Initialize the configure with other config files than just
|
||||
the default 'CPANPLUS::Config'.
|
||||
|
||||
Called from C<new()> to load user/system configurations
|
||||
|
||||
If the C<rescan> option is provided, your disk will be
|
||||
examined again to see if there are new config files that
|
||||
could be read. Defaults to C<false>.
|
||||
|
||||
Returns true on success, false on failure.
|
||||
|
||||
=cut
|
||||
|
||||
### move the Module::Pluggable detection to runtime, rather
|
||||
### than compile time, so that a simple 'require CPANPLUS'
|
||||
### doesn't start running over your filesystem for no good
|
||||
### reason. Make sure we only do the M::P call once though.
|
||||
### we use $loaded to mark it
|
||||
{ my $loaded;
|
||||
my $warned;
|
||||
sub init {
|
||||
my $self = shift;
|
||||
my $obj = $self->conf;
|
||||
my %hash = @_;
|
||||
|
||||
my ($rescan);
|
||||
my $tmpl = {
|
||||
rescan => { default => 0, store => \$rescan },
|
||||
};
|
||||
|
||||
check( $tmpl, \%hash ) or (
|
||||
warn(Params::Check->last_error), return
|
||||
);
|
||||
|
||||
### if the base dir is changed, we have to rescan it
|
||||
### for any CPANPLUS::Config::* files as well, so keep
|
||||
### track of it
|
||||
my $cur_base = $self->get_conf('base');
|
||||
|
||||
### warn if we find an old style config specified
|
||||
### via environment variables
|
||||
{ my $env = ENV_CPANPLUS_CONFIG;
|
||||
if( $ENV{$env} and not $warned ) {
|
||||
$warned++;
|
||||
error(loc("Specifying a config file in your environment " .
|
||||
"using %1 is obsolete.\nPlease follow the ".
|
||||
"directions outlined in %2 or use the '%3' command\n".
|
||||
"in the default shell to use custom config files.",
|
||||
$env, "CPANPLUS::Configure->save", 's save'));
|
||||
}
|
||||
}
|
||||
|
||||
{ ### make sure that the homedir is included now
|
||||
local @INC = ( LIB_DIR->($cur_base), @INC );
|
||||
|
||||
### only set it up once
|
||||
if( !$loaded++ or $rescan ) {
|
||||
### find plugins & extra configs
|
||||
### check $home/.cpanplus/lib as well
|
||||
require Module::Pluggable;
|
||||
|
||||
Module::Pluggable->import(
|
||||
search_path => ['CPANPLUS::Config'],
|
||||
search_dirs => [ LIB_DIR->($cur_base) ],
|
||||
except => qr/::SUPER$/,
|
||||
sub_name => 'configs'
|
||||
);
|
||||
}
|
||||
|
||||
|
||||
### do system config, user config, rest.. in that order
|
||||
### apparently, on a 2nd invocation of -->configs, a
|
||||
### ::ISA::CACHE package can appear.. that's bad...
|
||||
my %confs = map { $_ => $_ }
|
||||
grep { $_ !~ /::ISA::/ } __PACKAGE__->configs;
|
||||
my @confs = grep { defined }
|
||||
map { delete $confs{$_} } CONFIG_SYSTEM, CONFIG_USER;
|
||||
push @confs, sort keys %confs;
|
||||
|
||||
for my $plugin ( @confs ) {
|
||||
msg(loc("Found config '%1'", $plugin),0);
|
||||
|
||||
### if we already did this the /last/ time around don't
|
||||
### run the setup again.
|
||||
if( my $loc = Module::Loaded::is_loaded( $plugin ) ) {
|
||||
msg(loc(" Already loaded '%1' (%2)", $plugin, $loc), 0);
|
||||
next;
|
||||
} else {
|
||||
msg(loc(" Loading config '%1'", $plugin),0);
|
||||
|
||||
if( eval { load $plugin; 1 } ) {
|
||||
msg(loc(" Loaded '%1' (%2)",
|
||||
$plugin, Module::Loaded::is_loaded( $plugin ) ), 0);
|
||||
} else {
|
||||
error(loc(" Error loading '%1': %2", $plugin, $@));
|
||||
}
|
||||
}
|
||||
|
||||
if( $@ ) {
|
||||
error(loc("Could not load '%1': %2", $plugin, $@));
|
||||
next;
|
||||
}
|
||||
|
||||
my $sub = $plugin->can('setup');
|
||||
$sub->( $self ) if $sub;
|
||||
}
|
||||
}
|
||||
|
||||
### did one of the plugins change the base dir? then we should
|
||||
### scan the dirs again
|
||||
if( $cur_base ne $self->get_conf('base') ) {
|
||||
msg(loc("Base dir changed from '%1' to '%2', rescanning",
|
||||
$cur_base, $self->get_conf('base')), 0);
|
||||
$self->init( @_, rescan => 1 );
|
||||
}
|
||||
|
||||
### clean up the paths once more, just in case
|
||||
$obj->_clean_up_paths;
|
||||
|
||||
### XXX in case the 'lib' param got changed, we need to
|
||||
### add that now, or it's not propagating ;(
|
||||
{ my $lib = $self->get_conf('lib');
|
||||
my %inc = map { $_ => $_ } @INC;
|
||||
for my $l ( @$lib ) {
|
||||
push @INC, $l unless $inc{$l};
|
||||
}
|
||||
$self->_lib( \@INC );
|
||||
}
|
||||
|
||||
return 1;
|
||||
}
|
||||
}
|
||||
=pod
|
||||
|
||||
=head2 can_save( [$config_location] )
|
||||
|
||||
Check if we can save the configuration to the specified file.
|
||||
If no file is provided, defaults to your personal config.
|
||||
|
||||
Returns true if the file can be saved, false otherwise.
|
||||
|
||||
=cut
|
||||
|
||||
sub can_save {
|
||||
my $self = shift;
|
||||
my $file = shift || CONFIG_USER_FILE->();
|
||||
|
||||
return 1 unless -e $file;
|
||||
|
||||
chmod 0644, $file;
|
||||
return (-w $file);
|
||||
}
|
||||
|
||||
=pod
|
||||
|
||||
=head2 $file = $conf->save( [$package_name] )
|
||||
|
||||
Saves the configuration to the package name you provided.
|
||||
If this package is not C<CPANPLUS::Config::System>, it will
|
||||
be saved in your C<.cpanplus> directory, otherwise it will
|
||||
be attempted to be saved in the system wide directory.
|
||||
|
||||
If no argument is provided, it will default to your personal
|
||||
config.
|
||||
|
||||
Returns the full path to the file if the config was saved,
|
||||
false otherwise.
|
||||
|
||||
=cut
|
||||
|
||||
sub _config_pm_to_file {
|
||||
my $self = shift;
|
||||
my $pm = shift or return;
|
||||
my $dir = shift || CONFIG_USER_LIB_DIR->();
|
||||
|
||||
### only 3 types of files know: home, system and 'other'
|
||||
### so figure out where to save them based on their type
|
||||
my $file;
|
||||
if( $pm eq CONFIG_USER ) {
|
||||
$file = CONFIG_USER_FILE->();
|
||||
|
||||
} elsif ( $pm eq CONFIG_SYSTEM ) {
|
||||
$file = CONFIG_SYSTEM_FILE->();
|
||||
|
||||
### third party file
|
||||
} else {
|
||||
my $cfg_pkg = CONFIG . '::';
|
||||
unless( $pm =~ /^$cfg_pkg/ ) {
|
||||
error(loc(
|
||||
"WARNING: Your config package '%1' is not in the '%2' ".
|
||||
"namespace and will not be automatically detected by %3",
|
||||
$pm, $cfg_pkg, 'CPANPLUS'
|
||||
));
|
||||
}
|
||||
|
||||
$file = File::Spec->catfile(
|
||||
$dir,
|
||||
split( '::', $pm )
|
||||
) . '.pm';
|
||||
}
|
||||
|
||||
return $file;
|
||||
}
|
||||
|
||||
|
||||
sub save {
|
||||
my $self = shift;
|
||||
my $pm = shift || CONFIG_USER;
|
||||
my $savedir = shift || '';
|
||||
|
||||
my $file = $self->_config_pm_to_file( $pm, $savedir ) or return;
|
||||
my $dir = dirname( $file );
|
||||
|
||||
unless( -d $dir ) {
|
||||
$self->_mkdir( dir => $dir ) or (
|
||||
error(loc("Can not create directory '%1' to save config to",$dir)),
|
||||
return
|
||||
)
|
||||
}
|
||||
return unless $self->can_save($file);
|
||||
|
||||
### find only accessors that are not private
|
||||
my @acc = sort grep { $_ !~ /^_/ } $self->conf->ls_accessors;
|
||||
|
||||
### for dumping the values
|
||||
use Data::Dumper;
|
||||
|
||||
my @lines;
|
||||
for my $acc ( @acc ) {
|
||||
|
||||
push @lines, "### $acc section", $/;
|
||||
|
||||
for my $key ( $self->conf->$acc->ls_accessors ) {
|
||||
my $val = Dumper( $self->conf->$acc->$key );
|
||||
|
||||
$val =~ s/\$VAR1\s+=\s+//;
|
||||
$val =~ s/;\n//;
|
||||
|
||||
push @lines, '$'. "conf->set_${acc}( $key => $val );", $/;
|
||||
}
|
||||
push @lines, $/,$/;
|
||||
|
||||
}
|
||||
|
||||
my $str = join '', map { " $_" } @lines;
|
||||
|
||||
### use a variable to make sure the pod parser doesn't snag it
|
||||
my $is = '=';
|
||||
my $time = gmtime;
|
||||
|
||||
|
||||
my $msg = <<_END_OF_CONFIG_;
|
||||
###############################################
|
||||
###
|
||||
### Configuration structure for $pm
|
||||
###
|
||||
###############################################
|
||||
|
||||
#last changed: $time GMT
|
||||
|
||||
### minimal pod, so you can find it with perldoc -l, etc
|
||||
${is}pod
|
||||
|
||||
${is}head1 NAME
|
||||
|
||||
$pm
|
||||
|
||||
${is}head1 DESCRIPTION
|
||||
|
||||
This is a CPANPLUS configuration file. Editing this
|
||||
config changes the way CPANPLUS will behave
|
||||
|
||||
${is}cut
|
||||
|
||||
package $pm;
|
||||
|
||||
use strict;
|
||||
|
||||
sub setup {
|
||||
my \$conf = shift;
|
||||
|
||||
$str
|
||||
|
||||
return 1;
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
_END_OF_CONFIG_
|
||||
|
||||
$self->_move( file => $file, to => "$file~" ) if -f $file;
|
||||
|
||||
my $fh = new FileHandle;
|
||||
$fh->open(">$file")
|
||||
or (error(loc("Could not open '%1' for writing: %2", $file, $!)),
|
||||
return );
|
||||
|
||||
$fh->print($msg);
|
||||
$fh->close;
|
||||
|
||||
return $file;
|
||||
}
|
||||
|
||||
=pod
|
||||
|
||||
=head2 options( type => TYPE )
|
||||
|
||||
Returns a list of all valid config options given a specific type
|
||||
(like for example C<conf> of C<program>) or false if the type does
|
||||
not exist
|
||||
|
||||
=cut
|
||||
|
||||
sub options {
|
||||
my $self = shift;
|
||||
my $conf = $self->conf;
|
||||
my %hash = @_;
|
||||
|
||||
my $type;
|
||||
my $tmpl = {
|
||||
type => { required => 1, default => '',
|
||||
strict_type => 1, store => \$type },
|
||||
};
|
||||
|
||||
check($tmpl, \%hash) or return;
|
||||
|
||||
my %seen;
|
||||
return sort grep { !$seen{$_}++ }
|
||||
map { $_->$type->ls_accessors if $_->can($type) }
|
||||
$self->conf;
|
||||
}
|
||||
|
||||
=pod
|
||||
|
||||
=head1 ACCESSORS
|
||||
|
||||
Accessors that start with a C<_> are marked private -- regular users
|
||||
should never need to use these.
|
||||
|
||||
See the C<CPANPLUS::Config> documentation for what items can be
|
||||
set and retrieved.
|
||||
|
||||
=head2 get_SOMETHING( ITEM, [ITEM, ITEM, ... ] );
|
||||
|
||||
The C<get_*> style accessors merely retrieves one or more desired
|
||||
config options.
|
||||
|
||||
=head2 set_SOMETHING( ITEM => VAL, [ITEM => VAL, ITEM => VAL, ... ] );
|
||||
|
||||
The C<set_*> style accessors set the current value for one
|
||||
or more config options and will return true upon success, false on
|
||||
failure.
|
||||
|
||||
=head2 add_SOMETHING( ITEM => VAL, [ITEM => VAL, ITEM => VAL, ... ] );
|
||||
|
||||
The C<add_*> style accessor adds a new key to a config key.
|
||||
|
||||
Currently, the following accessors exist:
|
||||
|
||||
=over 4
|
||||
|
||||
=item set|get_conf
|
||||
|
||||
Simple configuration directives like verbosity and favourite shell.
|
||||
|
||||
=item set|get_program
|
||||
|
||||
Location of helper programs.
|
||||
|
||||
=item _set|_get_build
|
||||
|
||||
Locations of where to put what files for CPANPLUS.
|
||||
|
||||
=item _set|_get_source
|
||||
|
||||
Locations and names of source files locally.
|
||||
|
||||
=item _set|_get_mirror
|
||||
|
||||
Locations and names of source files remotely.
|
||||
|
||||
=item _set|_get_fetch
|
||||
|
||||
Special settings pertaining to the fetching of files.
|
||||
|
||||
=back
|
||||
|
||||
=cut
|
||||
|
||||
sub AUTOLOAD {
|
||||
my $self = shift;
|
||||
my $conf = $self->conf;
|
||||
|
||||
my $name = $AUTOLOAD;
|
||||
$name =~ s/.+:://;
|
||||
|
||||
my ($private, $action, $field) =
|
||||
$name =~ m/^(_)?((?:[gs]et|add))_([a-z]+)$/;
|
||||
|
||||
my $type = '';
|
||||
$type .= '_' if $private;
|
||||
$type .= $field if $field;
|
||||
|
||||
my $type_code = $conf->can($type);
|
||||
unless ( $type_code ) {
|
||||
error( loc("Invalid method type: '%1'", $name) );
|
||||
return;
|
||||
}
|
||||
my $type_obj = $type_code->();
|
||||
|
||||
unless( scalar @_ ) {
|
||||
error( loc("No arguments provided!") );
|
||||
return;
|
||||
}
|
||||
|
||||
### retrieve a current value for an existing key ###
|
||||
if( $action eq 'get' ) {
|
||||
for my $key (@_) {
|
||||
my @list = ();
|
||||
|
||||
### get it from the user config first
|
||||
if( my $code = $type_obj->can($key) ) {
|
||||
push @list, $code->();
|
||||
|
||||
### XXX EU::AI compatibility hack to provide lookups like in
|
||||
### cpanplus 0.04x; we renamed ->_get_build('base') to
|
||||
### ->get_conf('base')
|
||||
} elsif ( $type eq '_build' and $key eq 'base' ) {
|
||||
return $self->get_conf($key);
|
||||
|
||||
} else {
|
||||
error( loc(q[No such key '%1' in field '%2'], $key, $type) );
|
||||
return;
|
||||
}
|
||||
|
||||
return wantarray ? @list : $list[0];
|
||||
}
|
||||
|
||||
### set an existing key to a new value ###
|
||||
} elsif ( $action eq 'set' ) {
|
||||
my %args = @_;
|
||||
|
||||
while( my($key,$val) = each %args ) {
|
||||
|
||||
if( my $code = $type_obj->can($key) ) {
|
||||
$code->( $val );
|
||||
|
||||
} else {
|
||||
error( loc(q[No such key '%1' in field '%2'], $key, $type) );
|
||||
return;
|
||||
}
|
||||
}
|
||||
|
||||
return 1;
|
||||
|
||||
### add a new key to the config ###
|
||||
} elsif ( $action eq 'add' ) {
|
||||
my %args = @_;
|
||||
|
||||
while( my($key,$val) = each %args ) {
|
||||
|
||||
if( $type_obj->can($key) ) {
|
||||
error( loc( q[Key '%1' already exists for field '%2'],
|
||||
$key, $type));
|
||||
return;
|
||||
} else {
|
||||
$type_obj->mk_accessors( $key );
|
||||
$type_obj->$key( $val );
|
||||
}
|
||||
}
|
||||
return 1;
|
||||
|
||||
} else {
|
||||
|
||||
error( loc(q[Unknown action '%1'], $action) );
|
||||
return;
|
||||
}
|
||||
}
|
||||
|
||||
sub DESTROY { 1 };
|
||||
|
||||
1;
|
||||
|
||||
=pod
|
||||
|
||||
=head1 BUG REPORTS
|
||||
|
||||
Please report bugs or other issues to E<lt>bug-cpanplus@rt.cpan.org<gt>.
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
This module by Jos Boumans E<lt>kane@cpan.orgE<gt>.
|
||||
|
||||
=head1 COPYRIGHT
|
||||
|
||||
The CPAN++ interface (of which this module is a part of) is copyright (c)
|
||||
2001 - 2007, Jos Boumans E<lt>kane@cpan.orgE<gt>. All rights reserved.
|
||||
|
||||
This library is free software; you may redistribute and/or modify it
|
||||
under the same terms as Perl itself.
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<CPANPLUS::Backend>, L<CPANPLUS::Configure::Setup>, L<CPANPLUS::Config>
|
||||
|
||||
=cut
|
||||
|
||||
# Local variables:
|
||||
# c-indentation-style: bsd
|
||||
# c-basic-offset: 4
|
||||
# indent-tabs-mode: nil
|
||||
# End:
|
||||
# vim: expandtab shiftwidth=4:
|
||||
|
||||
Reference in New Issue
Block a user