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. |
27 | for my $meth ( qw[conf]) { |
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 | |
73 | The C<load_configs> parameter controls wether or not additional |
74 | user configurations are to be loaded or not. Defaults to C<true>. |
75 | |
76 | =cut |
77 | |
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 |
81 | { my $Config; |
82 | |
83 | sub new { |
84 | my $class = shift; |
85 | my %hash = @_; |
86 | |
87 | ### XXX pass on options to ->init() like rescan? |
88 | my ($load); |
89 | my $tmpl = { |
90 | load_configs => { default => 1, store => \$load }, |
91 | }; |
92 | |
93 | check( $tmpl, \%hash ) or ( |
94 | warn Params::Check->last_error, return |
95 | ); |
96 | |
97 | $Config ||= CPANPLUS::Config->new; |
98 | my $self = bless {}, $class; |
99 | $self->conf( $Config ); |
100 | |
101 | ### you want us to load other configs? |
102 | ### these can override things in the default config |
103 | $self->init if $load; |
104 | |
105 | return $self; |
106 | } |
107 | } |
108 | |
109 | =head2 $bool = $Configure->init( [rescan => BOOL]) |
110 | |
111 | Initialize the configure with other config files than just |
112 | the default 'CPANPLUS::Config'. |
113 | |
114 | Called from C<new()> to load user/system configurations |
115 | |
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>. |
119 | |
120 | Returns true on success, false on failure. |
121 | |
122 | =cut |
123 | |
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 |
129 | { my $loaded; |
130 | my $warned; |
131 | sub init { |
132 | my $self = shift; |
133 | my $obj = $self->conf; |
134 | my %hash = @_; |
135 | |
136 | my ($rescan); |
137 | my $tmpl = { |
138 | rescan => { default => 0, store => \$rescan }, |
139 | }; |
140 | |
141 | check( $tmpl, \%hash ) or ( |
142 | warn Params::Check->last_error, return |
143 | ); |
144 | |
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 ) { |
149 | $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')); |
155 | } |
156 | } |
157 | |
158 | ### make sure that the homedir is included now |
159 | local @INC = ( CONFIG_USER_LIB_DIR->(), @INC ); |
160 | |
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; |
166 | |
167 | Module::Pluggable->import( |
168 | search_path => ['CPANPLUS::Config'], |
169 | search_dirs => [ CONFIG_USER_LIB_DIR ], |
170 | except => qr/::SUPER$/, |
171 | sub_name => 'configs' |
172 | ); |
173 | } |
174 | |
175 | |
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; |
184 | |
185 | for my $plugin ( @confs ) { |
186 | msg(loc("Found config '%1'", $plugin),0); |
187 | |
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); |
192 | next; |
193 | } else { |
194 | msg(loc(" Loading config '%1'", $plugin),0); |
195 | |
196 | eval { load $plugin }; |
197 | msg(loc(" Loaded '%1' (%2)", |
198 | $plugin, Module::Loaded::is_loaded( $plugin ) ), 0); |
199 | } |
200 | |
201 | if( $@ ) { |
202 | error(loc("Could not load '%1': %2", $plugin, $@)); |
203 | next; |
204 | } |
205 | |
206 | my $sub = $plugin->can('setup'); |
207 | $sub->( $self ) if $sub; |
208 | } |
209 | |
210 | ### clean up the paths once more, just in case |
211 | $obj->_clean_up_paths; |
212 | |
213 | return 1; |
214 | } |
215 | } |
216 | =pod |
217 | |
218 | =head2 can_save( [$config_location] ) |
219 | |
220 | Check if we can save the configuration to the specified file. |
221 | If no file is provided, defaults to your personal config. |
222 | |
223 | Returns true if the file can be saved, false otherwise. |
224 | |
225 | =cut |
226 | |
227 | sub can_save { |
228 | my $self = shift; |
229 | my $file = shift || CONFIG_USER_FILE->(); |
230 | |
231 | return 1 unless -e $file; |
232 | |
233 | chmod 0644, $file; |
234 | return (-w $file); |
235 | } |
236 | |
237 | =pod |
238 | |
239 | =head2 $file = $conf->save( [$package_name] ) |
240 | |
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. |
245 | |
246 | If no argument is provided, it will default to your personal |
247 | config. |
248 | |
249 | Returns the full path to the file if the config was saved, |
250 | false otherwise. |
251 | |
252 | =cut |
253 | |
254 | sub _config_pm_to_file { |
255 | my $self = shift; |
256 | my $pm = shift or return; |
257 | my $dir = shift || CONFIG_USER_LIB_DIR->(); |
258 | |
259 | ### only 3 types of files know: home, system and 'other' |
260 | ### so figure out where to save them based on their type |
261 | my $file; |
262 | if( $pm eq CONFIG_USER ) { |
263 | $file = CONFIG_USER_FILE->(); |
264 | |
265 | } elsif ( $pm eq CONFIG_SYSTEM ) { |
266 | $file = CONFIG_SYSTEM_FILE->(); |
267 | |
268 | ### third party file |
269 | } else { |
270 | my $cfg_pkg = CONFIG . '::'; |
271 | unless( $pm =~ /^$cfg_pkg/ ) { |
272 | error(loc( |
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' |
276 | )); |
277 | } |
278 | |
279 | $file = File::Spec->catfile( |
280 | $dir, |
281 | split( '::', $pm ) |
282 | ) . '.pm'; |
283 | } |
284 | |
285 | return $file; |
286 | } |
287 | |
288 | |
289 | sub save { |
290 | my $self = shift; |
291 | my $pm = shift || CONFIG_USER; |
292 | my $savedir = shift || ''; |
293 | |
294 | my $file = $self->_config_pm_to_file( $pm, $savedir ) or return; |
295 | my $dir = dirname( $file ); |
296 | |
297 | unless( -d $dir ) { |
298 | $self->_mkdir( dir => $dir ) or ( |
299 | error(loc("Can not create directory '%1' to save config to",$dir)), |
300 | return |
301 | ) |
302 | } |
303 | return unless $self->can_save($file); |
304 | |
305 | ### find only accesors that are not private |
306 | my @acc = sort grep { $_ !~ /^_/ } $self->conf->ls_accessors; |
307 | |
308 | ### for dumping the values |
309 | use Data::Dumper; |
310 | |
311 | my @lines; |
312 | for my $acc ( @acc ) { |
313 | |
314 | push @lines, "### $acc section", $/; |
315 | |
316 | for my $key ( $self->conf->$acc->ls_accessors ) { |
317 | my $val = Dumper( $self->conf->$acc->$key ); |
318 | |
319 | $val =~ s/\$VAR1\s+=\s+//; |
320 | $val =~ s/;\n//; |
321 | |
322 | push @lines, '$'. "conf->set_${acc}( $key => $val );", $/; |
323 | } |
324 | push @lines, $/,$/; |
325 | |
326 | } |
327 | |
328 | my $str = join '', map { " $_" } @lines; |
329 | |
330 | ### use a variable to make sure the pod parser doesn't snag it |
331 | my $is = '='; |
332 | my $time = gmtime; |
333 | |
334 | |
335 | my $msg = <<_END_OF_CONFIG_; |
336 | ############################################### |
337 | ### |
338 | ### Configuration structure for $pm |
339 | ### |
340 | ############################################### |
341 | |
342 | #last changed: $time GMT |
343 | |
344 | ### minimal pod, so you can find it with perldoc -l, etc |
345 | ${is}pod |
346 | |
347 | ${is}head1 NAME |
348 | |
349 | $pm |
350 | |
351 | ${is}head1 DESCRIPTION |
352 | |
353 | This is a CPANPLUS configuration file. Editing this |
354 | config changes the way CPANPLUS will behave |
355 | |
356 | ${is}cut |
357 | |
358 | package $pm; |
359 | |
360 | use strict; |
361 | |
362 | sub setup { |
363 | my \$conf = shift; |
364 | |
365 | $str |
366 | |
367 | return 1; |
368 | } |
369 | |
370 | 1; |
371 | |
372 | _END_OF_CONFIG_ |
373 | |
374 | $self->_move( file => $file, to => "$file~" ) if -f $file; |
375 | |
376 | my $fh = new FileHandle; |
377 | $fh->open(">$file") |
378 | or (error(loc("Could not open '%1' for writing: %2", $file, $!)), |
379 | return ); |
380 | |
381 | $fh->print($msg); |
382 | $fh->close; |
383 | |
384 | return $file; |
385 | } |
386 | |
387 | =pod |
388 | |
389 | =head2 options( type => TYPE ) |
390 | |
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 |
393 | not exist |
394 | |
395 | =cut |
396 | |
397 | sub options { |
398 | my $self = shift; |
399 | my $conf = $self->conf; |
400 | my %hash = @_; |
401 | |
402 | my $type; |
403 | my $tmpl = { |
404 | type => { required => 1, default => '', |
405 | strict_type => 1, store => \$type }, |
406 | }; |
407 | |
408 | check($tmpl, \%hash) or return; |
409 | |
410 | my %seen; |
411 | return sort grep { !$seen{$_}++ } |
412 | map { $_->$type->ls_accessors if $_->can($type) } |
413 | $self->conf; |
414 | return; |
415 | } |
416 | |
417 | =pod |
418 | |
419 | =head1 ACCESSORS |
420 | |
421 | Accessors that start with a C<_> are marked private -- regular users |
422 | should never need to use these. |
423 | |
622d31ac |
424 | See the C<CPANPLUS::Config> documentation for what items can be |
425 | set and retrieved. |
426 | |
6aaee015 |
427 | =head2 get_SOMETHING( ITEM, [ITEM, ITEM, ... ] ); |
428 | |
429 | The C<get_*> style accessors merely retrieves one or more desired |
430 | config options. |
431 | |
432 | =head2 set_SOMETHING( ITEM => VAL, [ITEM => VAL, ITEM => VAL, ... ] ); |
433 | |
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 |
436 | failure. |
437 | |
438 | =head2 add_SOMETHING( ITEM => VAL, [ITEM => VAL, ITEM => VAL, ... ] ); |
439 | |
440 | The C<add_*> style accessor adds a new key to a config key. |
441 | |
442 | Currently, the following accessors exist: |
443 | |
444 | =over 4 |
445 | |
446 | =item set|get_conf |
447 | |
448 | Simple configuration directives like verbosity and favourite shell. |
449 | |
450 | =item set|get_program |
451 | |
452 | Location of helper programs. |
453 | |
454 | =item _set|_get_build |
455 | |
456 | Locations of where to put what files for CPANPLUS. |
457 | |
458 | =item _set|_get_source |
459 | |
460 | Locations and names of source files locally. |
461 | |
462 | =item _set|_get_mirror |
463 | |
464 | Locations and names of source files remotely. |
465 | |
6aaee015 |
466 | =item _set|_get_fetch |
467 | |
468 | Special settings pertaining to the fetching of files. |
469 | |
6aaee015 |
470 | =back |
471 | |
472 | =cut |
473 | |
474 | sub AUTOLOAD { |
475 | my $self = shift; |
476 | my $conf = $self->conf; |
477 | |
478 | my $name = $AUTOLOAD; |
479 | $name =~ s/.+:://; |
480 | |
481 | my ($private, $action, $field) = |
482 | $name =~ m/^(_)?((?:[gs]et|add))_([a-z]+)$/; |
483 | |
484 | my $type = ''; |
485 | $type .= '_' if $private; |
486 | $type .= $field if $field; |
487 | |
488 | unless ( $conf->can($type) ) { |
489 | error( loc("Invalid method type: '%1'", $name) ); |
490 | return; |
491 | } |
492 | |
493 | unless( scalar @_ ) { |
494 | error( loc("No arguments provided!") ); |
495 | return; |
496 | } |
497 | |
498 | ### retrieve a current value for an existing key ### |
499 | if( $action eq 'get' ) { |
500 | for my $key (@_) { |
501 | my @list = (); |
502 | |
503 | ### get it from the user config first |
504 | if( $conf->can($type) and $conf->$type->can($key) ) { |
505 | push @list, $conf->$type->$key; |
506 | |
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); |
512 | |
513 | } else { |
514 | error( loc(q[No such key '%1' in field '%2'], $key, $type) ); |
515 | return; |
516 | } |
517 | |
518 | return wantarray ? @list : $list[0]; |
519 | } |
520 | |
521 | ### set an existing key to a new value ### |
522 | } elsif ( $action eq 'set' ) { |
523 | my %args = @_; |
524 | |
525 | while( my($key,$val) = each %args ) { |
526 | |
527 | if( $conf->can($type) and $conf->$type->can($key) ) { |
528 | $conf->$type->$key( $val ); |
529 | |
530 | } else { |
531 | error( loc(q[No such key '%1' in field '%2'], $key, $type) ); |
532 | return; |
533 | } |
534 | } |
535 | |
536 | return 1; |
537 | |
538 | ### add a new key to the config ### |
539 | } elsif ( $action eq 'add' ) { |
540 | my %args = @_; |
541 | |
542 | while( my($key,$val) = each %args ) { |
543 | |
544 | if( $conf->$type->can($key) ) { |
545 | error( loc( q[Key '%1' already exists for field '%2'], |
546 | $key, $type)); |
547 | return; |
548 | } else { |
549 | $conf->$type->mk_accessors( $key ); |
550 | $conf->$type->$key( $val ); |
551 | } |
552 | } |
553 | return 1; |
554 | |
555 | } else { |
556 | |
557 | error( loc(q[Unknown action '%1'], $action) ); |
558 | return; |
559 | } |
560 | } |
561 | |
562 | sub DESTROY { 1 }; |
563 | |
564 | 1; |
565 | |
566 | =pod |
567 | |
568 | =head1 BUG REPORTS |
569 | |
570 | Please report bugs or other issues to E<lt>bug-cpanplus@rt.cpan.org<gt>. |
571 | |
572 | =head1 AUTHOR |
573 | |
574 | This module by Jos Boumans E<lt>kane@cpan.orgE<gt>. |
575 | |
576 | =head1 COPYRIGHT |
577 | |
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. |
580 | |
581 | This library is free software; you may redistribute and/or modify it |
582 | under the same terms as Perl itself. |
583 | |
584 | =head1 SEE ALSO |
585 | |
622d31ac |
586 | L<CPANPLUS::Backend>, L<CPANPLUS::Configure::Setup>, L<CPANPLUS::Config> |
6aaee015 |
587 | |
588 | =cut |
589 | |
590 | # Local variables: |
591 | # c-indentation-style: bsd |
592 | # c-basic-offset: 4 |
593 | # indent-tabs-mode: nil |
594 | # End: |
595 | # vim: expandtab shiftwidth=4: |
596 | |