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