1 package CPANPLUS::Configure;
5 use CPANPLUS::Internals::Constants;
10 use Module::Load qw[load];
11 use Params::Check qw[check];
12 use File::Basename qw[dirname];
13 use Module::Loaded ();
14 use Locale::Maketext::Simple Class => 'CPANPLUS', Style => 'gettext';
16 use vars qw[$AUTOLOAD $VERSION $MIN_CONFIG_VERSION];
17 use base qw[CPANPLUS::Internals::Utils];
19 local $Params::Check::VERBOSE = 1;
21 ### require, avoid circular use ###
22 require CPANPLUS::Internals;
23 $VERSION = $CPANPLUS::Internals::VERSION = $CPANPLUS::Internals::VERSION;
25 ### can't use O::A as we're using our own AUTOLOAD to get to
26 ### the config options.
27 for my $meth ( qw[conf _lib _perl5lib]) {
32 $self->{'_'.$meth} = $_[0] if @_;
33 return $self->{'_'.$meth};
46 $conf = CPANPLUS::Configure->new( );
48 $bool = $conf->can_save;
49 $bool = $conf->save( $where );
51 @opts = $conf->options( $type );
53 $make = $conf->get_program('make');
54 $verbose = $conf->set_conf( verbose => 1 );
58 This module deals with all the configuration issues for CPANPLUS.
59 Users can use objects created by this module to alter the behaviour
62 Please refer to the C<CPANPLUS::Backend> documentation on how to
63 obtain a C<CPANPLUS::Configure> object.
67 =head2 $Configure = CPANPLUS::Configure->new( load_configs => BOOL )
69 This method returns a new object. Normal users will never need to
70 invoke the C<new> method, but instead retrieve the desired object via
71 a method call on a C<CPANPLUS::Backend> object.
75 Controls wether or not additional user configurations are to be loaded
76 or not. Defaults to C<true>.
80 ### store teh CPANPLUS::Config object in a closure, so we only
81 ### initialize it once.. otherwise, on a 2nd ->new, settings
82 ### from configs on top of this one will be reset
89 ### XXX pass on options to ->init() like rescan?
92 load_configs => { default => 1, store => \$load },
95 check( $tmpl, \%hash ) or (
96 warn Params::Check->last_error, return
99 $Config ||= CPANPLUS::Config->new;
100 my $self = bless {}, $class;
101 $self->conf( $Config );
103 ### you want us to load other configs?
104 ### these can override things in the default config
105 $self->init if $load;
107 ### after processing the config files, check what
108 ### @INC and PERL5LIB are set to.
109 $self->_lib( \@INC );
110 $self->_perl5lib( $ENV{'PERL5LIB'} );
116 =head2 $bool = $Configure->init( [rescan => BOOL])
118 Initialize the configure with other config files than just
119 the default 'CPANPLUS::Config'.
121 Called from C<new()> to load user/system configurations
123 If the C<rescan> option is provided, your disk will be
124 examined again to see if there are new config files that
125 could be read. Defaults to C<false>.
127 Returns true on success, false on failure.
131 ### move the Module::Pluggable detection to runtime, rather
132 ### than compile time, so that a simple 'require CPANPLUS'
133 ### doesn't start running over your filesystem for no good
134 ### reason. Make sure we only do the M::P call once though.
135 ### we use $loaded to mark it
140 my $obj = $self->conf;
145 rescan => { default => 0, store => \$rescan },
148 check( $tmpl, \%hash ) or (
149 warn Params::Check->last_error, return
152 ### if the base dir is changed, we have to rescan it
153 ### for any CPANPLUS::Config::* files as well, so keep
155 my $cur_base = $self->get_conf('base');
157 ### warn if we find an old style config specified
158 ### via environment variables
159 { my $env = ENV_CPANPLUS_CONFIG;
160 if( $ENV{$env} and not $warned ) {
162 error(loc("Specifying a config file in your environment " .
163 "using %1 is obsolete.\nPlease follow the ".
164 "directions outlined in %2 or use the '%3' command\n".
165 "in the default shell to use custom config files.",
166 $env, "CPANPLUS::Configure->save", 's save'));
170 { ### make sure that the homedir is included now
171 local @INC = ( LIB_DIR->($cur_base), @INC );
173 ### only set it up once
174 if( !$loaded++ or $rescan ) {
175 ### find plugins & extra configs
176 ### check $home/.cpanplus/lib as well
177 require Module::Pluggable;
179 Module::Pluggable->import(
180 search_path => ['CPANPLUS::Config'],
181 search_dirs => [ LIB_DIR->($cur_base) ],
182 except => qr/::SUPER$/,
183 sub_name => 'configs'
188 ### do system config, user config, rest.. in that order
189 ### apparently, on a 2nd invocation of -->configs, a
190 ### ::ISA::CACHE package can appear.. that's bad...
191 my %confs = map { $_ => $_ }
192 grep { $_ !~ /::ISA::/ } __PACKAGE__->configs;
193 my @confs = grep { defined }
194 map { delete $confs{$_} } CONFIG_SYSTEM, CONFIG_USER;
195 push @confs, sort keys %confs;
197 for my $plugin ( @confs ) {
198 msg(loc("Found config '%1'", $plugin),0);
200 ### if we already did this the /last/ time around dont
201 ### run the setup agian.
202 if( my $loc = Module::Loaded::is_loaded( $plugin ) ) {
203 msg(loc(" Already loaded '%1' (%2)", $plugin, $loc), 0);
206 msg(loc(" Loading config '%1'", $plugin),0);
208 if( eval { load $plugin; 1 } ) {
209 msg(loc(" Loaded '%1' (%2)",
210 $plugin, Module::Loaded::is_loaded( $plugin ) ), 0);
212 error(loc(" Error loading '%1': %2", $plugin, $@));
217 error(loc("Could not load '%1': %2", $plugin, $@));
221 my $sub = $plugin->can('setup');
222 $sub->( $self ) if $sub;
226 ### did one of the plugins change the base dir? then we should
227 ### scan the dirs again
228 if( $cur_base ne $self->get_conf('base') ) {
229 msg(loc("Base dir changed from '%1' to '%2', rescanning",
230 $cur_base, $self->get_conf('base')), 0);
231 $self->init( @_, rescan => 1 );
234 ### clean up the paths once more, just in case
235 $obj->_clean_up_paths;
237 ### XXX in case the 'lib' param got changed, we need to
238 ### add that now, or it's not propagating ;(
239 { my $lib = $self->get_conf('lib');
240 my %inc = map { $_ => $_ } @INC;
241 for my $l ( @$lib ) {
242 push @INC, $l unless $inc{$l};
244 $self->_lib( \@INC );
252 =head2 can_save( [$config_location] )
254 Check if we can save the configuration to the specified file.
255 If no file is provided, defaults to your personal config.
257 Returns true if the file can be saved, false otherwise.
263 my $file = shift || CONFIG_USER_FILE->();
265 return 1 unless -e $file;
273 =head2 $file = $conf->save( [$package_name] )
275 Saves the configuration to the package name you provided.
276 If this package is not C<CPANPLUS::Config::System>, it will
277 be saved in your C<.cpanplus> directory, otherwise it will
278 be attempted to be saved in the system wide directory.
280 If no argument is provided, it will default to your personal
283 Returns the full path to the file if the config was saved,
288 sub _config_pm_to_file {
290 my $pm = shift or return;
291 my $dir = shift || CONFIG_USER_LIB_DIR->();
293 ### only 3 types of files know: home, system and 'other'
294 ### so figure out where to save them based on their type
296 if( $pm eq CONFIG_USER ) {
297 $file = CONFIG_USER_FILE->();
299 } elsif ( $pm eq CONFIG_SYSTEM ) {
300 $file = CONFIG_SYSTEM_FILE->();
304 my $cfg_pkg = CONFIG . '::';
305 unless( $pm =~ /^$cfg_pkg/ ) {
307 "WARNING: Your config package '%1' is not in the '%2' ".
308 "namespace and will not be automatically detected by %3",
309 $pm, $cfg_pkg, 'CPANPLUS'
313 $file = File::Spec->catfile(
325 my $pm = shift || CONFIG_USER;
326 my $savedir = shift || '';
328 my $file = $self->_config_pm_to_file( $pm, $savedir ) or return;
329 my $dir = dirname( $file );
332 $self->_mkdir( dir => $dir ) or (
333 error(loc("Can not create directory '%1' to save config to",$dir)),
337 return unless $self->can_save($file);
339 ### find only accesors that are not private
340 my @acc = sort grep { $_ !~ /^_/ } $self->conf->ls_accessors;
342 ### for dumping the values
346 for my $acc ( @acc ) {
348 push @lines, "### $acc section", $/;
350 for my $key ( $self->conf->$acc->ls_accessors ) {
351 my $val = Dumper( $self->conf->$acc->$key );
353 $val =~ s/\$VAR1\s+=\s+//;
356 push @lines, '$'. "conf->set_${acc}( $key => $val );", $/;
362 my $str = join '', map { " $_" } @lines;
364 ### use a variable to make sure the pod parser doesn't snag it
369 my $msg = <<_END_OF_CONFIG_;
370 ###############################################
372 ### Configuration structure for $pm
374 ###############################################
376 #last changed: $time GMT
378 ### minimal pod, so you can find it with perldoc -l, etc
385 ${is}head1 DESCRIPTION
387 This is a CPANPLUS configuration file. Editing this
388 config changes the way CPANPLUS will behave
408 $self->_move( file => $file, to => "$file~" ) if -f $file;
410 my $fh = new FileHandle;
412 or (error(loc("Could not open '%1' for writing: %2", $file, $!)),
423 =head2 options( type => TYPE )
425 Returns a list of all valid config options given a specific type
426 (like for example C<conf> of C<program>) or false if the type does
433 my $conf = $self->conf;
438 type => { required => 1, default => '',
439 strict_type => 1, store => \$type },
442 check($tmpl, \%hash) or return;
445 return sort grep { !$seen{$_}++ }
446 map { $_->$type->ls_accessors if $_->can($type) }
455 Accessors that start with a C<_> are marked private -- regular users
456 should never need to use these.
458 See the C<CPANPLUS::Config> documentation for what items can be
461 =head2 get_SOMETHING( ITEM, [ITEM, ITEM, ... ] );
463 The C<get_*> style accessors merely retrieves one or more desired
466 =head2 set_SOMETHING( ITEM => VAL, [ITEM => VAL, ITEM => VAL, ... ] );
468 The C<set_*> style accessors set the current value for one
469 or more config options and will return true upon success, false on
472 =head2 add_SOMETHING( ITEM => VAL, [ITEM => VAL, ITEM => VAL, ... ] );
474 The C<add_*> style accessor adds a new key to a config key.
476 Currently, the following accessors exist:
482 Simple configuration directives like verbosity and favourite shell.
484 =item set|get_program
486 Location of helper programs.
488 =item _set|_get_build
490 Locations of where to put what files for CPANPLUS.
492 =item _set|_get_source
494 Locations and names of source files locally.
496 =item _set|_get_mirror
498 Locations and names of source files remotely.
500 =item _set|_get_fetch
502 Special settings pertaining to the fetching of files.
510 my $conf = $self->conf;
512 my $name = $AUTOLOAD;
515 my ($private, $action, $field) =
516 $name =~ m/^(_)?((?:[gs]et|add))_([a-z]+)$/;
519 $type .= '_' if $private;
520 $type .= $field if $field;
522 unless ( $conf->can($type) ) {
523 error( loc("Invalid method type: '%1'", $name) );
527 unless( scalar @_ ) {
528 error( loc("No arguments provided!") );
532 ### retrieve a current value for an existing key ###
533 if( $action eq 'get' ) {
537 ### get it from the user config first
538 if( $conf->can($type) and $conf->$type->can($key) ) {
539 push @list, $conf->$type->$key;
541 ### XXX EU::AI compatibility hack to provide lookups like in
542 ### cpanplus 0.04x; we renamed ->_get_build('base') to
543 ### ->get_conf('base')
544 } elsif ( $type eq '_build' and $key eq 'base' ) {
545 return $self->get_conf($key);
548 error( loc(q[No such key '%1' in field '%2'], $key, $type) );
552 return wantarray ? @list : $list[0];
555 ### set an existing key to a new value ###
556 } elsif ( $action eq 'set' ) {
559 while( my($key,$val) = each %args ) {
561 if( $conf->can($type) and $conf->$type->can($key) ) {
562 $conf->$type->$key( $val );
565 error( loc(q[No such key '%1' in field '%2'], $key, $type) );
572 ### add a new key to the config ###
573 } elsif ( $action eq 'add' ) {
576 while( my($key,$val) = each %args ) {
578 if( $conf->$type->can($key) ) {
579 error( loc( q[Key '%1' already exists for field '%2'],
583 $conf->$type->mk_accessors( $key );
584 $conf->$type->$key( $val );
591 error( loc(q[Unknown action '%1'], $action) );
604 Please report bugs or other issues to E<lt>bug-cpanplus@rt.cpan.org<gt>.
608 This module by Jos Boumans E<lt>kane@cpan.orgE<gt>.
612 The CPAN++ interface (of which this module is a part of) is copyright (c)
613 2001 - 2007, Jos Boumans E<lt>kane@cpan.orgE<gt>. All rights reserved.
615 This library is free software; you may redistribute and/or modify it
616 under the same terms as Perl itself.
620 L<CPANPLUS::Backend>, L<CPANPLUS::Configure::Setup>, L<CPANPLUS::Config>
625 # c-indentation-style: bsd
627 # indent-tabs-mode: nil
629 # vim: expandtab shiftwidth=4: