← Index
NYTProf Performance Profile   « block view • line view • sub view »
For t/app_dpath.t
  Run on Tue Jun 5 15:25:28 2012
Reported on Tue Jun 5 15:26:10 2012

Filename/home/ss5/perl5/perlbrew/perls/perl-5.14.1/lib/site_perl/5.14.1/Config/General.pm
StatementsExecuted 27 statements in 29.5ms
Subroutines
Calls P F Exclusive
Time
Inclusive
Time
Subroutine
1113.68ms12.1msConfig::General::::BEGIN@17Config::General::BEGIN@17
1113.47ms39.6msConfig::General::::BEGIN@19Config::General::BEGIN@19
1113.39ms8.37msConfig::General::::BEGIN@22Config::General::BEGIN@22
1112.72ms6.08msConfig::General::::BEGIN@20Config::General::BEGIN@20
1111.95ms3.03msConfig::General::::BEGIN@21Config::General::BEGIN@21
111518µs561µsConfig::General::::BEGIN@29Config::General::BEGIN@29
11159µs76µsConfig::General::::BEGIN@15Config::General::BEGIN@15
11136µs205µsConfig::General::::BEGIN@32Config::General::BEGIN@32
11136µs63µsConfig::General::::BEGIN@16Config::General::BEGIN@16
11135µs300µsConfig::General::::BEGIN@38Config::General::BEGIN@38
11134µs89µsConfig::General::::BEGIN@33Config::General::BEGIN@33
11131µs170µsConfig::General::::BEGIN@37Config::General::BEGIN@37
0000s0sConfig::General::::NoMultiOptionsConfig::General::NoMultiOptions
0000s0sConfig::General::::ParseConfigConfig::General::ParseConfig
0000s0sConfig::General::::SaveConfigConfig::General::SaveConfig
0000s0sConfig::General::::SaveConfigStringConfig::General::SaveConfigString
0000s0sConfig::General::::_blessoopConfig::General::_blessoop
0000s0sConfig::General::::_blessvarsConfig::General::_blessvars
0000s0sConfig::General::::_copyConfig::General::_copy
0000s0sConfig::General::::_hashrefConfig::General::_hashref
0000s0sConfig::General::::_openConfig::General::_open
0000s0sConfig::General::::_parseConfig::General::_parse
0000s0sConfig::General::::_parse_valueConfig::General::_parse_value
0000s0sConfig::General::::_prepareConfig::General::_prepare
0000s0sConfig::General::::_processConfig::General::_process
0000s0sConfig::General::::_readConfig::General::_read
0000s0sConfig::General::::_splitpolicyConfig::General::_splitpolicy
0000s0sConfig::General::::_storeConfig::General::_store
0000s0sConfig::General::::_write_hashConfig::General::_write_hash
0000s0sConfig::General::::_write_scalarConfig::General::_write_scalar
0000s0sConfig::General::::filesConfig::General::files
0000s0sConfig::General::::getallConfig::General::getall
0000s0sConfig::General::::newConfig::General::new
0000s0sConfig::General::::saveConfig::General::save
0000s0sConfig::General::::save_fileConfig::General::save_file
0000s0sConfig::General::::save_stringConfig::General::save_string
Call graph for these subroutines as a Graphviz dot language file.
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
13package Config::General;
14
152100µs293µ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
use strict;
# spent 76µs making 1 call to Config::General::BEGIN@15 # spent 17µs making 1 call to strict::import
162106µs291µ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
use warnings;
# spent 63µs making 1 call to Config::General::BEGIN@16 # spent 28µs making 1 call to warnings::import
172688µs214.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
use English '-no_match_vars';
# spent 12.1ms making 1 call to Config::General::BEGIN@17 # spent 1.95ms making 1 call to English::import
18
192881µs240.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
use IO::File;
# spent 39.6ms making 1 call to Config::General::BEGIN@19 # spent 569µs making 1 call to Exporter::import
202562µs28.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
use FileHandle;
# spent 6.08ms making 1 call to Config::General::BEGIN@20 # spent 2.43ms making 1 call to FileHandle::import
212612µs23.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
use File::Spec::Functions qw(splitpath file_name_is_absolute catfile catpath);
# spent 3.03ms making 1 call to Config::General::BEGIN@21 # spent 344µs making 1 call to Exporter::import
222558µs29.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
use File::Glob qw/:glob/;
# 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!
292458µs1561µ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
use Carp::Heavy;
# spent 561µs making 1 call to Config::General::BEGIN@29
30
31
322102µs2374µ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
use Carp;
# spent 205µs making 1 call to Config::General::BEGIN@32 # spent 169µs making 1 call to Exporter::import
332146µs2144µ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
use Exporter;
# spent 89µs making 1 call to Config::General::BEGIN@33 # spent 55µs making 1 call to Exporter::import
34
3514µs$Config::General::VERSION = "2.50";
36
372103µs2310µ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
use vars qw(@ISA @EXPORT_OK);
# spent 170µs making 1 call to Config::General::BEGIN@37 # spent 139µs making 1 call to vars::import
38225.2ms2566µ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
use base qw(Exporter);
# spent 300µs making 1 call to Config::General::BEGIN@38 # spent 265µs making 1 call to base::import
39111µs@EXPORT_OK = qw(ParseConfig SaveConfig SaveConfigString);
40
41sub 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
- -
137sub _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
192sub _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
210sub _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
234sub _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
267sub _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
385sub getall {
386 #
387 # just return the whole config hash
388 #
389 my($this) = @_;
390 return (exists $this->{config} ? %{$this->{config}} : () );
391}
392
393
394sub 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
403sub _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
531sub _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
- -
760sub _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
1031sub _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
1045sub _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
- -
1101sub 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
1111sub 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
1133sub 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
- -
1181sub 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
- -
1203sub _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
1242sub _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
1294sub _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
1317sub _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#
1343sub ParseConfig {
1344 #
1345 # @_ may contain everything which is allowed for new()
1346 #
1347 return (new Config::General(@_))->getall();
1348}
1349
1350sub 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
1370sub 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
1394121µs1;
1395__END__