| 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 | Config::General::BEGIN@17 |
| 1 | 1 | 1 | 3.47ms | 39.6ms | Config::General::BEGIN@19 |
| 1 | 1 | 1 | 3.39ms | 8.37ms | Config::General::BEGIN@22 |
| 1 | 1 | 1 | 2.72ms | 6.08ms | Config::General::BEGIN@20 |
| 1 | 1 | 1 | 1.95ms | 3.03ms | Config::General::BEGIN@21 |
| 1 | 1 | 1 | 518µs | 561µs | Config::General::BEGIN@29 |
| 1 | 1 | 1 | 59µs | 76µs | Config::General::BEGIN@15 |
| 1 | 1 | 1 | 36µs | 205µs | Config::General::BEGIN@32 |
| 1 | 1 | 1 | 36µs | 63µs | Config::General::BEGIN@16 |
| 1 | 1 | 1 | 35µs | 300µs | Config::General::BEGIN@38 |
| 1 | 1 | 1 | 34µs | 89µs | Config::General::BEGIN@33 |
| 1 | 1 | 1 | 31µs | 170µs | Config::General::BEGIN@37 |
| 0 | 0 | 0 | 0s | 0s | Config::General::NoMultiOptions |
| 0 | 0 | 0 | 0s | 0s | Config::General::ParseConfig |
| 0 | 0 | 0 | 0s | 0s | Config::General::SaveConfig |
| 0 | 0 | 0 | 0s | 0s | Config::General::SaveConfigString |
| 0 | 0 | 0 | 0s | 0s | Config::General::_blessoop |
| 0 | 0 | 0 | 0s | 0s | Config::General::_blessvars |
| 0 | 0 | 0 | 0s | 0s | Config::General::_copy |
| 0 | 0 | 0 | 0s | 0s | Config::General::_hashref |
| 0 | 0 | 0 | 0s | 0s | Config::General::_open |
| 0 | 0 | 0 | 0s | 0s | Config::General::_parse |
| 0 | 0 | 0 | 0s | 0s | Config::General::_parse_value |
| 0 | 0 | 0 | 0s | 0s | Config::General::_prepare |
| 0 | 0 | 0 | 0s | 0s | Config::General::_process |
| 0 | 0 | 0 | 0s | 0s | Config::General::_read |
| 0 | 0 | 0 | 0s | 0s | Config::General::_splitpolicy |
| 0 | 0 | 0 | 0s | 0s | Config::General::_store |
| 0 | 0 | 0 | 0s | 0s | Config::General::_write_hash |
| 0 | 0 | 0 | 0s | 0s | Config::General::_write_scalar |
| 0 | 0 | 0 | 0s | 0s | Config::General::files |
| 0 | 0 | 0 | 0s | 0s | Config::General::getall |
| 0 | 0 | 0 | 0s | 0s | Config::General::new |
| 0 | 0 | 0 | 0s | 0s | Config::General::save |
| 0 | 0 | 0 | 0s | 0s | Config::General::save_file |
| 0 | 0 | 0 | 0s | 0s | Config::General::save_string |
| 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__ |