summaryrefslogtreecommitdiff
path: root/Master/tlpkg/tlperl/lib/CPANPLUS/Configure.pm
diff options
context:
space:
mode:
Diffstat (limited to 'Master/tlpkg/tlperl/lib/CPANPLUS/Configure.pm')
-rw-r--r--Master/tlpkg/tlperl/lib/CPANPLUS/Configure.pm630
1 files changed, 630 insertions, 0 deletions
diff --git a/Master/tlpkg/tlperl/lib/CPANPLUS/Configure.pm b/Master/tlpkg/tlperl/lib/CPANPLUS/Configure.pm
new file mode 100644
index 00000000000..baac91dc886
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/CPANPLUS/Configure.pm
@@ -0,0 +1,630 @@
+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 = $CPANPLUS::Internals::VERSION = $CPANPLUS::Internals::VERSION;
+
+### 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
+
+=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.
+
+=item load_configs
+
+Controls whether or not additional user configurations are to be loaded
+or not. Defaults to C<true>.
+
+=cut
+
+### store teh 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 dont
+ ### run the setup agian.
+ 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 accesors 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;
+ return;
+}
+
+=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;
+
+ unless ( $conf->can($type) ) {
+ error( loc("Invalid method type: '%1'", $name) );
+ return;
+ }
+
+ 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( $conf->can($type) and $conf->$type->can($key) ) {
+ push @list, $conf->$type->$key;
+
+ ### 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( $conf->can($type) and $conf->$type->can($key) ) {
+ $conf->$type->$key( $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( $conf->$type->can($key) ) {
+ error( loc( q[Key '%1' already exists for field '%2'],
+ $key, $type));
+ return;
+ } else {
+ $conf->$type->mk_accessors( $key );
+ $conf->$type->$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:
+