File Coverage

blib/lib/Config/General/Interpolated.pm

Criterion	Covered	Total	%
statement	51	79	64.6
branch	6	22	27.3
condition			n/a
subroutine	9	11	81.8
pod	1	1	100.0
total	67	113	59.3

line	stmt	bran	sub	pod	time	code
1						#
2						# Config::General::Interpolated - special Class based on Config::General
3						#
4						# Copyright (c) 2001 by Wei-Hon Chen <plasmaball@pchome.com.tw>.
5						# Copyright (c) 2000-2007 by Thomas Linden <tlinden \|AT\| cpan.org>.
6						# All Rights Reserved. Std. disclaimer applies.
7						# Artificial License, same as perl itself. Have fun.
8						#
9
10						package Config::General::Interpolated;
11						$Config::General::Interpolated::VERSION = "2.07";
12
13	1		1		14	use strict;
	1				10
	1				17
14	1		1		30	use Carp;
	1				9
	1				20
15	1		1		15	use Config::General;
	1				10
	1				16
16	1		1		15	use Exporter ();
	1				9
	1				9
17
18
19						# Import stuff from Config::General
20	1		1		15	use vars qw(@ISA @EXPORT);
	1				10
	1				17
21						@ISA = qw(Config::General Exporter);
22
23
24						sub new {
25						#
26						# overwrite new() with our own version
27						# and call the parent class new()
28						#
29
30	0		0	1	0	croak "Deprecated method Config::General::Interpolated::new() called.\n"
31						."Use Config::General::new() instead and set the -InterPolateVars flag.\n";
32						}
33
34
35
36						sub _set_regex {
37						#
38						# set the regex for finding vars
39						#
40
41						# the following regex is provided by Autrijus Tang
42						# <autrijus@autrijus.org>, and I made some modifications.
43						# thanx, autrijus. :)
44	1		1		13	my $regex = qr{
45						(^\|\G\|[^\\]) # $1: can be the beginning of the line
46						# or the beginning of next match
47						# but can't begin with a '\'
48						\$ # dollar sign
49						(\{)? # $2: optional opening curly
50						([a-zA-Z_]\w*) # $3: capturing variable name
51						(
52						?(2) # $4: if there's the opening curly...
53						\} # ... match closing curly
54						)
55						}x;
56	1				16	return $regex;
57						}
58
59
60						sub _interpolate {
61						#
62						# interpolate a scalar value and keep the result
63						# on the varstack.
64						#
65						# called directly by Config::General::_parse_value()
66						#
67	24		24		225	my ($this, $key, $value) = @_;
68
69	24				187	my $prevkey;
70
71	24	100			494	if ($this->{level} == 1) {
72						# top level
73	14				160	$prevkey = " ";
74						}
75						else {
76						# incorporate variables outside current scope(block) into
77						# our scope to make them visible to _interpolate()
78
79	10				82	foreach my $key (keys %{$this->{stack}->{ $this->{level} - 1}->{ $this->{lastkey} }}) {
	10				153
80	67	100			870	if (! exists $this->{stack}->{ $this->{level} }->{ $this->{prevkey} }->{$key}) {
81						# only import a variable if it is not re-defined in current scope! (rt.cpan.org bug #20742
82	43				661	$this->{stack}->{ $this->{level} }->{ $this->{prevkey} }->{$key} = $this->{stack}->{ $this->{level} - 1}->{ $this->{lastkey} }->{$key};
83						}
84						}
85
86	10				120	$prevkey = $this->{prevkey};
87						}
88
89	24				302	$value =~ s{$this->{regex}}{
90	8				83	my $con = $1;
91	8				77	my $var = $3;
92	8	50			78	my $var_lc = $this->{LowerCaseNames} ? lc($var) : $var;
93	8	50			85	if (exists $this->{stack}->{ $this->{level} }->{ $prevkey }->{$var_lc}) {
		0
94	8				108	$con . $this->{stack}->{ $this->{level} }->{ $prevkey }->{$var_lc};
95						}
96						elsif ($this->{InterPolateEnv}) {
97						# may lead to vulnerabilities, by default flag turned off
98	0	0			0	if (defined($ENV{$var})) {
99	0				0	$con . $ENV{$var};
100						}
101						}
102						else {
103	0	0			0	if ($this->{StrictVars}) {
104	0				0	croak "Use of uninitialized variable (\$$var) while loading config entry: $key = $value\n";
105						}
106						else {
107						# be cool
108	0				0	$con;
109						}
110						}
111						}egx;
112
113	24				319	$this->{stack}->{ $this->{level} }->{ $prevkey }->{$key} = $value;
114
115	24				281	return $value;
116						};
117
118
119						sub _interpolate_hash {
120						#
121						# interpolate a complete hash and keep the results
122						# on the varstack.
123						#
124						# called directly by Config::General::new()
125						#
126	1		1		11	my ($this, $config) = @_;
127
128	1				10	$this->{level} = 1;
129	1				11	$this->{upperkey} = "";
130	1				12	$this->{upperkeys} = [];
131	1				11	$this->{lastkey} = "";
132	1				10	$this->{prevkey} = " ";
133
134	1				12	$config = $this->_var_hash_stacker($config);
135
136	1				10	$this->{level} = 1;
137	1				11	$this->{upperkey} = "";
138	1				10	$this->{upperkeys} = [];
139	1				10	$this->{lastkey} = "";
140	1				10	$this->{prevkey} = " ";
141
142	1				12	return $config;
143						}
144
145						sub _var_hash_stacker {
146						#
147						# build a varstack of a given hash ref
148						#
149	1		1		11	my ($this, $config) = @_;
150
151	1				10	foreach my $key (keys %{$config}) {
	1				13
152	0	0			0	if (ref($config->{$key}) eq "ARRAY" ) {
		0
153	0				0	$this->{level}++;
154	0				0	$this->_savelast($key);
155	0				0	$config->{$key} = $this->_var_array_stacker($config->{$key}, $key);
156	0				0	$this->_backlast($key);
157	0				0	$this->{level}--;
158						}
159						elsif (ref($config->{$key}) eq "HASH") {
160	0				0	$this->{level}++;
161	0				0	$this->_savelast($key);
162	0				0	$config->{$key} = $this->_var_hash_stacker($config->{$key});
163	0				0	$this->_backlast($key);
164	0				0	$this->{level}--;
165						}
166						else {
167						# SCALAR
168	0				0	$config->{$key} = $this->_interpolate($key, $config->{$key});
169						}
170						}
171
172	1				12	return $config;
173						}
174
175
176						sub _var_array_stacker {
177						#
178						# same as _var_hash_stacker but for arrayrefs
179						#
180	0		0			my ($this, $config, $key) = @_;
181
182	0					my @new;
183
184	0					foreach my $entry (@{$config}) {
	0
185	0	0				if (ref($entry) eq "HASH") {
		0
186	0					$entry = $this->_var_hash_stacker($entry);
187						}
188						elsif (ref($entry) eq "ARRAY") {
189						# ignore this. Arrays of Arrays cannot be created/supported
190						# with Config::General, because they are not accessible by
191						# any key (anonymous array-ref)
192	0					next;
193						}
194						else {
195	0					$entry = $this->_interpolate($key, $entry);
196						}
197	0					push @new, $entry;
198						}
199
200	0					return \@new;
201						}
202
203
204						1;
205
206						__END__
207
208
209						=head1 NAME
210
211						Config::General::Interpolated - Parse variables within Config files
212
213
214						=head1 SYNOPSIS
215
216						use Config::General;
217						$conf = new Config::General(
218						-ConfigFile => 'configfile',
219						-InterPolateVars => 1
220						);
221
222						=head1 DESCRIPTION
223
224						This is an internal module which makes it possible to interpolate
225						perl style variables in your config file (i.e. C<$variable>
226						or C<${variable}>).
227
228						Normally you don't call it directly.
229
230
231						=head1 VARIABLES
232
233						Variables can be defined everywhere in the config and can be used
234						afterwards as the value of an option. Variables cannot be used as
235						keys or as part of keys.
236
237						If you define a variable inside
238						a block or a named block then it is only visible within this block or
239						within blocks which are defined inside this block. Well - let's take a
240						look to an example:
241
242						# sample config which uses variables
243						basedir = /opt/ora
244						user = t_space
245						sys = unix
246						<table intern>
247						instance = INTERN
248						owner = $user # "t_space"
249						logdir = $basedir/log # "/opt/ora/log"
250						sys = macos
251						<procs>
252						misc1 = ${sys}_${instance} # macos_INTERN
253						misc2 = $user # "t_space"
254						</procs>
255						</table>
256
257						This will result in the following structure:
258
259						{
260						'basedir' => '/opt/ora',
261						'user' => 't_space'
262						'sys' => 'unix',
263						'table' => {
264						'intern' => {
265						'sys' => 'macos',
266						'logdir' => '/opt/ora/log',
267						'instance' => 'INTERN',
268						'owner' => 't_space',
269						'procs' => {
270						'misc1' => 'macos_INTERN',
271						'misc2' => 't_space'
272						}
273						}
274						}
275
276						As you can see, the variable B<sys> has been defined twice. Inside
277						the <procs> block a variable ${sys} has been used, which then were
278						interpolated into the value of B<sys> defined inside the <table>
279						block, not the sys variable one level above. If sys were not defined
280						inside the <table> block then the "global" variable B<sys> would have
281						been used instead with the value of "unix".
282
283						Variables inside double quotes will be interpolated, but variables
284						inside single quotes will B<not> interpolated. This is the same
285						behavior as you know of perl itself.
286
287						In addition you can surround variable names with curly braces to
288						avoid misinterpretation by the parser.
289
290						=head1 SEE ALSO
291
292						L<Config::General>
293
294						=head1 AUTHORS
295
296						Thomas Linden <tlinden \|AT\| cpan.org>
297						Autrijus Tang <autrijus@autrijus.org>
298						Wei-Hon Chen <plasmaball@pchome.com.tw>
299
300						=head1 COPYRIGHT
301
302						Copyright 2001 by Wei-Hon Chen E<lt>plasmaball@pchome.com.twE<gt>.
303						Copyright 2002-2007 by Thomas Linden <tlinden \|AT\| cpan.org>.
304
305						This program is free software; you can redistribute it and/or
306						modify it under the same terms as Perl itself.
307
308						See L<http://www.perl.com/perl/misc/Artistic.html>
309
310						=head1 VERSION
311
312						2.07
313
314						=cut
315
316