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]) {
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.
73 The C<load_configs> parameter controls wether or not additional
74 user configurations are to be loaded or not. Defaults to C<true>.
78 ### store teh CPANPLUS::Config object in a closure, so we only
79 ### initialize it once.. otherwise, on a 2nd ->new, settings
80 ### from configs on top of this one will be reset
87 ### XXX pass on options to ->init() like rescan?
90 load_configs => { default => 1, store => \$load },
93 check( $tmpl, \%hash ) or (
94 warn Params::Check->last_error, return
97 $Config ||= CPANPLUS::Config->new;
98 my $self = bless {}, $class;
99 $self->conf( $Config );
101 ### you want us to load other configs?
102 ### these can override things in the default config
103 $self->init if $load;
109 =head2 $bool = $Configure->init( [rescan => BOOL])
111 Initialize the configure with other config files than just
112 the default 'CPANPLUS::Config'.
114 Called from C<new()> to load user/system configurations
116 If the C<rescan> option is provided, your disk will be
117 examined again to see if there are new config files that
118 could be read. Defaults to C<false>.
120 Returns true on success, false on failure.
124 ### move the Module::Pluggable detection to runtime, rather
125 ### than compile time, so that a simple 'require CPANPLUS'
126 ### doesn't start running over your filesystem for no good
127 ### reason. Make sure we only do the M::P call once though.
128 ### we use $loaded to mark it
133 my $obj = $self->conf;
138 rescan => { default => 0, store => \$rescan },
141 check( $tmpl, \%hash ) or (
142 warn Params::Check->last_error, return
145 ### warn if we find an old style config specified
146 ### via environment variables
147 { my $env = ENV_CPANPLUS_CONFIG;
148 if( $ENV{$env} and not $warned ) {
150 error(loc("Specifying a config file in your environment " .
151 "using %1 is obsolete.\nPlease follow the ".
152 "directions outlined in %2 or use the '%3' command\n".
153 "in the default shell to use custom config files.",
154 $env, "CPANPLUS::Configure->save", 's save'));
158 ### make sure that the homedir is included now
159 local @INC = ( CONFIG_USER_LIB_DIR->(), @INC );
161 ### only set it up once
162 if( !$loaded++ or $rescan ) {
163 ### find plugins & extra configs
164 ### check $home/.cpanplus/lib as well
165 require Module::Pluggable;
167 Module::Pluggable->import(
168 search_path => ['CPANPLUS::Config'],
169 search_dirs => [ CONFIG_USER_LIB_DIR ],
170 except => qr/::SUPER$/,
171 sub_name => 'configs'
176 ### do system config, user config, rest.. in that order
177 ### apparently, on a 2nd invocation of -->configs, a
178 ### ::ISA::CACHE package can appear.. that's bad...
179 my %confs = map { $_ => $_ }
180 grep { $_ !~ /::ISA::/ } __PACKAGE__->configs;
181 my @confs = grep { defined }
182 map { delete $confs{$_} } CONFIG_SYSTEM, CONFIG_USER;
183 push @confs, sort keys %confs;
185 for my $plugin ( @confs ) {
186 msg(loc("Found config '%1'", $plugin),0);
188 ### if we already did this the /last/ time around dont
189 ### run the setup agian.
190 if( my $loc = Module::Loaded::is_loaded( $plugin ) ) {
191 msg(loc(" Already loaded '%1' (%2)", $plugin, $loc), 0);
194 msg(loc(" Loading config '%1'", $plugin),0);
196 eval { load $plugin };
197 msg(loc(" Loaded '%1' (%2)",
198 $plugin, Module::Loaded::is_loaded( $plugin ) ), 0);
202 error(loc("Could not load '%1': %2", $plugin, $@));
206 my $sub = $plugin->can('setup');
207 $sub->( $self ) if $sub;
210 ### clean up the paths once more, just in case
211 $obj->_clean_up_paths;
218 =head2 can_save( [$config_location] )
220 Check if we can save the configuration to the specified file.
221 If no file is provided, defaults to your personal config.
223 Returns true if the file can be saved, false otherwise.
229 my $file = shift || CONFIG_USER_FILE->();
231 return 1 unless -e $file;
239 =head2 $file = $conf->save( [$package_name] )
241 Saves the configuration to the package name you provided.
242 If this package is not C<CPANPLUS::Config::System>, it will
243 be saved in your C<.cpanplus> directory, otherwise it will
244 be attempted to be saved in the system wide directory.
246 If no argument is provided, it will default to your personal
249 Returns the full path to the file if the config was saved,
254 sub _config_pm_to_file {
256 my $pm = shift or return;
257 my $dir = shift || CONFIG_USER_LIB_DIR->();
259 ### only 3 types of files know: home, system and 'other'
260 ### so figure out where to save them based on their type
262 if( $pm eq CONFIG_USER ) {
263 $file = CONFIG_USER_FILE->();
265 } elsif ( $pm eq CONFIG_SYSTEM ) {
266 $file = CONFIG_SYSTEM_FILE->();
270 my $cfg_pkg = CONFIG . '::';
271 unless( $pm =~ /^$cfg_pkg/ ) {
273 "WARNING: Your config package '%1' is not in the '%2' ".
274 "namespace and will not be automatically detected by %3",
275 $pm, $cfg_pkg, 'CPANPLUS'
279 $file = File::Spec->catfile(
291 my $pm = shift || CONFIG_USER;
292 my $savedir = shift || '';
294 my $file = $self->_config_pm_to_file( $pm, $savedir ) or return;
295 my $dir = dirname( $file );
298 $self->_mkdir( dir => $dir ) or (
299 error(loc("Can not create directory '%1' to save config to",$dir)),
303 return unless $self->can_save($file);
305 ### find only accesors that are not private
306 my @acc = sort grep { $_ !~ /^_/ } $self->conf->ls_accessors;
308 ### for dumping the values
312 for my $acc ( @acc ) {
314 push @lines, "### $acc section", $/;
316 for my $key ( $self->conf->$acc->ls_accessors ) {
317 my $val = Dumper( $self->conf->$acc->$key );
319 $val =~ s/\$VAR1\s+=\s+//;
322 push @lines, '$'. "conf->set_${acc}( $key => $val );", $/;
328 my $str = join '', map { " $_" } @lines;
330 ### use a variable to make sure the pod parser doesn't snag it
335 my $msg = <<_END_OF_CONFIG_;
336 ###############################################
338 ### Configuration structure for $pm
340 ###############################################
342 #last changed: $time GMT
344 ### minimal pod, so you can find it with perldoc -l, etc
351 ${is}head1 DESCRIPTION
353 This is a CPANPLUS configuration file. Editing this
354 config changes the way CPANPLUS will behave
374 $self->_move( file => $file, to => "$file~" ) if -f $file;
376 my $fh = new FileHandle;
378 or (error(loc("Could not open '%1' for writing: %2", $file, $!)),
389 =head2 options( type => TYPE )
391 Returns a list of all valid config options given a specific type
392 (like for example C<conf> of C<program>) or false if the type does
399 my $conf = $self->conf;
404 type => { required => 1, default => '',
405 strict_type => 1, store => \$type },
408 check($tmpl, \%hash) or return;
411 return sort grep { !$seen{$_}++ }
412 map { $_->$type->ls_accessors if $_->can($type) }
421 Accessors that start with a C<_> are marked private -- regular users
422 should never need to use these.
424 =head2 get_SOMETHING( ITEM, [ITEM, ITEM, ... ] );
426 The C<get_*> style accessors merely retrieves one or more desired
429 =head2 set_SOMETHING( ITEM => VAL, [ITEM => VAL, ITEM => VAL, ... ] );
431 The C<set_*> style accessors set the current value for one
432 or more config options and will return true upon success, false on
435 =head2 add_SOMETHING( ITEM => VAL, [ITEM => VAL, ITEM => VAL, ... ] );
437 The C<add_*> style accessor adds a new key to a config key.
439 Currently, the following accessors exist:
445 Simple configuration directives like verbosity and favourite shell.
447 =item set|get_program
449 Location of helper programs.
451 =item _set|_get_build
453 Locations of where to put what files for CPANPLUS.
455 =item _set|_get_source
457 Locations and names of source files locally.
459 =item _set|_get_mirror
461 Locations and names of source files remotely.
465 Mapping of distribution format names to modules.
467 =item _set|_get_fetch
469 Special settings pertaining to the fetching of files.
471 =item _set|_get_daemon
473 Settings for C<cpanpd>, the CPANPLUS daemon.
481 my $conf = $self->conf;
483 my $name = $AUTOLOAD;
486 my ($private, $action, $field) =
487 $name =~ m/^(_)?((?:[gs]et|add))_([a-z]+)$/;
490 $type .= '_' if $private;
491 $type .= $field if $field;
493 unless ( $conf->can($type) ) {
494 error( loc("Invalid method type: '%1'", $name) );
498 unless( scalar @_ ) {
499 error( loc("No arguments provided!") );
503 ### retrieve a current value for an existing key ###
504 if( $action eq 'get' ) {
508 ### get it from the user config first
509 if( $conf->can($type) and $conf->$type->can($key) ) {
510 push @list, $conf->$type->$key;
512 ### XXX EU::AI compatibility hack to provide lookups like in
513 ### cpanplus 0.04x; we renamed ->_get_build('base') to
514 ### ->get_conf('base')
515 } elsif ( $type eq '_build' and $key eq 'base' ) {
516 return $self->get_conf($key);
519 error( loc(q[No such key '%1' in field '%2'], $key, $type) );
523 return wantarray ? @list : $list[0];
526 ### set an existing key to a new value ###
527 } elsif ( $action eq 'set' ) {
530 while( my($key,$val) = each %args ) {
532 if( $conf->can($type) and $conf->$type->can($key) ) {
533 $conf->$type->$key( $val );
536 error( loc(q[No such key '%1' in field '%2'], $key, $type) );
543 ### add a new key to the config ###
544 } elsif ( $action eq 'add' ) {
547 while( my($key,$val) = each %args ) {
549 if( $conf->$type->can($key) ) {
550 error( loc( q[Key '%1' already exists for field '%2'],
554 $conf->$type->mk_accessors( $key );
555 $conf->$type->$key( $val );
562 error( loc(q[Unknown action '%1'], $action) );
575 Please report bugs or other issues to E<lt>bug-cpanplus@rt.cpan.org<gt>.
579 This module by Jos Boumans E<lt>kane@cpan.orgE<gt>.
583 The CPAN++ interface (of which this module is a part of) is copyright (c)
584 2001 - 2007, Jos Boumans E<lt>kane@cpan.orgE<gt>. All rights reserved.
586 This library is free software; you may redistribute and/or modify it
587 under the same terms as Perl itself.
591 L<CPANPLUS::Backend>, L<CPANPLUS::Configure::Setup>
596 # c-indentation-style: bsd
598 # indent-tabs-mode: nil
600 # vim: expandtab shiftwidth=4: