Commit | Line | Data |
6aaee015 |
1 | package CPANPLUS::Configure; |
2 | use strict; |
3 | |
4 | |
5 | use CPANPLUS::Internals::Constants; |
6 | use CPANPLUS::Error; |
7 | use CPANPLUS::Config; |
8 | |
9 | use Log::Message; |
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'; |
15 | |
16 | use vars qw[$AUTOLOAD $VERSION $MIN_CONFIG_VERSION]; |
17 | use base qw[CPANPLUS::Internals::Utils]; |
18 | |
19 | local $Params::Check::VERBOSE = 1; |
20 | |
21 | ### require, avoid circular use ### |
22 | require CPANPLUS::Internals; |
23 | $VERSION = $CPANPLUS::Internals::VERSION = $CPANPLUS::Internals::VERSION; |
24 | |
25 | ### can't use O::A as we're using our own AUTOLOAD to get to |
26 | ### the config options. |
4443dd53 |
27 | for my $meth ( qw[conf _lib _perl5lib]) { |
6aaee015 |
28 | no strict 'refs'; |
29 | |
30 | *$meth = sub { |
31 | my $self = shift; |
32 | $self->{'_'.$meth} = $_[0] if @_; |
33 | return $self->{'_'.$meth}; |
34 | } |
35 | } |
36 | |
37 | |
38 | =pod |
39 | |
40 | =head1 NAME |
41 | |
42 | CPANPLUS::Configure |
43 | |
44 | =head1 SYNOPSIS |
45 | |
46 | $conf = CPANPLUS::Configure->new( ); |
47 | |
48 | $bool = $conf->can_save; |
49 | $bool = $conf->save( $where ); |
50 | |
51 | @opts = $conf->options( $type ); |
52 | |
53 | $make = $conf->get_program('make'); |
54 | $verbose = $conf->set_conf( verbose => 1 ); |
55 | |
56 | =head1 DESCRIPTION |
57 | |
58 | This module deals with all the configuration issues for CPANPLUS. |
59 | Users can use objects created by this module to alter the behaviour |
60 | of CPANPLUS. |
61 | |
62 | Please refer to the C<CPANPLUS::Backend> documentation on how to |
63 | obtain a C<CPANPLUS::Configure> object. |
64 | |
65 | =head1 METHODS |
66 | |
67 | =head2 $Configure = CPANPLUS::Configure->new( load_configs => BOOL ) |
68 | |
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. |
72 | |
4443dd53 |
73 | =item load_configs |
74 | |
75 | Controls wether or not additional user configurations are to be loaded |
76 | or not. Defaults to C<true>. |
6aaee015 |
77 | |
78 | =cut |
79 | |
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 |
83 | { my $Config; |
84 | |
85 | sub new { |
86 | my $class = shift; |
87 | my %hash = @_; |
88 | |
89 | ### XXX pass on options to ->init() like rescan? |
90 | my ($load); |
91 | my $tmpl = { |
92 | load_configs => { default => 1, store => \$load }, |
93 | }; |
4443dd53 |
94 | |
6aaee015 |
95 | check( $tmpl, \%hash ) or ( |
96 | warn Params::Check->last_error, return |
97 | ); |
98 | |
99 | $Config ||= CPANPLUS::Config->new; |
100 | my $self = bless {}, $class; |
101 | $self->conf( $Config ); |
4443dd53 |
102 | |
6aaee015 |
103 | ### you want us to load other configs? |
104 | ### these can override things in the default config |
105 | $self->init if $load; |
4443dd53 |
106 | |
107 | ### after processing the config files, check what |
108 | ### @INC and PERL5LIB are set to. |
109 | $self->_lib( \@INC ); |
110 | $self->_perl5lib( $ENV{'PERL5LIB'} ); |
6aaee015 |
111 | |
112 | return $self; |
113 | } |
114 | } |
115 | |
116 | =head2 $bool = $Configure->init( [rescan => BOOL]) |
117 | |
118 | Initialize the configure with other config files than just |
119 | the default 'CPANPLUS::Config'. |
120 | |
121 | Called from C<new()> to load user/system configurations |
122 | |
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>. |
126 | |
127 | Returns true on success, false on failure. |
128 | |
129 | =cut |
130 | |
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 |
136 | { my $loaded; |
137 | my $warned; |
138 | sub init { |
139 | my $self = shift; |
140 | my $obj = $self->conf; |
141 | my %hash = @_; |
142 | |
143 | my ($rescan); |
144 | my $tmpl = { |
145 | rescan => { default => 0, store => \$rescan }, |
146 | }; |
147 | |
148 | check( $tmpl, \%hash ) or ( |
149 | warn Params::Check->last_error, return |
150 | ); |
151 | |
4443dd53 |
152 | ### if the base dir is changed, we have to rescan it |
153 | ### for any CPANPLUS::Config::* files as well, so keep |
154 | ### track of it |
155 | my $cur_base = $self->get_conf('base'); |
156 | |
6aaee015 |
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 ) { |
161 | $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')); |
167 | } |
168 | } |
169 | |
4443dd53 |
170 | { ### make sure that the homedir is included now |
171 | local @INC = ( LIB_DIR->($cur_base), @INC ); |
6aaee015 |
172 | |
4443dd53 |
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; |
178 | |
179 | Module::Pluggable->import( |
180 | search_path => ['CPANPLUS::Config'], |
181 | search_dirs => [ LIB_DIR->($cur_base) ], |
182 | except => qr/::SUPER$/, |
183 | sub_name => 'configs' |
184 | ); |
185 | } |
6aaee015 |
186 | |
6aaee015 |
187 | |
4443dd53 |
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; |
196 | |
197 | for my $plugin ( @confs ) { |
198 | msg(loc("Found config '%1'", $plugin),0); |
199 | |
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); |
204 | next; |
205 | } else { |
206 | msg(loc(" Loading config '%1'", $plugin),0); |
207 | |
208 | if( eval { load $plugin; 1 } ) { |
209 | msg(loc(" Loaded '%1' (%2)", |
210 | $plugin, Module::Loaded::is_loaded( $plugin ) ), 0); |
211 | } else { |
212 | error(loc(" Error loading '%1': %2", $plugin, $@)); |
213 | } |
214 | } |
215 | |
216 | if( $@ ) { |
217 | error(loc("Could not load '%1': %2", $plugin, $@)); |
218 | next; |
219 | } |
220 | |
221 | my $sub = $plugin->can('setup'); |
222 | $sub->( $self ) if $sub; |
223 | } |
6aaee015 |
224 | } |
225 | |
4443dd53 |
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 ); |
232 | } |
233 | |
6aaee015 |
234 | ### clean up the paths once more, just in case |
235 | $obj->_clean_up_paths; |
4443dd53 |
236 | |
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}; |
243 | } |
244 | $self->_lib( \@INC ); |
245 | } |
6aaee015 |
246 | |
247 | return 1; |
248 | } |
249 | } |
250 | =pod |
251 | |
252 | =head2 can_save( [$config_location] ) |
253 | |
254 | Check if we can save the configuration to the specified file. |
255 | If no file is provided, defaults to your personal config. |
256 | |
257 | Returns true if the file can be saved, false otherwise. |
258 | |
259 | =cut |
260 | |
261 | sub can_save { |
262 | my $self = shift; |
263 | my $file = shift || CONFIG_USER_FILE->(); |
264 | |
265 | return 1 unless -e $file; |
266 | |
267 | chmod 0644, $file; |
268 | return (-w $file); |
269 | } |
270 | |
271 | =pod |
272 | |
273 | =head2 $file = $conf->save( [$package_name] ) |
274 | |
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. |
279 | |
280 | If no argument is provided, it will default to your personal |
281 | config. |
282 | |
283 | Returns the full path to the file if the config was saved, |
284 | false otherwise. |
285 | |
286 | =cut |
287 | |
288 | sub _config_pm_to_file { |
289 | my $self = shift; |
290 | my $pm = shift or return; |
291 | my $dir = shift || CONFIG_USER_LIB_DIR->(); |
292 | |
293 | ### only 3 types of files know: home, system and 'other' |
294 | ### so figure out where to save them based on their type |
295 | my $file; |
296 | if( $pm eq CONFIG_USER ) { |
297 | $file = CONFIG_USER_FILE->(); |
298 | |
299 | } elsif ( $pm eq CONFIG_SYSTEM ) { |
300 | $file = CONFIG_SYSTEM_FILE->(); |
301 | |
302 | ### third party file |
303 | } else { |
304 | my $cfg_pkg = CONFIG . '::'; |
305 | unless( $pm =~ /^$cfg_pkg/ ) { |
306 | error(loc( |
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' |
310 | )); |
311 | } |
312 | |
313 | $file = File::Spec->catfile( |
314 | $dir, |
315 | split( '::', $pm ) |
316 | ) . '.pm'; |
317 | } |
318 | |
319 | return $file; |
320 | } |
321 | |
322 | |
323 | sub save { |
324 | my $self = shift; |
325 | my $pm = shift || CONFIG_USER; |
326 | my $savedir = shift || ''; |
327 | |
328 | my $file = $self->_config_pm_to_file( $pm, $savedir ) or return; |
329 | my $dir = dirname( $file ); |
330 | |
331 | unless( -d $dir ) { |
332 | $self->_mkdir( dir => $dir ) or ( |
333 | error(loc("Can not create directory '%1' to save config to",$dir)), |
334 | return |
335 | ) |
336 | } |
337 | return unless $self->can_save($file); |
338 | |
339 | ### find only accesors that are not private |
340 | my @acc = sort grep { $_ !~ /^_/ } $self->conf->ls_accessors; |
341 | |
342 | ### for dumping the values |
343 | use Data::Dumper; |
344 | |
345 | my @lines; |
346 | for my $acc ( @acc ) { |
347 | |
348 | push @lines, "### $acc section", $/; |
349 | |
350 | for my $key ( $self->conf->$acc->ls_accessors ) { |
351 | my $val = Dumper( $self->conf->$acc->$key ); |
352 | |
353 | $val =~ s/\$VAR1\s+=\s+//; |
354 | $val =~ s/;\n//; |
355 | |
356 | push @lines, '$'. "conf->set_${acc}( $key => $val );", $/; |
357 | } |
358 | push @lines, $/,$/; |
359 | |
360 | } |
361 | |
362 | my $str = join '', map { " $_" } @lines; |
363 | |
364 | ### use a variable to make sure the pod parser doesn't snag it |
365 | my $is = '='; |
366 | my $time = gmtime; |
367 | |
368 | |
369 | my $msg = <<_END_OF_CONFIG_; |
370 | ############################################### |
371 | ### |
372 | ### Configuration structure for $pm |
373 | ### |
374 | ############################################### |
375 | |
376 | #last changed: $time GMT |
377 | |
378 | ### minimal pod, so you can find it with perldoc -l, etc |
379 | ${is}pod |
380 | |
381 | ${is}head1 NAME |
382 | |
383 | $pm |
384 | |
385 | ${is}head1 DESCRIPTION |
386 | |
387 | This is a CPANPLUS configuration file. Editing this |
388 | config changes the way CPANPLUS will behave |
389 | |
390 | ${is}cut |
391 | |
392 | package $pm; |
393 | |
394 | use strict; |
395 | |
396 | sub setup { |
397 | my \$conf = shift; |
398 | |
399 | $str |
400 | |
401 | return 1; |
402 | } |
403 | |
404 | 1; |
405 | |
406 | _END_OF_CONFIG_ |
407 | |
408 | $self->_move( file => $file, to => "$file~" ) if -f $file; |
409 | |
410 | my $fh = new FileHandle; |
411 | $fh->open(">$file") |
412 | or (error(loc("Could not open '%1' for writing: %2", $file, $!)), |
413 | return ); |
414 | |
415 | $fh->print($msg); |
416 | $fh->close; |
417 | |
418 | return $file; |
419 | } |
420 | |
421 | =pod |
422 | |
423 | =head2 options( type => TYPE ) |
424 | |
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 |
427 | not exist |
428 | |
429 | =cut |
430 | |
431 | sub options { |
432 | my $self = shift; |
433 | my $conf = $self->conf; |
434 | my %hash = @_; |
435 | |
436 | my $type; |
437 | my $tmpl = { |
438 | type => { required => 1, default => '', |
439 | strict_type => 1, store => \$type }, |
440 | }; |
441 | |
442 | check($tmpl, \%hash) or return; |
443 | |
444 | my %seen; |
445 | return sort grep { !$seen{$_}++ } |
446 | map { $_->$type->ls_accessors if $_->can($type) } |
447 | $self->conf; |
448 | return; |
449 | } |
450 | |
451 | =pod |
452 | |
453 | =head1 ACCESSORS |
454 | |
455 | Accessors that start with a C<_> are marked private -- regular users |
456 | should never need to use these. |
457 | |
622d31ac |
458 | See the C<CPANPLUS::Config> documentation for what items can be |
459 | set and retrieved. |
460 | |
6aaee015 |
461 | =head2 get_SOMETHING( ITEM, [ITEM, ITEM, ... ] ); |
462 | |
463 | The C<get_*> style accessors merely retrieves one or more desired |
464 | config options. |
465 | |
466 | =head2 set_SOMETHING( ITEM => VAL, [ITEM => VAL, ITEM => VAL, ... ] ); |
467 | |
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 |
470 | failure. |
471 | |
472 | =head2 add_SOMETHING( ITEM => VAL, [ITEM => VAL, ITEM => VAL, ... ] ); |
473 | |
474 | The C<add_*> style accessor adds a new key to a config key. |
475 | |
476 | Currently, the following accessors exist: |
477 | |
478 | =over 4 |
479 | |
480 | =item set|get_conf |
481 | |
482 | Simple configuration directives like verbosity and favourite shell. |
483 | |
484 | =item set|get_program |
485 | |
486 | Location of helper programs. |
487 | |
488 | =item _set|_get_build |
489 | |
490 | Locations of where to put what files for CPANPLUS. |
491 | |
492 | =item _set|_get_source |
493 | |
494 | Locations and names of source files locally. |
495 | |
496 | =item _set|_get_mirror |
497 | |
498 | Locations and names of source files remotely. |
499 | |
6aaee015 |
500 | =item _set|_get_fetch |
501 | |
502 | Special settings pertaining to the fetching of files. |
503 | |
6aaee015 |
504 | =back |
505 | |
506 | =cut |
507 | |
508 | sub AUTOLOAD { |
509 | my $self = shift; |
510 | my $conf = $self->conf; |
511 | |
512 | my $name = $AUTOLOAD; |
513 | $name =~ s/.+:://; |
514 | |
515 | my ($private, $action, $field) = |
516 | $name =~ m/^(_)?((?:[gs]et|add))_([a-z]+)$/; |
517 | |
518 | my $type = ''; |
519 | $type .= '_' if $private; |
520 | $type .= $field if $field; |
521 | |
522 | unless ( $conf->can($type) ) { |
523 | error( loc("Invalid method type: '%1'", $name) ); |
524 | return; |
525 | } |
526 | |
527 | unless( scalar @_ ) { |
528 | error( loc("No arguments provided!") ); |
529 | return; |
530 | } |
531 | |
532 | ### retrieve a current value for an existing key ### |
533 | if( $action eq 'get' ) { |
534 | for my $key (@_) { |
535 | my @list = (); |
536 | |
537 | ### get it from the user config first |
538 | if( $conf->can($type) and $conf->$type->can($key) ) { |
539 | push @list, $conf->$type->$key; |
540 | |
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); |
546 | |
547 | } else { |
548 | error( loc(q[No such key '%1' in field '%2'], $key, $type) ); |
549 | return; |
550 | } |
551 | |
552 | return wantarray ? @list : $list[0]; |
553 | } |
554 | |
555 | ### set an existing key to a new value ### |
556 | } elsif ( $action eq 'set' ) { |
557 | my %args = @_; |
558 | |
559 | while( my($key,$val) = each %args ) { |
560 | |
561 | if( $conf->can($type) and $conf->$type->can($key) ) { |
562 | $conf->$type->$key( $val ); |
563 | |
564 | } else { |
565 | error( loc(q[No such key '%1' in field '%2'], $key, $type) ); |
566 | return; |
567 | } |
568 | } |
569 | |
570 | return 1; |
571 | |
572 | ### add a new key to the config ### |
573 | } elsif ( $action eq 'add' ) { |
574 | my %args = @_; |
575 | |
576 | while( my($key,$val) = each %args ) { |
577 | |
578 | if( $conf->$type->can($key) ) { |
579 | error( loc( q[Key '%1' already exists for field '%2'], |
580 | $key, $type)); |
581 | return; |
582 | } else { |
583 | $conf->$type->mk_accessors( $key ); |
584 | $conf->$type->$key( $val ); |
585 | } |
586 | } |
587 | return 1; |
588 | |
589 | } else { |
590 | |
591 | error( loc(q[Unknown action '%1'], $action) ); |
592 | return; |
593 | } |
594 | } |
595 | |
596 | sub DESTROY { 1 }; |
597 | |
598 | 1; |
599 | |
600 | =pod |
601 | |
602 | =head1 BUG REPORTS |
603 | |
604 | Please report bugs or other issues to E<lt>bug-cpanplus@rt.cpan.org<gt>. |
605 | |
606 | =head1 AUTHOR |
607 | |
608 | This module by Jos Boumans E<lt>kane@cpan.orgE<gt>. |
609 | |
610 | =head1 COPYRIGHT |
611 | |
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. |
614 | |
615 | This library is free software; you may redistribute and/or modify it |
616 | under the same terms as Perl itself. |
617 | |
618 | =head1 SEE ALSO |
619 | |
622d31ac |
620 | L<CPANPLUS::Backend>, L<CPANPLUS::Configure::Setup>, L<CPANPLUS::Config> |
6aaee015 |
621 | |
622 | =cut |
623 | |
624 | # Local variables: |
625 | # c-indentation-style: bsd |
626 | # c-basic-offset: 4 |
627 | # indent-tabs-mode: nil |
628 | # End: |
629 | # vim: expandtab shiftwidth=4: |
630 | |