File Coverage

blib/lib/Config/General.pm
Criterion Covered Total %
statement 415 541 76.7
branch 203 306 66.3
condition 40 72 55.6
subroutine 28 32 87.5
pod 8 10 80.0
total 694 961 72.2


line stmt bran cond sub pod time code
1             #
2             # Config::General.pm - Generic Config Module
3             #
4             # Purpose: Provide a convenient way for loading
5             # config values from a given file and
6             # return it as hash structure
7             #
8             # Copyright (c) 2000-2007 Thomas Linden <tlinden |AT| cpan.org>.
9             # All Rights Reserved. Std. disclaimer applies.
10             # Artificial License, same as perl itself. Have fun.
11             #
12             # namespace
13             package Config::General;
14              
15 1     1   17 use strict;
  1         10  
  1         16  
16 1     1   15 use warnings;
  1         9  
  1         17  
17 1     1   31 use English '-no_match_vars';
  1         10  
  1         16  
18              
19 1     1   35 use IO::File;
  1         10  
  1         23  
20 1     1   63 use FileHandle;
  1         9  
  1         16  
21 1     1   84 use File::Spec::Functions qw(splitpath file_name_is_absolute catfile catpath);
  1         37  
  1         24  
22 1     1   19 use File::Glob qw/:glob/;
  1         9  
  1         18  
23              
24              
25             # on debian with perl > 5.8.4 croak() doesn't work anymore without this.
26             # There is some require statement which dies 'cause it can't find Carp::Heavy,
27             # I really don't understand, what the hell they made, but the debian perl
28             # installation is definetly bullshit, damn!
29 1     1   38 use Carp::Heavy;
  1         10  
  1         22  
30              
31              
32 1     1   16 use Carp;
  1         9  
  1         17  
33 1     1   15 use Exporter;
  1         9  
  1         14  
34              
35             $Config::General::VERSION = 2.32;
36              
37 1     1   17 use vars qw(@ISA @EXPORT_OK);
  1         9  
  1         16  
38 1     1   15 use base qw(Exporter);
  1         12  
  1         18  
39             @EXPORT_OK = qw(ParseConfig SaveConfig SaveConfigString);
40              
41             sub new {
42             #
43             # create new Config::General object
44             #
45 40     40 1 728   my($this, @param ) = @_;
46 40   66     566   my $class = ref($this) || $this;
47              
48             # define default options
49 40         1864   my $self = {
50             SlashIsDirectory      => 0,
51              
52             AllowMultiOptions     => 1,
53              
54             MergeDuplicateOptions => 0,
55             MergeDuplicateBlocks  => 0,
56              
57             LowerCaseNames        => 0,
58              
59             UseApacheInclude      => 0,
60             IncludeRelative       => 0,
61             IncludeDirectories    => 0,
62             IncludeGlob           => 0,
63              
64             AutoLaunder           => 0,
65              
66             AutoTrue              => 0,
67              
68             AutoTrueFlags         => {
69             true  => '^(on|yes|true|1)$',
70             false => '^(off|no|false|0)$',
71             },
72              
73             DefaultConfig         => {},
74              
75             level                 => 1,
76              
77             InterPolateVars       => 0,
78              
79             InterPolateEnv        => 0,
80              
81             ExtendedAccess        => 0,
82              
83             SplitPolicy           => 'guess', # also possible: whitespace, equalsign and custom
84              
85             SplitDelimiter        => 0, # must be set by the user if SplitPolicy is 'custom'
86              
87             StoreDelimiter        => 0, # will be set by me unless user uses 'custom' policy
88              
89             CComments             => 1, # by default turned on
90              
91             BackslashEscape       => 0, # by default turned off, allows escaping anything using the backslash
92              
93             StrictObjects         => 1, # be strict on non-existent keys in OOP mode
94              
95             StrictVars            => 1, # be strict on undefined variables in Interpolate mode
96              
97             Tie                   => q(), # could be set to a perl module for tie'ing new hashes
98              
99             parsed                => 0, # internal state stuff for variable interpolation
100             upperkey              => q(),
101             upperkeys             => [],
102             lastkey               => q(),
103             prevkey               => q( ),
104             files                 => {}, # which files we have read, if any
105             };
106              
107             # create the class instance
108 40         595   bless $self, $class;
109              
110              
111 40 100       612   if ($#param >= 1) {
    50          
112             # use of the new hash interface!
113 32         428     my %conf = @param;
114              
115             # save the parameter list for ::Extended's new() calls
116 32         512     $self->{Params} = \%conf;
117              
118             # be backwards compatible
119 32 100       377     if (exists $conf{-file}) {
120 6         80       $self->{ConfigFile} = delete $conf{-file};
121                 }
122 32 50       377     if (exists $conf{-hash}) {
123 0         0       $self->{ConfigHash} = delete $conf{-hash};
124                 }
125              
126             # store input, file, handle, or array
127 32 100       331     if (exists $conf{-ConfigFile}) {
128 8         99       $self->{ConfigFile} = delete $conf{-ConfigFile};
129                 }
130 32 100       376     if (exists $conf{-ConfigHash}) {
131 11         128       $self->{ConfigHash} = delete $conf{-ConfigHash};
132                 }
133              
134             # store search path for relative configs, if any
135 32 50       327     if (exists $conf{-ConfigPath}) {
136 0         0       my $configpath = delete $conf{-ConfigPath};
137 0 0       0       $self->{ConfigPath} = ref $configpath eq 'ARRAY' ? $configpath : [$configpath];
138                 }
139              
140             # handle options which contains values we are needing (strings, hashrefs or the like)
141 32 100       330     if (exists $conf{-String} ) {
142 7 100       87       if (ref(\$conf{-String}) eq 'SCALAR') {
143 6 50       67 if ( $conf{-String}) {
144 6         158 $self->{StringContent} = $conf{-String};
145             }
146 6         65 delete $conf{-String};
147                   }
148                   else {
149 1         14 croak "Parameter -String must be a SCALAR!\n";
150                   }
151                 }
152              
153 31 50       342     if (exists $conf{-Tie}) {
154 0 0       0       if ($conf{-Tie}) {
155 0         0 $self->{Tie} = delete $conf{-Tie};
156 0         0 $self->{DefaultConfig} = $self->_hashref();
157                   }
158                 }
159              
160 31 100       315     if (exists $conf{-FlagBits}) {
161 1 50 33     26       if ($conf{-FlagBits} && ref($conf{-FlagBits}) eq 'HASH') {
162 1         12 $self->{FlagBits} = 1;
163 1         12 $self->{FlagBitsFlags} = $conf{-FlagBits};
164                   }
165 1         261       delete $conf{-FlagBits};
166                 }
167              
168 31 100       385     if (exists $conf{-DefaultConfig}) {
169 2 100 66     92       if ($conf{-DefaultConfig} && ref($conf{-DefaultConfig}) eq 'HASH') {
    50 33        
170 1         13 $self->{DefaultConfig} = $conf{-DefaultConfig};
171                   }
172                   elsif ($conf{-DefaultConfig} && ref($conf{-DefaultConfig}) eq q()) {
173 1         16 $self->_read($conf{-DefaultConfig}, 'SCALAR');
174 1         12 $self->{DefaultConfig} = $self->_parse($self->_hashref(), $self->{content});
175 1         11 $self->{content} = ();
176                   }
177 2         90       delete $conf{-DefaultConfig};
178                 }
179              
180             # handle options which may either be true or false
181             # allowing "human" logic about what is true and what is not
182 31         383     foreach my $entry (keys %conf) {
183 28         337       my $key = $entry;
184 28         372       $key =~ s/^\-//;
185 28 50       366       if (! exists $self->{$key}) {
186 0         0 croak "Unknown parameter: $entry => \"$conf{$entry}\" (key: <$key>)\n";
187                   }
188 28 100       453       if ($conf{$entry} =~ /$self->{AutoTrueFlags}->{true}/io) {
    100          
189 25         303 $self->{$key} = 1;
190                   }
191                   elsif ($conf{$entry} =~ /$self->{AutoTrueFlags}->{false}/io) {
192 1         12 $self->{$key} = 0;
193                   }
194                   else {
195             # keep it untouched
196 2         24 $self->{$key} = $conf{$entry};
197                   }
198                 }
199              
200 31 100       383     if ($self->{MergeDuplicateOptions}) {
201             # override if not set by user
202 5 50       58       if (! exists $conf{-AllowMultiOptions}) {
203 5         75 $self->{AllowMultiOptions} = 0;
204                   }
205                 }
206               }
207               elsif ($#param == 0) {
208             # use of the old style
209 8         107     $self->{ConfigFile} = $param[0];
210 8 50       99     if (ref($self->{ConfigFile}) eq 'HASH') {
211 0         0       $self->{ConfigHash} = delete $self->{ConfigFile};
212                 }
213               }
214               else {
215             # this happens if $#param == -1,1 thus no param was given to new!
216 0         0     $self->{config} = $self->_hashref();
217 0         0     $self->{parsed} = 1;
218               }
219              
220             # prepare the split delimiter if needed
221 39 100       527   if ($self->{SplitPolicy} ne 'guess') {
222 1 50       18     if ($self->{SplitPolicy} eq 'whitespace') {
    50          
    50          
223 0         0       $self->{SplitDelimiter} = '\s+';
224 0 0       0       if (!$self->{StoreDelimiter}) {
225 0         0 $self->{StoreDelimiter} = q( );
226                   }
227                 }
228                 elsif ($self->{SplitPolicy} eq 'equalsign') {
229 0         0       $self->{SplitDelimiter} = '\s*=\s*';
230 0 0       0       if (!$self->{StoreDelimiter}) {
231 0         0 $self->{StoreDelimiter} = ' = ';
232                   }
233                 }
234                 elsif ($self->{SplitPolicy} eq 'custom') {
235 1 50       13       if (! $self->{SplitDelimiter} ) {
236 0         0 croak "SplitPolicy set to 'custom' but no SplitDelimiter set.\n";
237                   }
238                 }
239                 else {
240 0         0       croak "Unsupported SplitPolicy: $self->{SplitPolicy}.\n";
241                 }
242               }
243               else {
244 38 50       496     if (!$self->{StoreDelimiter}) {
245 38         418       $self->{StoreDelimiter} = q( );
246                 }
247               }
248              
249 39 100 66     677   if ($self->{InterPolateVars} || $self->{InterPolateEnv}) {
250             # InterPolateEnv implies InterPolateVars
251 1         10     $self->{InterPolateVars} = 1;
252              
253             # we are blessing here again, to get into the ::InterPolated namespace
254             # for inheriting the methods available overthere, which we doesn't have.
255             #
256 1         13     bless $self, 'Config::General::Interpolated';
257 1         9     eval {
258 1         33       require Config::General::Interpolated;
259                 };
260 1 50       15     if ($EVAL_ERROR) {
261 0         0       croak $EVAL_ERROR;
262                 }
263             # pre-compile the variable regexp
264 1         15     $self->{regex} = $self->_set_regex();
265               }
266              
267             # process as usual
268 39 50       407   if (!$self->{parsed}) {
269 39 100 66     540     if ($self->{DefaultConfig} && $self->{InterPolateVars}) {
270 1         14       $self->{DefaultConfig} = $self->_interpolate_hash($self->{DefaultConfig}); # FIXME: _hashref() ?
271                 }
272 39 100 33     580     if (exists $self->{StringContent}) {
    100          
    50          
273             # consider the supplied string as config file
274 6         79       $self->_read($self->{StringContent}, 'SCALAR');
275 6         81       $self->{config} = $self->_parse($self->{DefaultConfig}, $self->{content});
276                 }
277                 elsif (exists $self->{ConfigHash}) {
278 11 100       114       if (ref($self->{ConfigHash}) eq 'HASH') {
279             # initialize with given hash
280 10         94 $self->{config} = $self->{ConfigHash};
281 10         89 $self->{parsed} = 1;
282                   }
283                   else {
284 1         13 croak "Parameter -ConfigHash must be a hash reference!\n";
285                   }
286                 }
287                 elsif (ref($self->{ConfigFile}) eq 'GLOB' || ref($self->{ConfigFile}) eq 'FileHandle') {
288             # use the file the glob points to
289 0         0       $self->_read($self->{ConfigFile});
290 0         0       $self->{config} = $self->_parse($self->{DefaultConfig}, $self->{content});
291                 }
292                 else {
293 22 50       212       if ($self->{ConfigFile}) {
294             # open the file and read the contents in
295 22         223 $self->{configfile} = $self->{ConfigFile};
296 22 50       279 if ( file_name_is_absolute($self->{ConfigFile}) ) {
297             # look if is is an absolute path and save the basename if it is absolute
298 0         0 my ($volume, $path, undef) = splitpath($self->{ConfigFile});
299 0         0 $path =~ s#/$##; # remove eventually existing trailing slash
300 0 0       0 if (! $self->{ConfigPath}) {
301 0         0 $self->{ConfigPath} = [];
302             }
303 0         0 unshift @{$self->{ConfigPath}}, catpath($volume, $path, q());
  0         0  
304             }
305 22         899 $self->_open($self->{configfile});
306           </