File Coverage

lib/CPANPLUS/Configure.pm
Criterion Covered Total %
statement 161 180 89.4
branch 38 64 59.4
condition 10 22 45.5
subroutine 23 23 100.0
pod 5 5 100.0
total 237 294 80.6


line stmt bran cond sub pod time code
1             package CPANPLUS::Configure;
2 15     15   225 use strict;
  15         221  
  15         291  
3              
4              
5 15     15   489 use CPANPLUS::Internals::Constants;
  15         170  
  15         5472  
6 15     15   344 use CPANPLUS::Error;
  15         163  
  15         349  
7 15     15   784 use CPANPLUS::Config;
  15         999  
  15         4547  
8              
9 15     15   1423 use Log::Message;
  15         473  
  15         4349  
10 15     15   374 use Module::Load qw[load];
  15         502  
  15         1908  
11 15     15   263 use Params::Check qw[check];
  15         159  
  15         2315  
12 15     15   264 use File::Basename qw[dirname];
  15         209  
  15         1247  
13 15     15   1271 use Module::Loaded ();
  15         166  
  15         160  
14 15     15   262 use Locale::Maketext::Simple Class => 'CPANPLUS', Style => 'gettext';
  15         187  
  15         1606  
15              
16 15     15   260 use vars qw[$AUTOLOAD $VERSION $MIN_CONFIG_VERSION];
  15         144  
  15         220  
17 15     15   242 use base qw[CPANPLUS::Internals::Utils];
  15         300  
  15         227  
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 15     15   281     no strict 'refs';
  15         146  
  15         492  
29                 
30                 *$meth = sub {
31 2864     2864   49216         my $self = shift;
32 2864 100       102182         $self->{'_'.$meth} = $_[0] if @_;
33 2864         72381         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 15     15 1 3105         my $class = shift;
85 15         364         my %hash = @_;
86                     
87 15         286         my ($load);
88 15         289         my $tmpl = {
89                         load_configs => { default => 1, store => \$load },
90                     };
91                     
92 15 50       600         check( $tmpl, \%hash ) or (
93                         warn Params::Check->last_error, return
94                     );
95                     
96 15   66     704         $Config ||= CPANPLUS::Config->new;
97 15         444         my $self = bless {}, $class;
98 15         525         $self->conf( $Config );
99                 
100             ### you want us to load other configs?
101             ### these can override things in the default config
102 15 50       384         $self->init if $load;
103                 
104 15         364         return $self;
105                 }
106             }
107              
108             =head2 $bool = $Configure->init
109            
110             Initialize the configure with other config files than just
111             the default 'CPANPLUS::Config'.
112            
113             Called from C<new()> to load user/system configurations
114            
115             =cut
116              
117             ### move the Module::Pluggable detection to runtime, rather
118             ### than compile time, so that a simple 'require CPANPLUS'
119             ### doesn't start running over your filesystem for no good
120             ### reason. Make sure we only do the M::P call once though.
121             ### we use $loaded to mark it
122             {   my $loaded;
123              
124                 sub init {
125 15     15 1 379         my $self = shift;
126 15         306         my $obj = $self->conf;
127                     
128             ### make sure that the homedir is included now
129 15         397         local @INC = ( CONFIG_USER_LIB_DIR->(), @INC );
130                     
131             ### only set it up once
132 15 100       5554         unless( $loaded++ ) {
133             ### find plugins & extra configs
134             ### check $home/.cpanplus/lib as well
135 14         664             require Module::Pluggable;
136                         
137 14         532             Module::Pluggable->import(
138                             search_path => ['CPANPLUS::Config'],
139                             search_dirs => [ CONFIG_USER_LIB_DIR ],
140                             except => qr/::SUPER$/,
141                             sub_name => 'configs'
142                         );
143                     }
144                     
145                     
146             ### do system config, user config, rest.. in that order
147             ### apparently, on a 2nd invocation of -->configs, a
148             ### ::ISA::CACHE package can appear.. that's bad...
149 1         13         my %confs = map { $_ => $_ }
  1         12  
150 15         350                     grep { $_ !~ /::ISA::/ } __PACKAGE__->configs;
151 30         450         my @confs = grep { defined }
  30         467  
152 15         169                     map { delete $confs{$_} } CONFIG_SYSTEM, CONFIG_USER;
153 15         189         push @confs, sort keys %confs;
154                 
155 15         158         for my $plugin ( @confs ) {
156 1         14             msg(loc("Found plugin '%1'", $plugin),0);
157                         
158             ### if we already did this the /last/ time around dont
159             ### run the setup agian.
160 1 50       31             next if Module::Loaded::is_loaded( $plugin );
161 1         59             msg(loc("Loading plugin '%1'", $plugin),0);
162                         
163 1         25             eval { load $plugin };
  1         15  
164                         
165 1 50       25             if( $@ ) {
166 0         0                 error(loc("Could not load '%1': %2", $plugin, $@));
167 0         0                 next;
168                         }
169                         
170 1         25             my $sub = $plugin->can('setup');
171 1 50       15             $sub->( $self ) if $sub;
172                     }
173                     
174             ### clean up the paths once more, just in case
175 15         243         $obj->_clean_up_paths;
176                 
177 15         251         return 1;
178                 }
179             }
180             =pod
181            
182             =head2 can_save( [$config_location] )
183            
184             Check if we can save the configuration to the specified file.
185             If no file is provided, defaults to your personal config.
186            
187             Returns true if the file can be saved, false otherwise.
188            
189             =cut
190              
191             sub can_save {
192 2     2 1 29     my $self = shift;
193 2   33     23     my $file = shift || CONFIG_USER_FILE->();
194                 
195 2 50       59     return 1 unless -e $file;
196              
197 2         134     chmod 0644, $file;
198 2         45     return (-w $file);
199             }
200              
201             =pod
202            
203             =head2 save( [$package_name] )
204            
205             Saves the configuration to the package name you provided.
206             If this package is not C<CPANPLUS::Config::System>, it will
207             be saved in your C<.cpanplus> directory, otherwise it will
208             be attempted to be saved in the system wide directory.
209            
210             If no argument is provided, it will default to your personal
211             config.
212            
213             Returns true if the file was saved, false otherwise.
214            
215             =cut
216              
217             sub _config_pm_to_file {
218 1     1   10     my $self = shift;
219 1 50       13     my $pm = shift or return;
220 1   33     25     my $dir = shift || CONFIG_USER_LIB_DIR->();
221              
222             ### only 3 types of files know: home, system and 'other'
223             ### so figure out where to save them based on their type
224 1         88     my $file;
225 1 50       13     if( $pm eq CONFIG_USER ) {
    0          
226 1         13         $file = CONFIG_USER_FILE->();
227              
228                 } elsif ( $pm eq CONFIG_SYSTEM ) {
229 0         0         $file = CONFIG_SYSTEM_FILE->();
230                     
231             ### third party file
232                 } else {
233 0         0         my $cfg_pkg = CONFIG . '::';
234 0 0       0         unless( $pm =~ /^$cfg_pkg/ ) {
235 0         0             error(loc(
236                             "WARNING: Your config package '%1' is not in the '%2' ".
237                             "namespace and will not be automatically detected by %3",
238                             $pm, $cfg_pkg, 'CPANPLUS'
239                         ));
240                     }
241                 
242 0         0         $file = File::Spec->catfile(
243                         $dir,
244                         split( '::', $pm )
245                     ) . '.pm';
246                 }
247              
248 1         15     return $file;
249             }
250              
251              
252             sub save {
253 1     1 1 11     my $self = shift;
254 1   50     12     my $pm = shift || CONFIG_USER;
255 1   50     16     my $savedir = shift || '';
256                 
257 1 50       13     my $file = $self->_config_pm_to_file( $pm, $savedir ) or return;
258 1         16     my $dir = dirname( $file );
259                 
260 1 50       25     unless( -d $dir ) {
261 0 0       0         $self->_mkdir( dir => $dir ) or (
262                         error(loc("Can not create directory '%1' to save config to",$dir)),
263                         return
264                     )
265                 }
266 1 50       12     return unless $self->can_save($file);
267              
268             ### find only accesors that are not private
269 1         61     my @acc = sort grep { $_ !~ /^_/ } $self->conf->ls_accessors;
  6         127  
270              
271             ### for dumping the values
272 15     15   548     use Data::Dumper;
  15         253  
  15         1201  
273                 
274 1         14     my @lines;
275 1         10     for my $acc ( @acc ) {
276                     
277 2         25         push @lines, "### $acc section", $/;
278                     
279 2         26         for my $key ( $self->conf->$acc->ls_accessors ) {
280 37         382             my $val = Dumper( $self->conf->$acc->$key );
281                     
282 37         559             $val =~ s/\$VAR1\s+=\s+//;
283 37         923             $val =~ s/;\n//;
284                     
285 37         556             push @lines, '$'. "conf->set_${acc}( $key => $val );", $/;
286                     }
287 2         66         push @lines, $/,$/;
288              
289                 }
290              
291 1         12     my $str = join '', map { " $_" } @lines;
  82         926  
292              
293             ### use a variable to make sure the pod parser doesn't snag it
294 1         20     my $is = '=';
295 1         410     my $time = gmtime;
296                
297                 
298 1         86     my $msg = <<_END_OF_CONFIG_;
299             ###############################################
300             ###
301             ### Configuration structure for $pm
302             ###
303             ###############################################
304            
305             #last changed: $time GMT
306            
307             ### minimal pod, so you can find it with perldoc -l, etc
308             ${is}pod
309            
310             ${is}head1 NAME
311            
312             $pm
313            
314             ${is}head1 DESCRIPTION
315            
316             This is a CPANPLUS configuration file. Editing this
317             config changes the way CPANPLUS will behave
318            
319             ${is}cut
320            
321             package $pm;
322            
323             use strict;
324            
325             sub setup {
326             my \$conf = shift;
327            
328             $str
329            
330             return 1;
331             }
332            
333             1;
334            
335             _END_OF_CONFIG_
336              
337 1 50       54     $self->_move( file => $file, to => "$file~" ) if -f $file;
338              
339 1         39     my $fh = new FileHandle;
340 1 50       154     $fh->open(">$file")
341                     or (error(loc("Could not open '%1' for writing: %2", $file, $!)),
342                         return );
343              
344 1         151     $fh->print($msg);
345 1         72     $fh->close;
346              
347 1         14     return 1;
348             }
349              
350             =pod
351            
352             =head2 options( type => TYPE )
353            
354             Returns a list of all valid config options given a specific type
355             (like for example C<conf> of C<program>) or false if the type does
356             not exist
357            
358             =cut
359              
360             sub options {
361 6     6 1 14053     my $self = shift;
362 6         75     my $conf = $self->conf;
363 6         76     my %hash = @_;
364              
365 6         53     my $type;
366 6         167     my $tmpl = {
367                     type => { required => 1, default => '',
368                                  strict_type => 1, store => \$type },
369                 };
370              
371 6 50       88     check($tmpl, \%hash) or return;
372              
373 6         58     my %seen;
374 55 50       691     return sort grep { !$seen{$_}++ }
  6         76  
375 6         64                 map { $_->$type->ls_accessors if $_->can($type) }
376                             $self->conf;
377 0         0     return;
378             }
379              
380             =pod
381            
382             =head1 ACCESSORS
383            
384             Accessors that start with a C<_> are marked private -- regular users
385             should never need to use these.
386            
387             =head2 get_SOMETHING( ITEM, [ITEM, ITEM, ... ] );
388            
389             The C<get_*> style accessors merely retrieves one or more desired
390             config options.
391            
392             =head2 set_SOMETHING( ITEM => VAL, [ITEM => VAL, ITEM => VAL, ... ] );
393            
394             The C<set_*> style accessors set the current value for one
395             or more config options and will return true upon success, false on
396             failure.
397            
398             =head2 add_SOMETHING( ITEM => VAL, [ITEM => VAL, ITEM => VAL, ... ] );
399            
400             The C<add_*> style accessor adds a new key to a config key.
401            
402             Currently, the following accessors exist:
403            
404             =over 4
405            
406             =item set|get_conf
407            
408             Simple configuration directives like verbosity and favourite shell.
409            
410             =item set|get_program
411            
412             Location of helper programs.
413            
414             =item _set|_get_build
415            
416             Locations of where to put what files for CPANPLUS.
417            
418             =item _set|_get_source
419            
420             Locations and names of source files locally.
421            
422             =item _set|_get_mirror
423            
424             Locations and names of source files remotely.
425            
426             =item _set|_get_dist
427            
428             Mapping of distribution format names to modules.
429            
430             =item _set|_get_fetch
431            
432             Special settings pertaining to the fetching of files.
433            
434             =item _set|_get_daemon
435            
436             Settings for C<cpanpd>, the CPANPLUS daemon.
437            
438             =back
439            
440             =cut
441              
442             sub AUTOLOAD {
443 2781     2781   580755     my $self = shift;
444 2781         69340     my $conf = $self->conf;
445              
446 2781         46285     my $name = $AUTOLOAD;
447 2781         62995     $name =~ s/.+:://;
448              
449 2781         70194     my ($private, $action, $field) =
450                             $name =~ m/^(_)?((?:[gs]et|add))_([a-z]+)$/;
451              
452 2781         51762     my $type = '';
453 2781 100       41286     $type .= '_' if $private;
454 2781 100       51611     $type .= $field if $field;
455              
456 2781 100       74102     unless ( $conf->can($type) ) {
457 1         14         error( loc("Invalid method type: '%1'", $name) );
458 1         51         return;
459                 }
460              
461 2780 50       46120     unless( scalar @_ ) {
462 0         0         error( loc("No arguments provided!") );
463 0         0         return;
464                 }
465              
466             ### retrieve a current value for an existing key ###
467 2780 100       37545     if( $action eq 'get' ) {
    100          
    50          
468 2525         31142         for my $key (@_) {
469 2525         26589             my @list = ();
470              
471             ### get it from the user config first
472 2525 100 66     39149             if( $conf->can($type) and $conf->$type->can($key) ) {
    50 33        
473 2524         46519                 push @list, $conf->$type->$key;
474              
475             ### XXX EU::AI compatibility hack to provide lookups like in
476             ### cpanplus 0.04x; we renamed ->_get_build('base') to
477             ### ->get_conf('base')
478                         } elsif ( $type eq '_build' and $key eq 'base' ) {
479 1         87                 return $self->get_conf($key);
480                             
481                         } else {
482 0         0                 error( loc(q[No such key '%1' in field '%2'], $key, $type) );
483 0         0                 return;
484                         }
485              
486 2524 100       125139             return wantarray ? @list : $list[0];
487                     }
488              
489             ### set an existing key to a new value ###
490                 } elsif ( $action eq 'set' ) {
491 249         6352         my %args = @_;
492              
493 249         4029         while( my($key,$val) = each %args ) {
494              
495 249 50 33     3591             if( $conf->can($type) and $conf->$type->can($key) ) {
496 249         3648                 $conf->$type->$key( $val );
497                             
498                         } else {
499 0         0                 error( loc(q[No such key '%1' in field '%2'], $key, $type) );
500 0         0                 return;
501                         }
502                     }
503              
504 249         11094         return 1;
505              
506             ### add a new key to the config ###
507                 } elsif ( $action eq 'add' ) {
508 6         67         my %args = @_;
509              
510 6         81         while( my($key,$val) = each %args ) {
511              
512 6 50       90             if( $conf->$type->can($key) ) {
513 0         0                 error( loc( q[Key '%1' already exists for field '%2'],
514                                         $key, $type));
515 0         0                 return;
516                         } else {
517 6         85                 $conf->$type->mk_accessors( $key );
518 6         84                 $conf->$type->$key( $val );
519                         }
520                     }
521 6         107         return 1;
522              
523                 } else {
524              
525 0         0         error( loc(q[Unknown action '%1'], $action) );
526 0         0         return;
527                 }
528             }
529              
530 3     3   47 sub DESTROY { 1 };
531              
532             1;
533              
534             =pod
535            
536             =head1 AUTHOR
537            
538             This module by
539             Jos Boumans E<lt>kane@cpan.orgE<gt>.
540            
541             =head1 COPYRIGHT
542            
543             The CPAN++ interface (of which this module is a part of) is
544             copyright (c) 2001, 2002, 2003, 2004, Jos Boumans E<lt>kane@cpan.orgE<gt>.
545             All rights reserved.
546            
547             This library is free software;
548             you may redistribute and/or modify it under the same
549             terms as Perl itself.
550            
551             =head1 SEE ALSO
552            
553             L<CPANPLUS::Backend>, L<CPANPLUS::Configure::Setup>
554            
555             =cut
556              
557             # Local variables:
558             # c-indentation-style: bsd
559             # c-basic-offset: 4
560             # indent-tabs-mode: nil
561             # End:
562             # vim: expandtab shiftwidth=4:
563              
564