Profile of Config/General.pm

← 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:00 2012

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

Subroutines
Calls | P | F | Exclusive Time | Inclusive Time | Subroutine
--- | --- | --- | --- | --- | ---
1 | 1 | 1 | 3.68ms | 12.1ms | Config::General::::BEGIN@17Config::General::BEGIN@17
1 | 1 | 1 | 3.47ms | 39.6ms | Config::General::::BEGIN@19Config::General::BEGIN@19
1 | 1 | 1 | 3.39ms | 8.37ms | Config::General::::BEGIN@22Config::General::BEGIN@22
1 | 1 | 1 | 2.72ms | 6.08ms | Config::General::::BEGIN@20Config::General::BEGIN@20
1 | 1 | 1 | 1.95ms | 3.03ms | Config::General::::BEGIN@21Config::General::BEGIN@21
1 | 1 | 1 | 518µs | 561µs | Config::General::::BEGIN@29Config::General::BEGIN@29
1 | 1 | 1 | 59µs | 76µs | Config::General::::BEGIN@15Config::General::BEGIN@15
1 | 1 | 1 | 36µs | 205µs | Config::General::::BEGIN@32Config::General::BEGIN@32
1 | 1 | 1 | 36µs | 63µs | Config::General::::BEGIN@16Config::General::BEGIN@16
1 | 1 | 1 | 35µs | 300µs | Config::General::::BEGIN@38Config::General::BEGIN@38
1 | 1 | 1 | 34µs | 89µs | Config::General::::BEGIN@33Config::General::BEGIN@33
1 | 1 | 1 | 31µs | 170µs | Config::General::::BEGIN@37Config::General::BEGIN@37
0 | 0 | 0 | 0s | 0s | Config::General::::NoMultiOptionsConfig::General::NoMultiOptions
0 | 0 | 0 | 0s | 0s | Config::General::::ParseConfigConfig::General::ParseConfig
0 | 0 | 0 | 0s | 0s | Config::General::::SaveConfigConfig::General::SaveConfig
0 | 0 | 0 | 0s | 0s | Config::General::::SaveConfigStringConfig::General::SaveConfigString
0 | 0 | 0 | 0s | 0s | Config::General::::_blessoopConfig::General::_blessoop
0 | 0 | 0 | 0s | 0s | Config::General::::_blessvarsConfig::General::_blessvars
0 | 0 | 0 | 0s | 0s | Config::General::::_copyConfig::General::_copy
0 | 0 | 0 | 0s | 0s | Config::General::::_hashrefConfig::General::_hashref
0 | 0 | 0 | 0s | 0s | Config::General::::_openConfig::General::_open
0 | 0 | 0 | 0s | 0s | Config::General::::_parseConfig::General::_parse
0 | 0 | 0 | 0s | 0s | Config::General::::_parse_valueConfig::General::_parse_value
0 | 0 | 0 | 0s | 0s | Config::General::::_prepareConfig::General::_prepare
0 | 0 | 0 | 0s | 0s | Config::General::::_processConfig::General::_process
0 | 0 | 0 | 0s | 0s | Config::General::::_readConfig::General::_read
0 | 0 | 0 | 0s | 0s | Config::General::::_splitpolicyConfig::General::_splitpolicy
0 | 0 | 0 | 0s | 0s | Config::General::::_storeConfig::General::_store
0 | 0 | 0 | 0s | 0s | Config::General::::_write_hashConfig::General::_write_hash
0 | 0 | 0 | 0s | 0s | Config::General::::_write_scalarConfig::General::_write_scalar
0 | 0 | 0 | 0s | 0s | Config::General::::filesConfig::General::files
0 | 0 | 0 | 0s | 0s | Config::General::::getallConfig::General::getall
0 | 0 | 0 | 0s | 0s | Config::General::::newConfig::General::new
0 | 0 | 0 | 0s | 0s | Config::General::::saveConfig::General::save
0 | 0 | 0 | 0s | 0s | Config::General::::save_fileConfig::General::save_file
0 | 0 | 0 | 0s | 0s | Config::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
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 use strict; # 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 use warnings; # 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 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 |  |  |  |  |
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 use IO::File; # 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 use FileHandle; # 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 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
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 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!
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 use Carp::Heavy; # 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 use Carp; # 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 use Exporter; # 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 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
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 use base qw(Exporter); # 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__