File Coverage

blib/lib/Config/General/Interpolated.pm
Criterion Covered Total %
statement 59 85 69.4
branch 16 34 47.0
condition n/a
subroutine 10 13 76.9
pod 1 1 100.0
total 86 133 64.6


line stmt bran cond sub pod time code
1             #
2             # Config::General::Interpolated - special Class based on Config::General
3             #
4             # Copyright (c) 2001 by Wei-Hon Chen .
5             # Copyright (c) 2000-2014 by Thomas Linden .
6             # All Rights Reserved. Std. disclaimer applies.
7             # Artistic License, same as perl itself. Have fun.
8             #
9              
10             package Config::General::Interpolated;
11             $Config::General::Interpolated::VERSION = "2.15";
12              
13 1     1   5 use strict;
  1         2  
  1         27  
14 1     1   4 use Carp;
  1         2  
  1         48  
15 1     1   6 use Config::General;
  1         1  
  1         24  
16 1     1   4 use Exporter ();
  1         1  
  1         36  
17              
18              
19             # Import stuff from Config::General
20 1     1   7 use vars qw(@ISA @EXPORT);
  1         1  
  1         870  
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             # , and I made some modifications.
43             # thanx, autrijus. :)
44 11     11   39 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-Z0-9_\-\.:\+,]+) # $3: capturing variable name (fix of #33447)
51             (?(2) # $4: if there's the opening curly...
52             \} # ... match closing curly
53             )
54             }x;
55 11         29 return $regex;
56             }
57              
58              
59             sub _interpolate {
60             #
61             # interpolate a scalar value and keep the result
62             # on the varstack.
63             #
64             # called directly by Config::General::_parse_value()
65             #
66 115     115   186 my ($this, $config, $key, $value) = @_;
67 115         130 my $quote_counter = 100;
68              
69             # some dirty trick to circumvent single quoted vars to be interpolated
70             # we remove all quotes and replace them with unique random literals,
71             # which will be replaced after interpolation with the original quotes
72             # fixes bug rt#35766
73 115         133 my %quotes;
74              
75 115 100       179 if(! $this->{AllowSingleQuoteInterpolation} ) {
76 113         170 $value =~ s/(\'[^\']+?\')/
77 2005         3275 my $key = "QUOTE" . ($quote_counter++) . "QUOTE";
78 2005         4430 $quotes{ $key } = $1;
79 2005         4900 $key;
80             /gex;
81             }
82              
83 115         443 $value =~ s{$this->{regex}}{
84 28         62 my $con = $1;
85 28         37 my $var = $3;
86 28 50       48 my $var_lc = $this->{LowerCaseNames} ? lc($var) : $var;
87              
88 28 50       45 if (exists $config->{__stack}->{$var_lc}) {
    0          
    0          
89 28         76 $con . $config->{__stack}->{$var_lc};
90             }
91             elsif ($this->{InterPolateEnv}) {
92             # may lead to vulnerabilities, by default flag turned off
93 0 0       0 if (defined($ENV{$var})) {
94 0         0 $con . $ENV{$var};
95             }
96             else {
97 0         0 $con;
98             }
99             }
100             elsif ($this->{StrictVars}) {
101 0         0 croak "Use of uninitialized variable (\$$var) while loading config entry: $key = $value\n";
102             }
103             else {
104             # be cool
105 0         0 $con;
106             }
107             }egx;
108              
109             # re-insert unaltered quotes
110             # fixes bug rt#35766
111 115         364 foreach my $quote (keys %quotes) {
112 2005         39919 $value =~ s/$quote/$quotes{$quote}/;
113             }
114              
115 115         555 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 11     11   18 my ($this, $config) = @_;
127              
128             # bugfix rt.cpan.org#46184, moved code from _interpolate() to here.
129 11 100       19 if ($this->{InterPolateEnv}) {
130             # may lead to vulnerabilities, by default flag turned off
131 1         8 for my $key (keys %ENV){
132 34         56 $config->{__stack}->{$key}=$ENV{$key};
133             }
134             }
135              
136 11         22 $config = $this->_var_hash_stacker($config);
137              
138 11         21 return $config;
139             }
140              
141             sub _var_hash_stacker {
142             #
143             # build a varstack of a given hash ref
144             #
145 12     12   17 my ($this, $config) = @_;
146              
147 12         12 foreach my $key (keys %{$config}) {
  12         27  
148 8 100       18 next if($key eq "__stack");
149 6 50       14 if (ref($config->{$key}) eq "ARRAY" ) {
    100          
150 0         0 $config->{$key} = $this->_var_array_stacker($config->{$key}, $key);
151             }
152             elsif (ref($config->{$key}) eq "HASH") {
153 1         2 my $tmphash = $config->{$key};
154 1         2 $tmphash->{__stack} = $config->{__stack};
155 1         3 $config->{$key} = $this->_var_hash_stacker($tmphash);
156             }
157             else {
158             # SCALAR
159 5         9 $config->{__stack}->{$key} = $config->{$key};
160             }
161             }
162              
163 12         20 return $config;
164             }
165              
166              
167             sub _var_array_stacker {
168             #
169             # same as _var_hash_stacker but for arrayrefs
170             #
171 0     0   0 my ($this, $config, $key) = @_;
172              
173 0         0 my @new;
174              
175 0         0 foreach my $entry (@{$config}) {
  0         0  
176 0 0       0 if (ref($entry) eq "HASH") {
    0          
177 0         0 $entry = $this->_var_hash_stacker($entry);
178             }
179             elsif (ref($entry) eq "ARRAY") {
180             # ignore this. Arrays of Arrays cannot be created/supported
181             # with Config::General, because they are not accessible by
182             # any key (anonymous array-ref)
183 0         0 next;
184             }
185             else {
186             #### $config->{__stack}->{$key} = $config->{$key};
187             # removed. a array of scalars (eg: option = [1,2,3]) cannot
188             # be used for interpolation (which one shall we use?!), so
189             # we ignore those types of lists.
190             # found by fbicknel, fixes rt.cpan.org#41570
191             }
192 0         0 push @new, $entry;
193             }
194              
195 0         0 return \@new;
196             }
197              
198             sub _clean_stack {
199             #
200             # recursively empty the variable stack
201             #
202 50     50   64 my ($this, $config) = @_;
203             #return $config; # DEBUG
204 50         54 foreach my $key (keys %{$config}) {
  50         99  
205 166 100       219 if ($key eq "__stack") {
206 48         107 delete $config->{__stack};
207 48         61 next;
208             }
209 118 50       243 if (ref($config->{$key}) eq "ARRAY" ) {
    100          
210 0         0 $config->{$key} = $this->_clean_array_stack($config->{$key});
211             }
212             elsif (ref($config->{$key}) eq "HASH") {
213 39         61 $config->{$key} = $this->_clean_stack($config->{$key});
214             }
215             }
216 50         90 return $config;
217             }
218              
219              
220             sub _clean_array_stack {
221             #
222             # same as _var_hash_stacker but for arrayrefs
223             #
224 0     0     my ($this, $config) = @_;
225              
226 0           my @new;
227              
228 0           foreach my $entry (@{$config}) {
  0            
229 0 0         if (ref($entry) eq "HASH") {
    0          
230 0           $entry = $this->_clean_stack($entry);
231             }
232             elsif (ref($entry) eq "ARRAY") {
233             # ignore this. Arrays of Arrays cannot be created/supported
234             # with Config::General, because they are not accessible by
235             # any key (anonymous array-ref)
236 0           next;
237             }
238 0           push @new, $entry;
239             }
240              
241 0           return \@new;
242             }
243              
244             1;
245              
246             __END__