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 See the C<CPANPLUS::Config> documentation for what items can be
427 =head2 get_SOMETHING( ITEM, [ITEM, ITEM, ... ] );
429 The C<get_*> style accessors merely retrieves one or more desired
432 =head2 set_SOMETHING( ITEM => VAL, [ITEM => VAL, ITEM => VAL, ... ] );
434 The C<set_*> style accessors set the current value for one
435 or more config options and will return true upon success, false on
438 =head2 add_SOMETHING( ITEM => VAL, [ITEM => VAL, ITEM => VAL, ... ] );
440 The C<add_*> style accessor adds a new key to a config key.
442 Currently, the following accessors exist:
448 Simple configuration directives like verbosity and favourite shell.
450 =item set|get_program
452 Location of helper programs.
454 =item _set|_get_build
456 Locations of where to put what files for CPANPLUS.
458 =item _set|_get_source
460 Locations and names of source files locally.
462 =item _set|_get_mirror
464 Locations and names of source files remotely.
466 =item _set|_get_fetch
468 Special settings pertaining to the fetching of files.
476 my $conf = $self->conf;
478 my $name = $AUTOLOAD;
481 my ($private, $action, $field) =
482 $name =~ m/^(_)?((?:[gs]et|add))_([a-z]+)$/;
485 $type .= '_' if $private;
486 $type .= $field if $field;
488 unless ( $conf->can($type) ) {
489 error( loc("Invalid method type: '%1'", $name) );
493 unless( scalar @_ ) {
494 error( loc("No arguments provided!") );
498 ### retrieve a current value for an existing key ###
499 if( $action eq 'get' ) {
503 ### get it from the user config first
504 if( $conf->can($type) and $conf->$type->can($key) ) {
505 push @list, $conf->$type->$key;
507 ### XXX EU::AI compatibility hack to provide lookups like in
508 ### cpanplus 0.04x; we renamed ->_get_build('base') to
509 ### ->get_conf('base')
510 } elsif ( $type eq '_build' and $key eq 'base' ) {
511 return $self->get_conf($key);
514 error( loc(q[No such key '%1' in field '%2'], $key, $type) );
518 return wantarray ? @list : $list[0];
521 ### set an existing key to a new value ###
522 } elsif ( $action eq 'set' ) {
525 while( my($key,$val) = each %args ) {
527 if( $conf->can($type) and $conf->$type->can($key) ) {
528 $conf->$type->$key( $val );
531 error( loc(q[No such key '%1' in field '%2'], $key, $type) );
538 ### add a new key to the config ###
539 } elsif ( $action eq 'add' ) {
542 while( my($key,$val) = each %args ) {
544 if( $conf->$type->can($key) ) {
545 error( loc( q[Key '%1' already exists for field '%2'],
549 $conf->$type->mk_accessors( $key );
550 $conf->$type->$key( $val );
557 error( loc(q[Unknown action '%1'], $action) );
570 Please report bugs or other issues to E<lt>bug-cpanplus@rt.cpan.org<gt>.
574 This module by Jos Boumans E<lt>kane@cpan.orgE<gt>.
578 The CPAN++ interface (of which this module is a part of) is copyright (c)
579 2001 - 2007, Jos Boumans E<lt>kane@cpan.orgE<gt>. All rights reserved.
581 This library is free software; you may redistribute and/or modify it
582 under the same terms as Perl itself.
586 L<CPANPLUS::Backend>, L<CPANPLUS::Configure::Setup>, L<CPANPLUS::Config>
591 # c-indentation-style: bsd
593 # indent-tabs-mode: nil
595 # vim: expandtab shiftwidth=4: