Filename | /home/ss5/perl5/perlbrew/perls/perl-5.14.1/lib/site_perl/5.14.1/Config/General.pm |
Statements | Executed 27 statements in 29.5ms |
Calls | P | F | Exclusive Time |
Inclusive Time |
Subroutine |
---|---|---|---|---|---|
1 | 1 | 1 | 3.68ms | 12.1ms | BEGIN@17 | Config::General::
1 | 1 | 1 | 3.47ms | 39.6ms | BEGIN@19 | Config::General::
1 | 1 | 1 | 3.39ms | 8.37ms | BEGIN@22 | Config::General::
1 | 1 | 1 | 2.72ms | 6.08ms | BEGIN@20 | Config::General::
1 | 1 | 1 | 1.95ms | 3.03ms | BEGIN@21 | Config::General::
1 | 1 | 1 | 518µs | 561µs | BEGIN@29 | Config::General::
1 | 1 | 1 | 59µs | 76µs | BEGIN@15 | Config::General::
1 | 1 | 1 | 36µs | 205µs | BEGIN@32 | Config::General::
1 | 1 | 1 | 36µs | 63µs | BEGIN@16 | Config::General::
1 | 1 | 1 | 35µs | 300µs | BEGIN@38 | Config::General::
1 | 1 | 1 | 34µs | 89µs | BEGIN@33 | Config::General::
1 | 1 | 1 | 31µs | 170µs | BEGIN@37 | Config::General::
0 | 0 | 0 | 0s | 0s | NoMultiOptions | Config::General::
0 | 0 | 0 | 0s | 0s | ParseConfig | Config::General::
0 | 0 | 0 | 0s | 0s | SaveConfig | Config::General::
0 | 0 | 0 | 0s | 0s | SaveConfigString | Config::General::
0 | 0 | 0 | 0s | 0s | _blessoop | Config::General::
0 | 0 | 0 | 0s | 0s | _blessvars | Config::General::
0 | 0 | 0 | 0s | 0s | _copy | Config::General::
0 | 0 | 0 | 0s | 0s | _hashref | Config::General::
0 | 0 | 0 | 0s | 0s | _open | Config::General::
0 | 0 | 0 | 0s | 0s | _parse | Config::General::
0 | 0 | 0 | 0s | 0s | _parse_value | Config::General::
0 | 0 | 0 | 0s | 0s | _prepare | Config::General::
0 | 0 | 0 | 0s | 0s | _process | Config::General::
0 | 0 | 0 | 0s | 0s | _read | Config::General::
0 | 0 | 0 | 0s | 0s | _splitpolicy | Config::General::
0 | 0 | 0 | 0s | 0s | _store | Config::General::
0 | 0 | 0 | 0s | 0s | _write_hash | Config::General::
0 | 0 | 0 | 0s | 0s | _write_scalar | Config::General::
0 | 0 | 0 | 0s | 0s | files | Config::General::
0 | 0 | 0 | 0s | 0s | getall | Config::General::
0 | 0 | 0 | 0s | 0s | new | Config::General::
0 | 0 | 0 | 0s | 0s | save | Config::General::
0 | 0 | 0 | 0s | 0s | save_file | Config::General::
0 | 0 | 0 | 0s | 0s | save_string | Config::General::
Line | State ments |
Time on line |
Calls | Time in subs |
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-2010 Thomas Linden <tlinden |AT| cpan.org>. | ||||
9 | # All Rights Reserved. Std. disclaimer applies. | ||||
10 | # Artistic License, same as perl itself. Have fun. | ||||
11 | # | ||||
12 | # namespace | ||||
13 | package Config::General; | ||||
14 | |||||
15 | 2 | 100µs | 2 | 93µs | # spent 76µs (59+17) within Config::General::BEGIN@15 which was called:
# once (59µs+17µs) by main::BEGIN@11 at line 15 # spent 76µs making 1 call to Config::General::BEGIN@15
# spent 17µs making 1 call to strict::import |
16 | 2 | 106µs | 2 | 91µs | # spent 63µs (36+28) within Config::General::BEGIN@16 which was called:
# once (36µs+28µs) by main::BEGIN@11 at line 16 # spent 63µs making 1 call to Config::General::BEGIN@16
# spent 28µs making 1 call to warnings::import |
17 | 2 | 688µs | 2 | 14.1ms | # spent 12.1ms (3.68+8.46) within Config::General::BEGIN@17 which was called:
# once (3.68ms+8.46ms) by main::BEGIN@11 at line 17 # spent 12.1ms making 1 call to Config::General::BEGIN@17
# spent 1.95ms making 1 call to English::import |
18 | |||||
19 | 2 | 881µs | 2 | 40.2ms | # spent 39.6ms (3.47+36.1) within Config::General::BEGIN@19 which was called:
# once (3.47ms+36.1ms) by main::BEGIN@11 at line 19 # spent 39.6ms making 1 call to Config::General::BEGIN@19
# spent 569µs making 1 call to Exporter::import |
20 | 2 | 562µs | 2 | 8.51ms | # spent 6.08ms (2.72+3.36) within Config::General::BEGIN@20 which was called:
# once (2.72ms+3.36ms) by main::BEGIN@11 at line 20 # spent 6.08ms making 1 call to Config::General::BEGIN@20
# spent 2.43ms making 1 call to FileHandle::import |
21 | 2 | 612µs | 2 | 3.37ms | # spent 3.03ms (1.95+1.08) within Config::General::BEGIN@21 which was called:
# once (1.95ms+1.08ms) by main::BEGIN@11 at line 21 # spent 3.03ms making 1 call to Config::General::BEGIN@21
# spent 344µs making 1 call to Exporter::import |
22 | 2 | 558µs | 2 | 9.48ms | # spent 8.37ms (3.39+4.98) within Config::General::BEGIN@22 which was called:
# once (3.39ms+4.98ms) by main::BEGIN@11 at line 22 # spent 8.37ms making 1 call to Config::General::BEGIN@22
# spent 1.11ms making 1 call to File::Glob::import |
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 | 2 | 458µs | 1 | 561µs | # spent 561µs (518+43) within Config::General::BEGIN@29 which was called:
# once (518µs+43µs) by main::BEGIN@11 at line 29 # spent 561µs making 1 call to Config::General::BEGIN@29 |
30 | |||||
31 | |||||
32 | 2 | 102µs | 2 | 374µs | # spent 205µs (36+169) within Config::General::BEGIN@32 which was called:
# once (36µs+169µs) by main::BEGIN@11 at line 32 # spent 205µs making 1 call to Config::General::BEGIN@32
# spent 169µs making 1 call to Exporter::import |
33 | 2 | 146µs | 2 | 144µs | # spent 89µs (34+55) within Config::General::BEGIN@33 which was called:
# once (34µs+55µs) by main::BEGIN@11 at line 33 # spent 89µs making 1 call to Config::General::BEGIN@33
# spent 55µs making 1 call to Exporter::import |
34 | |||||
35 | 1 | 4µs | $Config::General::VERSION = "2.50"; | ||
36 | |||||
37 | 2 | 103µs | 2 | 310µs | # spent 170µs (31+139) within Config::General::BEGIN@37 which was called:
# once (31µs+139µs) by main::BEGIN@11 at line 37 # spent 170µs making 1 call to Config::General::BEGIN@37
# spent 139µs making 1 call to vars::import |
38 | 2 | 25.2ms | 2 | 566µs | # spent 300µs (35+265) within Config::General::BEGIN@38 which was called:
# once (35µs+265µs) by main::BEGIN@11 at line 38 # spent 300µs making 1 call to Config::General::BEGIN@38
# spent 265µs making 1 call to base::import |
39 | 1 | 11µs | @EXPORT_OK = qw(ParseConfig SaveConfig SaveConfigString); | ||
40 | |||||
41 | sub new { | ||||
42 | # | ||||
43 | # create new Config::General object | ||||
44 | # | ||||
45 | my($this, @param ) = @_; | ||||
46 | my $class = ref($this) || $this; | ||||
47 | |||||
48 | # define default options | ||||
49 | my $self = { | ||||
50 | # sha256 of current date | ||||
51 | # hopefully this lowers the probability that | ||||
52 | # this matches any configuration key or value out there | ||||
53 | # bugfix for rt.40925 | ||||
54 | EOFseparator => 'ad7d7b87f5b81d2a0d5cb75294afeb91aa4801b1f8e8532dc1b633c0e1d47037', | ||||
55 | SlashIsDirectory => 0, | ||||
56 | AllowMultiOptions => 1, | ||||
57 | MergeDuplicateOptions => 0, | ||||
58 | MergeDuplicateBlocks => 0, | ||||
59 | LowerCaseNames => 0, | ||||
60 | ApacheCompatible => 0, | ||||
61 | UseApacheInclude => 0, | ||||
62 | IncludeRelative => 0, | ||||
63 | IncludeDirectories => 0, | ||||
64 | IncludeGlob => 0, | ||||
65 | IncludeAgain => 0, | ||||
66 | AutoLaunder => 0, | ||||
67 | AutoTrue => 0, | ||||
68 | AutoTrueFlags => { | ||||
69 | true => '^(on|yes|true|1)$', | ||||
70 | false => '^(off|no|false|0)$', | ||||
71 | }, | ||||
72 | DefaultConfig => {}, | ||||
73 | String => '', | ||||
74 | level => 1, | ||||
75 | InterPolateVars => 0, | ||||
76 | InterPolateEnv => 0, | ||||
77 | ExtendedAccess => 0, | ||||
78 | SplitPolicy => 'guess', # also possible: whitespace, equalsign and custom | ||||
79 | SplitDelimiter => 0, # must be set by the user if SplitPolicy is 'custom' | ||||
80 | StoreDelimiter => 0, # will be set by me unless user uses 'custom' policy | ||||
81 | CComments => 1, # by default turned on | ||||
82 | BackslashEscape => 0, # deprecated | ||||
83 | StrictObjects => 1, # be strict on non-existent keys in OOP mode | ||||
84 | StrictVars => 1, # be strict on undefined variables in Interpolate mode | ||||
85 | Tie => q(), # could be set to a perl module for tie'ing new hashes | ||||
86 | parsed => 0, # internal state stuff for variable interpolation | ||||
87 | files => {}, # which files we have read, if any | ||||
88 | UTF8 => 0, | ||||
89 | SaveSorted => 0, | ||||
90 | ForceArray => 0, # force single value array if value enclosed in [] | ||||
91 | AllowSingleQuoteInterpolation => 0 | ||||
92 | }; | ||||
93 | |||||
94 | # create the class instance | ||||
95 | bless $self, $class; | ||||
96 | |||||
97 | if ($#param >= 1) { | ||||
98 | # use of the new hash interface! | ||||
99 | $self->_prepare(@param); | ||||
100 | } | ||||
101 | elsif ($#param == 0) { | ||||
102 | # use of the old style | ||||
103 | $self->{ConfigFile} = $param[0]; | ||||
104 | if (ref($self->{ConfigFile}) eq 'HASH') { | ||||
105 | $self->{ConfigHash} = delete $self->{ConfigFile}; | ||||
106 | } | ||||
107 | } | ||||
108 | else { | ||||
109 | # this happens if $#param == -1,1 thus no param was given to new! | ||||
110 | $self->{config} = $self->_hashref(); | ||||
111 | $self->{parsed} = 1; | ||||
112 | } | ||||
113 | |||||
114 | # find split policy to use for option/value separation | ||||
115 | $self->_splitpolicy(); | ||||
116 | |||||
117 | # bless into variable interpolation module if neccessary | ||||
118 | $self->_blessvars(); | ||||
119 | |||||
120 | # process as usual | ||||
121 | if (!$self->{parsed}) { | ||||
122 | $self->_process(); | ||||
123 | } | ||||
124 | |||||
125 | if ($self->{InterPolateVars}) { | ||||
126 | $self->{config} = $self->_clean_stack($self->{config}); | ||||
127 | } | ||||
128 | |||||
129 | # bless into OOP namespace if required | ||||
130 | $self->_blessoop(); | ||||
131 | |||||
132 | return $self; | ||||
133 | } | ||||
134 | |||||
- - | |||||
137 | sub _process { | ||||
138 | # | ||||
139 | # call _read() and _parse() on the given config | ||||
140 | my($self) = @_; | ||||
141 | |||||
142 | if ($self->{DefaultConfig} && $self->{InterPolateVars}) { | ||||
143 | $self->{DefaultConfig} = $self->_interpolate_hash($self->{DefaultConfig}); # FIXME: _hashref() ? | ||||
144 | } | ||||
145 | if (exists $self->{StringContent}) { | ||||
146 | # consider the supplied string as config file | ||||
147 | $self->_read($self->{StringContent}, 'SCALAR'); | ||||
148 | $self->{config} = $self->_parse($self->{DefaultConfig}, $self->{content}); | ||||
149 | } | ||||
150 | elsif (exists $self->{ConfigHash}) { | ||||
151 | if (ref($self->{ConfigHash}) eq 'HASH') { | ||||
152 | # initialize with given hash | ||||
153 | $self->{config} = $self->{ConfigHash}; | ||||
154 | $self->{parsed} = 1; | ||||
155 | } | ||||
156 | else { | ||||
157 | croak "Config::General: Parameter -ConfigHash must be a hash reference!\n"; | ||||
158 | } | ||||
159 | } | ||||
160 | elsif (ref($self->{ConfigFile}) eq 'GLOB' || ref($self->{ConfigFile}) eq 'FileHandle') { | ||||
161 | # use the file the glob points to | ||||
162 | $self->_read($self->{ConfigFile}); | ||||
163 | $self->{config} = $self->_parse($self->{DefaultConfig}, $self->{content}); | ||||
164 | } | ||||
165 | else { | ||||
166 | if ($self->{ConfigFile}) { | ||||
167 | # open the file and read the contents in | ||||
168 | $self->{configfile} = $self->{ConfigFile}; | ||||
169 | if ( file_name_is_absolute($self->{ConfigFile}) ) { | ||||
170 | # look if is is an absolute path and save the basename if it is absolute | ||||
171 | my ($volume, $path, undef) = splitpath($self->{ConfigFile}); | ||||
172 | $path =~ s#/$##; # remove eventually existing trailing slash | ||||
173 | if (! $self->{ConfigPath}) { | ||||
174 | $self->{ConfigPath} = []; | ||||
175 | } | ||||
176 | unshift @{$self->{ConfigPath}}, catpath($volume, $path, q()); | ||||
177 | } | ||||
178 | $self->_open($self->{configfile}); | ||||
179 | # now, we parse immdediately, getall simply returns the whole hash | ||||
180 | $self->{config} = $self->_hashref(); | ||||
181 | $self->{config} = $self->_parse($self->{DefaultConfig}, $self->{content}); | ||||
182 | } | ||||
183 | else { | ||||
184 | # hm, no valid config file given, so try it as an empty object | ||||
185 | $self->{config} = $self->_hashref(); | ||||
186 | $self->{parsed} = 1; | ||||
187 | } | ||||
188 | } | ||||
189 | } | ||||
190 | |||||
191 | |||||
192 | sub _blessoop { | ||||
193 | # | ||||
194 | # bless into ::Extended if neccessary | ||||
195 | my($self) = @_; | ||||
196 | if ($self->{ExtendedAccess}) { | ||||
197 | # we are blessing here again, to get into the ::Extended namespace | ||||
198 | # for inheriting the methods available overthere, which we doesn't have. | ||||
199 | bless $self, 'Config::General::Extended'; | ||||
200 | eval { | ||||
201 | require Config::General::Extended; | ||||
202 | }; | ||||
203 | if ($EVAL_ERROR) { | ||||
204 | croak "Config::General: " . $EVAL_ERROR; | ||||
205 | } | ||||
206 | } | ||||
207 | # return $self; | ||||
208 | } | ||||
209 | |||||
210 | sub _blessvars { | ||||
211 | # | ||||
212 | # bless into ::Interpolated if neccessary | ||||
213 | my($self) = @_; | ||||
214 | if ($self->{InterPolateVars} || $self->{InterPolateEnv}) { | ||||
215 | # InterPolateEnv implies InterPolateVars | ||||
216 | $self->{InterPolateVars} = 1; | ||||
217 | |||||
218 | # we are blessing here again, to get into the ::InterPolated namespace | ||||
219 | # for inheriting the methods available overthere, which we doesn't have here. | ||||
220 | bless $self, 'Config::General::Interpolated'; | ||||
221 | eval { | ||||
222 | require Config::General::Interpolated; | ||||
223 | }; | ||||
224 | if ($EVAL_ERROR) { | ||||
225 | croak "Config::General: " . $EVAL_ERROR; | ||||
226 | } | ||||
227 | # pre-compile the variable regexp | ||||
228 | $self->{regex} = $self->_set_regex(); | ||||
229 | } | ||||
230 | # return $self; | ||||
231 | } | ||||
232 | |||||
233 | |||||
234 | sub _splitpolicy { | ||||
235 | # | ||||
236 | # find out what split policy to use | ||||
237 | my($self) = @_; | ||||
238 | if ($self->{SplitPolicy} ne 'guess') { | ||||
239 | if ($self->{SplitPolicy} eq 'whitespace') { | ||||
240 | $self->{SplitDelimiter} = '\s+'; | ||||
241 | if (!$self->{StoreDelimiter}) { | ||||
242 | $self->{StoreDelimiter} = q( ); | ||||
243 | } | ||||
244 | } | ||||
245 | elsif ($self->{SplitPolicy} eq 'equalsign') { | ||||
246 | $self->{SplitDelimiter} = '\s*=\s*'; | ||||
247 | if (!$self->{StoreDelimiter}) { | ||||
248 | $self->{StoreDelimiter} = ' = '; | ||||
249 | } | ||||
250 | } | ||||
251 | elsif ($self->{SplitPolicy} eq 'custom') { | ||||
252 | if (! $self->{SplitDelimiter} ) { | ||||
253 | croak "Config::General: SplitPolicy set to 'custom' but no SplitDelimiter set.\n"; | ||||
254 | } | ||||
255 | } | ||||
256 | else { | ||||
257 | croak "Config::General: Unsupported SplitPolicy: $self->{SplitPolicy}.\n"; | ||||
258 | } | ||||
259 | } | ||||
260 | else { | ||||
261 | if (!$self->{StoreDelimiter}) { | ||||
262 | $self->{StoreDelimiter} = q( ); | ||||
263 | } | ||||
264 | } | ||||
265 | } | ||||
266 | |||||
267 | sub _prepare { | ||||
268 | # | ||||
269 | # prepare the class parameters, mangle them, if there | ||||
270 | # are options to reset or to override, do it here. | ||||
271 | my ($self, %conf) = @_; | ||||
272 | |||||
273 | # save the parameter list for ::Extended's new() calls | ||||
274 | $self->{Params} = \%conf; | ||||
275 | |||||
276 | # be backwards compatible | ||||
277 | if (exists $conf{-file}) { | ||||
278 | $self->{ConfigFile} = delete $conf{-file}; | ||||
279 | } | ||||
280 | if (exists $conf{-hash}) { | ||||
281 | $self->{ConfigHash} = delete $conf{-hash}; | ||||
282 | } | ||||
283 | |||||
284 | # store input, file, handle, or array | ||||
285 | if (exists $conf{-ConfigFile}) { | ||||
286 | $self->{ConfigFile} = delete $conf{-ConfigFile}; | ||||
287 | } | ||||
288 | if (exists $conf{-ConfigHash}) { | ||||
289 | $self->{ConfigHash} = delete $conf{-ConfigHash}; | ||||
290 | } | ||||
291 | |||||
292 | # store search path for relative configs, if any | ||||
293 | if (exists $conf{-ConfigPath}) { | ||||
294 | my $configpath = delete $conf{-ConfigPath}; | ||||
295 | $self->{ConfigPath} = ref $configpath eq 'ARRAY' ? $configpath : [$configpath]; | ||||
296 | } | ||||
297 | |||||
298 | # handle options which contains values we need (strings, hashrefs or the like) | ||||
299 | if (exists $conf{-String} ) { | ||||
300 | #if (ref(\$conf{-String}) eq 'SCALAR') { | ||||
301 | if (not ref $conf{-String}) { | ||||
302 | if ( $conf{-String}) { | ||||
303 | $self->{StringContent} = $conf{-String}; | ||||
304 | } | ||||
305 | delete $conf{-String}; | ||||
306 | } | ||||
307 | # re-implement arrayref support, removed after 2.22 as _read were | ||||
308 | # re-organized | ||||
309 | # fixed bug#33385 | ||||
310 | elsif(ref($conf{-String}) eq 'ARRAY') { | ||||
311 | $self->{StringContent} = join "\n", @{$conf{-String}}; | ||||
312 | } | ||||
313 | else { | ||||
314 | croak "Config::General: Parameter -String must be a SCALAR or ARRAYREF!\n"; | ||||
315 | } | ||||
316 | delete $conf{-String}; | ||||
317 | } | ||||
318 | if (exists $conf{-Tie}) { | ||||
319 | if ($conf{-Tie}) { | ||||
320 | $self->{Tie} = delete $conf{-Tie}; | ||||
321 | $self->{DefaultConfig} = $self->_hashref(); | ||||
322 | } | ||||
323 | } | ||||
324 | |||||
325 | if (exists $conf{-FlagBits}) { | ||||
326 | if ($conf{-FlagBits} && ref($conf{-FlagBits}) eq 'HASH') { | ||||
327 | $self->{FlagBits} = 1; | ||||
328 | $self->{FlagBitsFlags} = $conf{-FlagBits}; | ||||
329 | } | ||||
330 | delete $conf{-FlagBits}; | ||||
331 | } | ||||
332 | |||||
333 | if (exists $conf{-DefaultConfig}) { | ||||
334 | if ($conf{-DefaultConfig} && ref($conf{-DefaultConfig}) eq 'HASH') { | ||||
335 | $self->{DefaultConfig} = $conf{-DefaultConfig}; | ||||
336 | } | ||||
337 | elsif ($conf{-DefaultConfig} && ref($conf{-DefaultConfig}) eq q()) { | ||||
338 | $self->_read($conf{-DefaultConfig}, 'SCALAR'); | ||||
339 | $self->{DefaultConfig} = $self->_parse($self->_hashref(), $self->{content}); | ||||
340 | $self->{content} = (); | ||||
341 | } | ||||
342 | delete $conf{-DefaultConfig}; | ||||
343 | } | ||||
344 | |||||
345 | # handle options which may either be true or false | ||||
346 | # allowing "human" logic about what is true and what is not | ||||
347 | foreach my $entry (keys %conf) { | ||||
348 | my $key = $entry; | ||||
349 | $key =~ s/^\-//; | ||||
350 | if (! exists $self->{$key}) { | ||||
351 | croak "Config::General: Unknown parameter: $entry => \"$conf{$entry}\" (key: <$key>)\n"; | ||||
352 | } | ||||
353 | if ($conf{$entry} =~ /$self->{AutoTrueFlags}->{true}/io) { | ||||
354 | $self->{$key} = 1; | ||||
355 | } | ||||
356 | elsif ($conf{$entry} =~ /$self->{AutoTrueFlags}->{false}/io) { | ||||
357 | $self->{$key} = 0; | ||||
358 | } | ||||
359 | else { | ||||
360 | # keep it untouched | ||||
361 | $self->{$key} = $conf{$entry}; | ||||
362 | } | ||||
363 | } | ||||
364 | |||||
365 | if ($self->{MergeDuplicateOptions}) { | ||||
366 | # override if not set by user | ||||
367 | if (! exists $conf{-AllowMultiOptions}) { | ||||
368 | $self->{AllowMultiOptions} = 0; | ||||
369 | } | ||||
370 | } | ||||
371 | |||||
372 | if ($self->{ApacheCompatible}) { | ||||
373 | # turn on all apache compatibility options which has | ||||
374 | # been incorporated during the years... | ||||
375 | $self->{UseApacheInclude} = 1; | ||||
376 | $self->{IncludeRelative} = 1; | ||||
377 | $self->{IncludeDirectories} = 1; | ||||
378 | $self->{IncludeGlob} = 1; | ||||
379 | $self->{SlashIsDirectory} = 1; | ||||
380 | $self->{SplitPolicy} = 'whitespace'; | ||||
381 | $self->{CComments} = 0; | ||||
382 | } | ||||
383 | } | ||||
384 | |||||
385 | sub getall { | ||||
386 | # | ||||
387 | # just return the whole config hash | ||||
388 | # | ||||
389 | my($this) = @_; | ||||
390 | return (exists $this->{config} ? %{$this->{config}} : () ); | ||||
391 | } | ||||
392 | |||||
393 | |||||
394 | sub files { | ||||
395 | # | ||||
396 | # return a list of files opened so far | ||||
397 | # | ||||
398 | my($this) = @_; | ||||
399 | return (exists $this->{files} ? keys %{$this->{files}} : () ); | ||||
400 | } | ||||
401 | |||||
402 | |||||
403 | sub _open { | ||||
404 | # | ||||
405 | # open the config file, or expand a directory or glob | ||||
406 | # | ||||
407 | my($this, $basefile, $basepath) = @_; | ||||
408 | my($fh, $configfile); | ||||
409 | |||||
410 | if($basepath) { | ||||
411 | # if this doesn't work we can still try later the global config path to use | ||||
412 | $configfile = catfile($basepath, $basefile); | ||||
413 | } | ||||
414 | else { | ||||
415 | $configfile = $basefile; | ||||
416 | } | ||||
417 | |||||
418 | if ($this->{IncludeGlob} and $configfile =~ /[*?\[\{\\]/) { | ||||
419 | # Something like: *.conf (or maybe dir/*.conf) was included; expand it and | ||||
420 | # pass each expansion through this method again. | ||||
421 | my @include = grep { -f $_ } bsd_glob($configfile, GLOB_BRACE | GLOB_QUOTE); | ||||
422 | |||||
423 | # applied patch by AlexK fixing rt.cpan.org#41030 | ||||
424 | if ( !@include && defined $this->{ConfigPath} ) { | ||||
425 | foreach my $dir (@{$this->{ConfigPath}}) { | ||||
426 | my ($volume, $path, undef) = splitpath($basefile); | ||||
427 | if ( -d catfile( $dir, $path ) ) { | ||||
428 | push @include, grep { -f $_ } bsd_glob(catfile($dir, $basefile), GLOB_BRACE | GLOB_QUOTE); | ||||
429 | last; | ||||
430 | } | ||||
431 | } | ||||
432 | } | ||||
433 | |||||
434 | if (@include == 1) { | ||||
435 | $configfile = $include[0]; | ||||
436 | } | ||||
437 | else { | ||||
438 | # Multiple results or no expansion results (which is fine, | ||||
439 | # include foo/* shouldn't fail if there isn't anything matching) | ||||
440 | local $this->{IncludeGlob}; | ||||
441 | for (@include) { | ||||
442 | $this->_open($_); | ||||
443 | } | ||||
444 | return; | ||||
445 | } | ||||
446 | } | ||||
447 | |||||
448 | if (!-e $configfile) { | ||||
449 | my $found; | ||||
450 | if (defined $this->{ConfigPath}) { | ||||
451 | # try to find the file within ConfigPath | ||||
452 | foreach my $dir (@{$this->{ConfigPath}}) { | ||||
453 | if( -e catfile($dir, $basefile) ) { | ||||
454 | $configfile = catfile($dir, $basefile); | ||||
455 | $found = 1; | ||||
456 | last; # found it | ||||
457 | } | ||||
458 | } | ||||
459 | } | ||||
460 | if (!$found) { | ||||
461 | my $path_message = defined $this->{ConfigPath} ? q( within ConfigPath: ) . join(q(.), @{$this->{ConfigPath}}) : q(); | ||||
462 | croak qq{Config::General The file "$basefile" does not exist$path_message!}; | ||||
463 | } | ||||
464 | } | ||||
465 | |||||
466 | local ($RS) = $RS; | ||||
467 | if (! $RS) { | ||||
468 | carp(q(\$RS (INPUT_RECORD_SEPARATOR) is undefined. Guessing you want a line feed character)); | ||||
469 | $RS = "\n"; | ||||
470 | } | ||||
471 | |||||
472 | if (-d $configfile and $this->{IncludeDirectories}) { | ||||
473 | # A directory was included; include all the files inside that directory in ASCII order | ||||
474 | local *INCLUDEDIR; | ||||
475 | opendir INCLUDEDIR, $configfile or croak "Config::General: Could not open directory $configfile!($!)\n"; | ||||
476 | my @files = sort grep { -f catfile($configfile, $_) } catfile($configfile, $_), readdir INCLUDEDIR; | ||||
477 | closedir INCLUDEDIR; | ||||
478 | local $this->{CurrentConfigFilePath} = $configfile; | ||||
479 | for (@files) { | ||||
480 | my $file = catfile($configfile, $_); | ||||
481 | if (! exists $this->{files}->{$file} or $this->{IncludeAgain} ) { | ||||
482 | # support re-read if used urged us to do so, otherwise ignore the file | ||||
483 | if ($this->{UTF8}) { | ||||
484 | $fh = new IO::File; | ||||
485 | open( $fh, "<:utf8", $file) | ||||
486 | or croak "Config::General: Could not open $file in UTF8 mode!($!)\n"; | ||||
487 | } | ||||
488 | else { | ||||
489 | $fh = IO::File->new( $file, 'r') or croak "Config::General: Could not open $file!($!)\n"; | ||||
490 | } | ||||
491 | $this->{files}->{"$file"} = 1; | ||||
492 | $this->_read($fh); | ||||
493 | } | ||||
494 | else { | ||||
495 | warn "File $file already loaded. Use -IncludeAgain to load it again.\n"; | ||||
496 | } | ||||
497 | } | ||||
498 | } | ||||
499 | elsif (-d $configfile) { | ||||
500 | croak "Config::General: config file argument is a directory, expecting a file!\n"; | ||||
501 | } | ||||
502 | elsif (-e _) { | ||||
503 | if (exists $this->{files}->{$configfile} and not $this->{IncludeAgain}) { | ||||
504 | # do not read the same file twice, just return | ||||
505 | warn "File $configfile already loaded. Use -IncludeAgain to load it again.\n"; | ||||
506 | return; | ||||
507 | } | ||||
508 | else { | ||||
509 | if ($this->{UTF8}) { | ||||
510 | $fh = new IO::File; | ||||
511 | open( $fh, "<:utf8", $configfile) | ||||
512 | or croak "Config::General: Could not open $configfile in UTF8 mode!($!)\n"; | ||||
513 | } | ||||
514 | else { | ||||
515 | $fh = IO::File->new( "$configfile", 'r') | ||||
516 | or croak "Config::General: Could not open $configfile!($!)\n"; | ||||
517 | } | ||||
518 | |||||
519 | $this->{files}->{$configfile} = 1; | ||||
520 | |||||
521 | my ($volume, $path, undef) = splitpath($configfile); | ||||
522 | local $this->{CurrentConfigFilePath} = catpath($volume, $path, q()); | ||||
523 | |||||
524 | $this->_read($fh); | ||||
525 | } | ||||
526 | } | ||||
527 | return; | ||||
528 | } | ||||
529 | |||||
530 | |||||
531 | sub _read { | ||||
532 | # | ||||
533 | # store the config contents in @content | ||||
534 | # and prepare it somewhat for easier parsing later | ||||
535 | # (comments, continuing lines, and stuff) | ||||
536 | # | ||||
537 | my($this, $fh, $flag) = @_; | ||||
538 | my(@stuff, @content, $c_comment, $longline, $hier, $hierend, @hierdoc); | ||||
539 | local $_ = q(); | ||||
540 | |||||
541 | if ($flag && $flag eq 'SCALAR') { | ||||
542 | if (ref($fh) eq 'ARRAY') { | ||||
543 | @stuff = @{$fh}; | ||||
544 | } | ||||
545 | else { | ||||
546 | @stuff = split /\n/, $fh; | ||||
547 | } | ||||
548 | } | ||||
549 | else { | ||||
550 | @stuff = <$fh>; | ||||
551 | } | ||||
552 | |||||
553 | foreach (@stuff) { | ||||
554 | if ($this->{AutoLaunder}) { | ||||
555 | if (m/^(.*)$/) { | ||||
556 | $_ = $1; | ||||
557 | } | ||||
558 | } | ||||
559 | |||||
560 | chomp; | ||||
561 | |||||
562 | if ($this->{CComments}) { | ||||
563 | # look for C-Style comments, if activated | ||||
564 | if (/(\s*\/\*.*\*\/\s*)/) { | ||||
565 | # single c-comment on one line | ||||
566 | s/\s*\/\*.*\*\/\s*//; | ||||
567 | } | ||||
568 | elsif (/^\s*\/\*/) { | ||||
569 | # the beginning of a C-comment ("/*"), from now on ignore everything. | ||||
570 | if (/\*\/\s*$/) { | ||||
571 | # C-comment end is already there, so just ignore this line! | ||||
572 | $c_comment = 0; | ||||
573 | } | ||||
574 | else { | ||||
575 | $c_comment = 1; | ||||
576 | } | ||||
577 | } | ||||
578 | elsif (/\*\//) { | ||||
579 | if (!$c_comment) { | ||||
580 | warn "invalid syntax: found end of C-comment without previous start!\n"; | ||||
581 | } | ||||
582 | $c_comment = 0; # the current C-comment ends here, go on | ||||
583 | s/^.*\*\///; # if there is still stuff, it will be read | ||||
584 | } | ||||
585 | next if($c_comment); # ignore EVERYTHING from now on, IF it IS a C-Comment | ||||
586 | } | ||||
587 | |||||
588 | |||||
589 | if ($hier) { | ||||
590 | # inside here-doc, only look for $hierend marker | ||||
591 | if (/^(\s*)\Q$hierend\E\s*$/) { | ||||
592 | my $indent = $1; # preserve indentation | ||||
593 | $hier .= ' ' . $this->{EOFseparator}; # bugfix of rt.40925 | ||||
594 | # _parse will also preserver indentation | ||||
595 | if ($indent) { | ||||
596 | foreach (@hierdoc) { | ||||
597 | s/^$indent//; # i.e. the end was: " EOF" then we remove " " from every here-doc line | ||||
598 | $hier .= $_ . "\n"; # and store it in $hier | ||||
599 | } | ||||
600 | } | ||||
601 | else { | ||||
602 | $hier .= join "\n", @hierdoc; # there was no indentation of the end-string, so join it 1:1 | ||||
603 | } | ||||
604 | push @{$this->{content}}, $hier; # push it onto the content stack | ||||
605 | @hierdoc = (); | ||||
606 | undef $hier; | ||||
607 | undef $hierend; | ||||
608 | } | ||||
609 | else { | ||||
610 | # everything else onto the stack | ||||
611 | push @hierdoc, $_; | ||||
612 | } | ||||
613 | next; | ||||
614 | } | ||||
615 | |||||
616 | ### | ||||
617 | ### non-heredoc entries from now on | ||||
618 | ## | ||||
619 | |||||
620 | # Remove comments and empty lines | ||||
621 | s/(?<!\\)#.*$//; # .+ => .* bugfix rt.cpan.org#44600 | ||||
622 | next if /^\s*#/; | ||||
623 | next if /^\s*$/; | ||||
624 | |||||
625 | |||||
626 | # look for multiline option, indicated by a trailing backslash | ||||
627 | #my $extra = $this->{BackslashEscape} ? '(?<!\\\\)' : q(); | ||||
628 | #if (/$extra\\$/) { | ||||
629 | if (/(?<!\\)\\$/) { | ||||
630 | chop; | ||||
631 | s/^\s*//; | ||||
632 | $longline .= $_; | ||||
633 | next; | ||||
634 | } | ||||
635 | |||||
636 | # remove the \ from all characters if BackslashEscape is turned on | ||||
637 | # FIXME (rt.cpan.org#33218 | ||||
638 | #if ($this->{BackslashEscape}) { | ||||
639 | # s/\\(.)/$1/g; | ||||
640 | #} | ||||
641 | #else { | ||||
642 | # # remove the \ char in front of masked "#", if any | ||||
643 | # s/\\#/#/g; | ||||
644 | #} | ||||
645 | |||||
646 | |||||
647 | # transform explicit-empty blocks to conforming blocks | ||||
648 | if (!$this->{ApacheCompatible} && /\s*<([^\/]+?.*?)\/>$/) { | ||||
649 | my $block = $1; | ||||
650 | if ($block !~ /\"/) { | ||||
651 | if ($block !~ /\s[^\s]/) { | ||||
652 | # fix of bug 7957, add quotation to pure slash at the | ||||
653 | # end of a block so that it will be considered as directory | ||||
654 | # unless the block is already quoted or contains whitespaces | ||||
655 | # and no quotes. | ||||
656 | if ($this->{SlashIsDirectory}) { | ||||
657 | push @{$this->{content}}, '<' . $block . '"/">'; | ||||
658 | next; | ||||
659 | } | ||||
660 | } | ||||
661 | } | ||||
662 | my $orig = $_; | ||||
663 | $orig =~ s/\/>$/>/; | ||||
664 | $block =~ s/\s\s*.*$//; | ||||
665 | push @{$this->{content}}, $orig, "</${block}>"; | ||||
666 | next; | ||||
667 | } | ||||
668 | |||||
669 | |||||
670 | # look for here-doc identifier | ||||
671 | if ($this->{SplitPolicy} eq 'guess') { | ||||
672 | if (/^\s*([^=]+?)\s*=\s*<<\s*(.+?)\s*$/) { | ||||
673 | # try equal sign (fix bug rt#36607) | ||||
674 | $hier = $1; # the actual here-doc variable name | ||||
675 | $hierend = $2; # the here-doc identifier, i.e. "EOF" | ||||
676 | next; | ||||
677 | } | ||||
678 | elsif (/^\s*(\S+?)\s+<<\s*(.+?)\s*$/) { | ||||
679 | # try whitespace | ||||
680 | $hier = $1; # the actual here-doc variable name | ||||
681 | $hierend = $2; # the here-doc identifier, i.e. "EOF" | ||||
682 | next; | ||||
683 | } | ||||
684 | } | ||||
685 | else { | ||||
686 | # no guess, use one of the configured strict split policies | ||||
687 | if (/^\s*(.+?)($this->{SplitDelimiter})<<\s*(.+?)\s*$/) { | ||||
688 | $hier = $1; # the actual here-doc variable name | ||||
689 | $hierend = $3; # the here-doc identifier, i.e. "EOF" | ||||
690 | next; | ||||
691 | } | ||||
692 | } | ||||
693 | |||||
- - | |||||
696 | ### | ||||
697 | ### any "normal" config lines from now on | ||||
698 | ### | ||||
699 | |||||
700 | if ($longline) { | ||||
701 | # previous stuff was a longline and this is the last line of the longline | ||||
702 | s/^\s*//; | ||||
703 | $longline .= $_; | ||||
704 | push @{$this->{content}}, $longline; # push it onto the content stack | ||||
705 | undef $longline; | ||||
706 | next; | ||||
707 | } | ||||
708 | else { | ||||
709 | # look for include statement(s) | ||||
710 | my $incl_file; | ||||
711 | my $path = ''; | ||||
712 | if ( $this->{IncludeRelative} and defined $this->{CurrentConfigFilePath}) { | ||||
713 | $path = $this->{CurrentConfigFilePath}; | ||||
714 | } | ||||
715 | elsif (defined $this->{ConfigPath}) { | ||||
716 | # fetch pathname of base config file, assuming the 1st one is the path of it | ||||
717 | $path = $this->{ConfigPath}->[0]; | ||||
718 | } | ||||
719 | |||||
720 | # bugfix rt.cpan.org#38635: support quoted filenames | ||||
721 | if ($this->{UseApacheInclude}) { | ||||
722 | if (/^\s*include\s*(["'])(.*?)(?<!\\)\1$/i) { | ||||
723 | $incl_file = $2; | ||||
724 | } | ||||
725 | elsif (/^\s*include\s+(.+?)\s*$/i) { | ||||
726 | $incl_file = $1; | ||||
727 | } | ||||
728 | } | ||||
729 | else { | ||||
730 | if (/^\s*<<include\s+(.+?)>>\s*$/i) { | ||||
731 | $incl_file = $1; | ||||
732 | } | ||||
733 | } | ||||
734 | |||||
735 | if ($incl_file) { | ||||
736 | if ( $this->{IncludeRelative} && $path && !file_name_is_absolute($incl_file) ) { | ||||
737 | # include the file from within location of $this->{configfile} | ||||
738 | $this->_open( $incl_file, $path ); | ||||
739 | } | ||||
740 | else { | ||||
741 | # include the file from within pwd, or absolute | ||||
742 | $this->_open($incl_file); | ||||
743 | } | ||||
744 | } | ||||
745 | else { | ||||
746 | # standard entry, (option = value) | ||||
747 | push @{$this->{content}}, $_; | ||||
748 | } | ||||
749 | |||||
750 | } | ||||
751 | |||||
752 | } | ||||
753 | return 1; | ||||
754 | } | ||||
755 | |||||
- - | |||||
760 | sub _parse { | ||||
761 | # | ||||
762 | # parse the contents of the file | ||||
763 | # | ||||
764 | my($this, $config, $content) = @_; | ||||
765 | my(@newcontent, $block, $blockname, $chunk,$block_level); | ||||
766 | local $_; | ||||
767 | |||||
768 | foreach (@{$content}) { # loop over content stack | ||||
769 | chomp; | ||||
770 | $chunk++; | ||||
771 | $_ =~ s/^\s+//; # strip spaces @ end and begin | ||||
772 | $_ =~ s/\s+$//; | ||||
773 | |||||
774 | # | ||||
775 | # build option value assignment, split current input | ||||
776 | # using whitespace, equal sign or optionally here-doc | ||||
777 | # separator EOFseparator | ||||
778 | my ($option,$value); | ||||
779 | if (/$this->{EOFseparator}/) { | ||||
780 | ($option,$value) = split /\s*$this->{EOFseparator}\s*/, $_, 2; # separated by heredoc-finding in _open() | ||||
781 | } | ||||
782 | else { | ||||
783 | if ($this->{SplitPolicy} eq 'guess') { | ||||
784 | # again the old regex. use equalsign SplitPolicy to get the | ||||
785 | # 2.00 behavior. the new regexes were too odd. | ||||
786 | ($option,$value) = split /\s*=\s*|\s+/, $_, 2; | ||||
787 | } | ||||
788 | else { | ||||
789 | # no guess, use one of the configured strict split policies | ||||
790 | ($option,$value) = split /$this->{SplitDelimiter}/, $_, 2; | ||||
791 | } | ||||
792 | } | ||||
793 | |||||
794 | if ($value && $value =~ /^"/ && $value =~ /"$/) { | ||||
795 | $value =~ s/^"//; # remove leading and trailing " | ||||
796 | $value =~ s/"$//; | ||||
797 | } | ||||
798 | if (! defined $block) { # not inside a block @ the moment | ||||
799 | if (/^<([^\/]+?.*?)>$/) { # look if it is a block | ||||
800 | $block = $1; # store block name | ||||
801 | if ($block =~ /^"([^"]+)"$/) { | ||||
802 | # quoted block, unquote it and do not split | ||||
803 | $block =~ s/"//g; | ||||
804 | } | ||||
805 | else { | ||||
806 | # If it is a named block store the name separately; allow the block and name to each be quoted | ||||
807 | if ($block =~ /^(?:"([^"]+)"|(\S+))(?:\s+(?:"([^"]+)"|(.*)))?$/) { | ||||
808 | $block = $1 || $2; | ||||
809 | $blockname = $3 || $4; | ||||
810 | } | ||||
811 | } | ||||
812 | if ($this->{InterPolateVars}) { | ||||
813 | # interpolate block(name), add "<" and ">" to the key, because | ||||
814 | # it is sure that such keys does not exist otherwise. | ||||
815 | $block = $this->_interpolate($config, "<$block>", $block); | ||||
816 | if (defined $blockname) { | ||||
817 | $blockname = $this->_interpolate($config, "<$blockname>", "$blockname"); | ||||
818 | } | ||||
819 | } | ||||
820 | if ($this->{LowerCaseNames}) { | ||||
821 | $block = lc $block; # only for blocks lc(), if configured via new() | ||||
822 | } | ||||
823 | $this->{level} += 1; | ||||
824 | undef @newcontent; | ||||
825 | next; | ||||
826 | } | ||||
827 | elsif (/^<\/(.+?)>$/) { # it is an end block, but we don't have a matching block! | ||||
828 | croak "Config::General: EndBlock \"<\/$1>\" has no StartBlock statement (level: $this->{level}, chunk $chunk)!\n"; | ||||
829 | } | ||||
830 | else { # insert key/value pair into actual node | ||||
831 | if ($this->{LowerCaseNames}) { | ||||
832 | $option = lc $option; | ||||
833 | } | ||||
834 | |||||
835 | if (exists $config->{$option}) { | ||||
836 | if ($this->{MergeDuplicateOptions}) { | ||||
837 | $config->{$option} = $this->_parse_value($config, $option, $value); | ||||
838 | |||||
839 | # bugfix rt.cpan.org#33216 | ||||
840 | if ($this->{InterPolateVars}) { | ||||
841 | # save pair on local stack | ||||
842 | $config->{__stack}->{$option} = $config->{$option}; | ||||
843 | } | ||||
844 | } | ||||
845 | else { | ||||
846 | if (! $this->{AllowMultiOptions} ) { | ||||
847 | # no, duplicates not allowed | ||||
848 | croak "Config::General: Option \"$option\" occurs more than once (level: $this->{level}, chunk $chunk)!\n"; | ||||
849 | } | ||||
850 | else { | ||||
851 | # yes, duplicates allowed | ||||
852 | if (ref($config->{$option}) ne 'ARRAY') { # convert scalar to array | ||||
853 | my $savevalue = $config->{$option}; | ||||
854 | delete $config->{$option}; | ||||
855 | push @{$config->{$option}}, $savevalue; | ||||
856 | } | ||||
857 | eval { | ||||
858 | # check if arrays are supported by the underlying hash | ||||
859 | my $i = scalar @{$config->{$option}}; | ||||
860 | }; | ||||
861 | if ($EVAL_ERROR) { | ||||
862 | $config->{$option} = $this->_parse_value($config, $option, $value); | ||||
863 | } | ||||
864 | else { | ||||
865 | # it's already an array, just push | ||||
866 | push @{$config->{$option}}, $this->_parse_value($config, $option, $value); | ||||
867 | } | ||||
868 | } | ||||
869 | } | ||||
870 | } | ||||
871 | else { | ||||
872 | if($this->{ForceArray} && $value =~ /^\[\s*(.+?)\s*\]$/) { | ||||
873 | # force single value array entry | ||||
874 | push @{$config->{$option}}, $this->_parse_value($config, $option, $1); | ||||
875 | } | ||||
876 | else { | ||||
877 | # standard config option, insert key/value pair into node | ||||
878 | $config->{$option} = $this->_parse_value($config, $option, $value); | ||||
879 | |||||
880 | if ($this->{InterPolateVars}) { | ||||
881 | # save pair on local stack | ||||
882 | $config->{__stack}->{$option} = $config->{$option}; | ||||
883 | } | ||||
884 | } | ||||
885 | } | ||||
886 | } | ||||
887 | } | ||||
888 | elsif (/^<([^\/]+?.*?)>$/) { # found a start block inside a block, don't forget it | ||||
889 | $block_level++; # $block_level indicates wether we are still inside a node | ||||
890 | push @newcontent, $_; # push onto new content stack for later recursive call of _parse() | ||||
891 | } | ||||
892 | elsif (/^<\/(.+?)>$/) { | ||||
893 | if ($block_level) { # this endblock is not the one we are searching for, decrement and push | ||||
894 | $block_level--; # if it is 0, then the endblock was the one we searched for, see below | ||||
895 | push @newcontent, $_; # push onto new content stack | ||||
896 | } | ||||
897 | else { # calling myself recursively, end of $block reached, $block_level is 0 | ||||
898 | if (defined $blockname) { | ||||
899 | # a named block, make it a hashref inside a hash within the current node | ||||
900 | |||||
901 | if (! exists $config->{$block}) { | ||||
902 | # Make sure that the hash is not created implicitly | ||||
903 | $config->{$block} = $this->_hashref(); | ||||
904 | |||||
905 | if ($this->{InterPolateVars}) { | ||||
906 | # inherit current __stack to new block | ||||
907 | $config->{$block}->{__stack} = $this->_copy($config->{__stack}); | ||||
908 | } | ||||
909 | } | ||||
910 | |||||
911 | if (ref($config->{$block}) eq '') { | ||||
912 | croak "Config::General: Block <$block> already exists as scalar entry!\n"; | ||||
913 | } | ||||
914 | elsif (ref($config->{$block}) eq 'ARRAY') { | ||||
915 | croak "Config::General: Cannot append named block <$block $blockname> to array of scalars!\n" | ||||
916 | ."Block <$block> or scalar '$block' occurs more than once.\n" | ||||
917 | ."Turn on -MergeDuplicateBlocks or make sure <$block> occurs only once in the config.\n"; | ||||
918 | } | ||||
919 | elsif (exists $config->{$block}->{$blockname}) { | ||||
920 | # the named block already exists, make it an array | ||||
921 | if ($this->{MergeDuplicateBlocks}) { | ||||
922 | # just merge the new block with the same name as an existing one into | ||||
923 | # this one. | ||||
924 | $config->{$block}->{$blockname} = $this->_parse($config->{$block}->{$blockname}, \@newcontent); | ||||
925 | } | ||||
926 | else { | ||||
927 | if (! $this->{AllowMultiOptions}) { | ||||
928 | croak "Config::General: Named block \"<$block $blockname>\" occurs more than once (level: $this->{level}, chunk $chunk)!\n"; | ||||
929 | } | ||||
930 | else { # preserve existing data | ||||
931 | my $savevalue = $config->{$block}->{$blockname}; | ||||
932 | delete $config->{$block}->{$blockname}; | ||||
933 | my @ar; | ||||
934 | if (ref $savevalue eq 'ARRAY') { | ||||
935 | push @ar, @{$savevalue}; # preserve array if any | ||||
936 | } | ||||
937 | else { | ||||
938 | push @ar, $savevalue; | ||||
939 | } | ||||
940 | push @ar, $this->_parse( $this->_hashref(), \@newcontent); # append it | ||||
941 | $config->{$block}->{$blockname} = \@ar; | ||||
942 | } | ||||
943 | } | ||||
944 | } | ||||
945 | else { | ||||
946 | # the first occurence of this particular named block | ||||
947 | my $tmphash = $this->_hashref(); | ||||
948 | |||||
949 | if ($this->{InterPolateVars}) { | ||||
950 | # inherit current __stack to new block | ||||
951 | $tmphash->{__stack} = $this->_copy($config->{__stack}); | ||||
952 | #$tmphash->{__stack} = $config->{$block}->{__stack}; | ||||
953 | } | ||||
954 | |||||
955 | $config->{$block}->{$blockname} = $this->_parse($tmphash, \@newcontent); | ||||
956 | } | ||||
957 | } | ||||
958 | else { | ||||
959 | # standard block | ||||
960 | if (exists $config->{$block}) { | ||||
961 | if (ref($config->{$block}) eq '') { | ||||
962 | croak "Config::General: Cannot create hashref from <$block> because there is\n" | ||||
963 | ."already a scalar option '$block' with value '$config->{$block}'\n"; | ||||
964 | } | ||||
965 | |||||
966 | # the block already exists, make it an array | ||||
967 | if ($this->{MergeDuplicateBlocks}) { | ||||
968 | # just merge the new block with the same name as an existing one into | ||||
969 | # this one. | ||||
970 | $config->{$block} = $this->_parse($config->{$block}, \@newcontent); | ||||
971 | } | ||||
972 | else { | ||||
973 | if (! $this->{AllowMultiOptions}) { | ||||
974 | croak "Config::General: Block \"<$block>\" occurs more than once (level: $this->{level}, chunk $chunk)!\n"; | ||||
975 | } | ||||
976 | else { | ||||
977 | my $savevalue = $config->{$block}; | ||||
978 | delete $config->{$block}; | ||||
979 | my @ar; | ||||
980 | if (ref $savevalue eq "ARRAY") { | ||||
981 | push @ar, @{$savevalue}; | ||||
982 | } | ||||
983 | else { | ||||
984 | push @ar, $savevalue; | ||||
985 | } | ||||
986 | |||||
987 | # fixes rt#31529 | ||||
988 | my $tmphash = $this->_hashref(); | ||||
989 | if ($this->{InterPolateVars}) { | ||||
990 | # inherit current __stack to new block | ||||
991 | $tmphash->{__stack} = $this->_copy($config->{__stack}); | ||||
992 | } | ||||
993 | |||||
994 | push @ar, $this->_parse( $tmphash, \@newcontent); | ||||
995 | |||||
996 | $config->{$block} = \@ar; | ||||
997 | } | ||||
998 | } | ||||
999 | } | ||||
1000 | else { | ||||
1001 | # the first occurence of this particular block | ||||
1002 | my $tmphash = $this->_hashref(); | ||||
1003 | |||||
1004 | if ($this->{InterPolateVars}) { | ||||
1005 | # inherit current __stack to new block | ||||
1006 | $tmphash->{__stack} = $this->_copy($config->{__stack}); | ||||
1007 | } | ||||
1008 | |||||
1009 | $config->{$block} = $this->_parse($tmphash, \@newcontent); | ||||
1010 | } | ||||
1011 | } | ||||
1012 | undef $blockname; | ||||
1013 | undef $block; | ||||
1014 | $this->{level} -= 1; | ||||
1015 | next; | ||||
1016 | } | ||||
1017 | } | ||||
1018 | else { # inside $block, just push onto new content stack | ||||
1019 | push @newcontent, $_; | ||||
1020 | } | ||||
1021 | } | ||||
1022 | if ($block) { | ||||
1023 | # $block is still defined, which means, that it had | ||||
1024 | # no matching endblock! | ||||
1025 | croak "Config::General: Block \"<$block>\" has no EndBlock statement (level: $this->{level}, chunk $chunk)!\n"; | ||||
1026 | } | ||||
1027 | return $config; | ||||
1028 | } | ||||
1029 | |||||
1030 | |||||
1031 | sub _copy { | ||||
1032 | # | ||||
1033 | # copy the contents of one hash into another | ||||
1034 | # to circumvent invalid references | ||||
1035 | # fixes rt.cpan.org bug #35122 | ||||
1036 | my($this, $source) = @_; | ||||
1037 | my %hash = (); | ||||
1038 | while (my ($key, $value) = each %{$source}) { | ||||
1039 | $hash{$key} = $value; | ||||
1040 | } | ||||
1041 | return \%hash; | ||||
1042 | } | ||||
1043 | |||||
1044 | |||||
1045 | sub _parse_value { | ||||
1046 | # | ||||
1047 | # parse the value if value parsing is turned on | ||||
1048 | # by either -AutoTrue and/or -FlagBits | ||||
1049 | # otherwise just return the given value unchanged | ||||
1050 | # | ||||
1051 | my($this, $config, $option, $value) =@_; | ||||
1052 | |||||
1053 | # avoid "Use of uninitialized value" | ||||
1054 | if (! defined $value) { | ||||
1055 | # patch fix rt#54583 | ||||
1056 | # Return an input undefined value without trying transformations | ||||
1057 | return $value; | ||||
1058 | } | ||||
1059 | |||||
1060 | if ($this->{InterPolateVars}) { | ||||
1061 | $value = $this->_interpolate($config, $option, $value); | ||||
1062 | } | ||||
1063 | |||||
1064 | # make true/false values to 1 or 0 (-AutoTrue) | ||||
1065 | if ($this->{AutoTrue}) { | ||||
1066 | if ($value =~ /$this->{AutoTrueFlags}->{true}/io) { | ||||
1067 | $value = 1; | ||||
1068 | } | ||||
1069 | elsif ($value =~ /$this->{AutoTrueFlags}->{false}/io) { | ||||
1070 | $value = 0; | ||||
1071 | } | ||||
1072 | } | ||||
1073 | |||||
1074 | # assign predefined flags or undef for every flag | flag ... (-FlagBits) | ||||
1075 | if ($this->{FlagBits}) { | ||||
1076 | if (exists $this->{FlagBitsFlags}->{$option}) { | ||||
1077 | my %__flags = map { $_ => 1 } split /\s*\|\s*/, $value; | ||||
1078 | foreach my $flag (keys %{$this->{FlagBitsFlags}->{$option}}) { | ||||
1079 | if (exists $__flags{$flag}) { | ||||
1080 | $__flags{$flag} = $this->{FlagBitsFlags}->{$option}->{$flag}; | ||||
1081 | } | ||||
1082 | else { | ||||
1083 | $__flags{$flag} = undef; | ||||
1084 | } | ||||
1085 | } | ||||
1086 | $value = \%__flags; | ||||
1087 | } | ||||
1088 | } | ||||
1089 | |||||
1090 | # are there any escaped characters left? put them out as is | ||||
1091 | $value =~ s/\\([\$\\\"#])/$1/g; | ||||
1092 | |||||
1093 | return $value; | ||||
1094 | } | ||||
1095 | |||||
- - | |||||
1101 | sub NoMultiOptions { | ||||
1102 | # | ||||
1103 | # turn AllowMultiOptions off, still exists for backward compatibility. | ||||
1104 | # Since we do parsing from within new(), we must | ||||
1105 | # call it again if one turns NoMultiOptions on! | ||||
1106 | # | ||||
1107 | croak q(Config::General: The NoMultiOptions() method is deprecated. Set 'AllowMultiOptions' to 'no' instead!); | ||||
1108 | } | ||||
1109 | |||||
1110 | |||||
1111 | sub save { | ||||
1112 | # | ||||
1113 | # this is the old version of save() whose API interface | ||||
1114 | # has been changed. I'm very sorry 'bout this. | ||||
1115 | # | ||||
1116 | # I'll try to figure out, if it has been called correctly | ||||
1117 | # and if yes, feed the call to Save(), otherwise croak. | ||||
1118 | # | ||||
1119 | my($this, $one, @two) = @_; | ||||
1120 | |||||
1121 | if ( (@two && $one) && ( (scalar @two) % 2 == 0) ) { | ||||
1122 | # @two seems to be a hash | ||||
1123 | my %h = @two; | ||||
1124 | $this->save_file($one, \%h); | ||||
1125 | } | ||||
1126 | else { | ||||
1127 | croak q(Config::General: The save() method is deprecated. Use the new save_file() method instead!); | ||||
1128 | } | ||||
1129 | return; | ||||
1130 | } | ||||
1131 | |||||
1132 | |||||
1133 | sub save_file { | ||||
1134 | # | ||||
1135 | # save the config back to disk | ||||
1136 | # | ||||
1137 | my($this, $file, $config) = @_; | ||||
1138 | my $fh; | ||||
1139 | my $config_string; | ||||
1140 | |||||
1141 | if (!$file) { | ||||
1142 | croak "Config::General: Filename is required!"; | ||||
1143 | } | ||||
1144 | else { | ||||
1145 | if ($this->{UTF8}) { | ||||
1146 | $fh = new IO::File; | ||||
1147 | open($fh, ">:utf8", $file) | ||||
1148 | or croak "Config::General: Could not open $file in UTF8 mode!($!)\n"; | ||||
1149 | } | ||||
1150 | else { | ||||
1151 | $fh = IO::File->new( "$file", 'w') | ||||
1152 | or croak "Config::General: Could not open $file!($!)\n"; | ||||
1153 | } | ||||
1154 | if (!$config) { | ||||
1155 | if (exists $this->{config}) { | ||||
1156 | $config_string = $this->_store(0, $this->{config}); | ||||
1157 | } | ||||
1158 | else { | ||||
1159 | croak "Config::General: No config hash supplied which could be saved to disk!\n"; | ||||
1160 | } | ||||
1161 | } | ||||
1162 | else { | ||||
1163 | $config_string = $this->_store(0, $config); | ||||
1164 | } | ||||
1165 | |||||
1166 | if ($config_string) { | ||||
1167 | print {$fh} $config_string; | ||||
1168 | } | ||||
1169 | else { | ||||
1170 | # empty config for whatever reason, I don't care | ||||
1171 | print {$fh} q(); | ||||
1172 | } | ||||
1173 | |||||
1174 | close $fh; | ||||
1175 | } | ||||
1176 | return; | ||||
1177 | } | ||||
1178 | |||||
- - | |||||
1181 | sub save_string { | ||||
1182 | # | ||||
1183 | # return the saved config as a string | ||||
1184 | # | ||||
1185 | my($this, $config) = @_; | ||||
1186 | |||||
1187 | if (!$config || ref($config) ne 'HASH') { | ||||
1188 | if (exists $this->{config}) { | ||||
1189 | return $this->_store(0, $this->{config}); | ||||
1190 | } | ||||
1191 | else { | ||||
1192 | croak "Config::General: No config hash supplied which could be saved to disk!\n"; | ||||
1193 | } | ||||
1194 | } | ||||
1195 | else { | ||||
1196 | return $this->_store(0, $config); | ||||
1197 | } | ||||
1198 | return; | ||||
1199 | } | ||||
1200 | |||||
- - | |||||
1203 | sub _store { | ||||
1204 | # | ||||
1205 | # internal sub for saving a block | ||||
1206 | # | ||||
1207 | my($this, $level, $config) = @_; | ||||
1208 | local $_; | ||||
1209 | my $indent = q( ) x $level; | ||||
1210 | |||||
1211 | my $config_string = q(); | ||||
1212 | |||||
1213 | foreach my $entry ( $this->{SaveSorted} ? sort keys %$config : keys %$config ) { | ||||
1214 | if (ref($config->{$entry}) eq 'ARRAY') { | ||||
1215 | if( $this->{ForceArray} && scalar @{$config->{$entry}} == 1 && ! ref($config->{$entry}->[0]) ) { | ||||
1216 | # a single value array forced to stay as array | ||||
1217 | $config_string .= $this->_write_scalar($level, $entry, '[' . $config->{$entry}->[0] . ']'); | ||||
1218 | } | ||||
1219 | else { | ||||
1220 | foreach my $line ( $this->{SaveSorted} ? sort @{$config->{$entry}} : @{$config->{$entry}} ) { | ||||
1221 | if (ref($line) eq 'HASH') { | ||||
1222 | $config_string .= $this->_write_hash($level, $entry, $line); | ||||
1223 | } | ||||
1224 | else { | ||||
1225 | $config_string .= $this->_write_scalar($level, $entry, $line); | ||||
1226 | } | ||||
1227 | } | ||||
1228 | } | ||||
1229 | } | ||||
1230 | elsif (ref($config->{$entry}) eq 'HASH') { | ||||
1231 | $config_string .= $this->_write_hash($level, $entry, $config->{$entry}); | ||||
1232 | } | ||||
1233 | else { | ||||
1234 | $config_string .= $this->_write_scalar($level, $entry, $config->{$entry}); | ||||
1235 | } | ||||
1236 | } | ||||
1237 | |||||
1238 | return $config_string; | ||||
1239 | } | ||||
1240 | |||||
1241 | |||||
1242 | sub _write_scalar { | ||||
1243 | # | ||||
1244 | # internal sub, which writes a scalar | ||||
1245 | # it returns it, in fact | ||||
1246 | # | ||||
1247 | my($this, $level, $entry, $line) = @_; | ||||
1248 | |||||
1249 | my $indent = q( ) x $level; | ||||
1250 | |||||
1251 | my $config_string; | ||||
1252 | |||||
1253 | # patch fix rt#54583 | ||||
1254 | if ( ! defined $line ) { | ||||
1255 | $config_string .= $indent . $entry . "\n"; | ||||
1256 | } | ||||
1257 | elsif ($line =~ /\n/ || $line =~ /\\$/) { | ||||
1258 | # it is a here doc | ||||
1259 | my $delimiter; | ||||
1260 | my $tmplimiter = 'EOF'; | ||||
1261 | while (!$delimiter) { | ||||
1262 | # create a unique here-doc identifier | ||||
1263 | if ($line =~ /$tmplimiter/s) { | ||||
1264 | $tmplimiter .= '%'; | ||||
1265 | } | ||||
1266 | else { | ||||
1267 | $delimiter = $tmplimiter; | ||||
1268 | } | ||||
1269 | } | ||||
1270 | my @lines = split /\n/, $line; | ||||
1271 | $config_string .= $indent . $entry . $this->{StoreDelimiter} . "<<$delimiter\n"; | ||||
1272 | foreach (@lines) { | ||||
1273 | $config_string .= $indent . $_ . "\n"; | ||||
1274 | } | ||||
1275 | $config_string .= $indent . "$delimiter\n"; | ||||
1276 | } | ||||
1277 | else { | ||||
1278 | # a simple stupid scalar entry | ||||
1279 | |||||
1280 | # re-escape contained $ or # or \ chars | ||||
1281 | $line =~ s/([#\$\\\"])/\\$1/g; | ||||
1282 | |||||
1283 | # bugfix rt.cpan.org#42287 | ||||
1284 | if ($line =~ /^\s/ or $line =~ /\s$/) { | ||||
1285 | # need to quote it | ||||
1286 | $line = "\"$line\""; | ||||
1287 | } | ||||
1288 | $config_string .= $indent . $entry . $this->{StoreDelimiter} . $line . "\n"; | ||||
1289 | } | ||||
1290 | |||||
1291 | return $config_string; | ||||
1292 | } | ||||
1293 | |||||
1294 | sub _write_hash { | ||||
1295 | # | ||||
1296 | # internal sub, which writes a hash (block) | ||||
1297 | # it returns it, in fact | ||||
1298 | # | ||||
1299 | my($this, $level, $entry, $line) = @_; | ||||
1300 | |||||
1301 | my $indent = q( ) x $level; | ||||
1302 | my $config_string; | ||||
1303 | |||||
1304 | if ($entry =~ /\s/) { | ||||
1305 | # quote the entry if it contains whitespaces | ||||
1306 | $entry = q(") . $entry . q("); | ||||
1307 | } | ||||
1308 | |||||
1309 | $config_string .= $indent . q(<) . $entry . ">\n"; | ||||
1310 | $config_string .= $this->_store($level + 1, $line); | ||||
1311 | $config_string .= $indent . q(</) . $entry . ">\n"; | ||||
1312 | |||||
1313 | return $config_string | ||||
1314 | } | ||||
1315 | |||||
1316 | |||||
1317 | sub _hashref { | ||||
1318 | # | ||||
1319 | # return a probably tied new empty hash ref | ||||
1320 | # | ||||
1321 | my($this) = @_; | ||||
1322 | if ($this->{Tie}) { | ||||
1323 | eval { | ||||
1324 | eval qq{require $this->{Tie}}; | ||||
1325 | }; | ||||
1326 | if ($EVAL_ERROR) { | ||||
1327 | croak q(Config::General: Could not create a tied hash of type: ) . $this->{Tie} . q(: ) . $EVAL_ERROR; | ||||
1328 | } | ||||
1329 | my %hash; | ||||
1330 | tie %hash, $this->{Tie}; | ||||
1331 | return \%hash; | ||||
1332 | } | ||||
1333 | else { | ||||
1334 | return {}; | ||||
1335 | } | ||||
1336 | } | ||||
1337 | |||||
- - | |||||
1340 | # | ||||
1341 | # Procedural interface | ||||
1342 | # | ||||
1343 | sub ParseConfig { | ||||
1344 | # | ||||
1345 | # @_ may contain everything which is allowed for new() | ||||
1346 | # | ||||
1347 | return (new Config::General(@_))->getall(); | ||||
1348 | } | ||||
1349 | |||||
1350 | sub SaveConfig { | ||||
1351 | # | ||||
1352 | # 2 parameters are required, filename and hash ref | ||||
1353 | # | ||||
1354 | my ($file, $hash) = @_; | ||||
1355 | |||||
1356 | if (!$file || !$hash) { | ||||
1357 | croak q{Config::General::SaveConfig(): filename and hash argument required.}; | ||||
1358 | } | ||||
1359 | else { | ||||
1360 | if (ref($hash) ne 'HASH') { | ||||
1361 | croak q(Config::General::SaveConfig() The second parameter must be a reference to a hash!); | ||||
1362 | } | ||||
1363 | else { | ||||
1364 | (new Config::General(-ConfigHash => $hash))->save_file($file); | ||||
1365 | } | ||||
1366 | } | ||||
1367 | return; | ||||
1368 | } | ||||
1369 | |||||
1370 | sub SaveConfigString { | ||||
1371 | # | ||||
1372 | # same as SaveConfig, but return the config, | ||||
1373 | # instead of saving it | ||||
1374 | # | ||||
1375 | my ($hash) = @_; | ||||
1376 | |||||
1377 | if (!$hash) { | ||||
1378 | croak q{Config::General::SaveConfigString(): Hash argument required.}; | ||||
1379 | } | ||||
1380 | else { | ||||
1381 | if (ref($hash) ne 'HASH') { | ||||
1382 | croak q(Config::General::SaveConfigString() The parameter must be a reference to a hash!); | ||||
1383 | } | ||||
1384 | else { | ||||
1385 | return (new Config::General(-ConfigHash => $hash))->save_string(); | ||||
1386 | } | ||||
1387 | } | ||||
1388 | return; | ||||
1389 | } | ||||
1390 | |||||
- - | |||||
1393 | # keep this one | ||||
1394 | 1 | 21µs | 1; | ||
1395 | __END__ |