Filename | /2home/ss5/perl5/perlbrew/perls/perl-5.12.3/lib/site_perl/5.12.3/Log/Log4perl/Config.pm |
Statements | Executed 43 statements in 3.78ms |
Calls | P | F | Exclusive Time |
Inclusive Time |
Subroutine |
---|---|---|---|---|---|
1 | 1 | 1 | 772µs | 814µs | BEGIN@14 | Log::Log4perl::Config::
1 | 1 | 1 | 634µs | 1.33ms | BEGIN@10 | Log::Log4perl::Config::
1 | 1 | 1 | 507µs | 757µs | BEGIN@13 | Log::Log4perl::Config::
1 | 1 | 1 | 414µs | 567µs | BEGIN@12 | Log::Log4perl::Config::
1 | 1 | 1 | 340µs | 453µs | BEGIN@11 | Log::Log4perl::Config::
1 | 1 | 1 | 18µs | 18µs | BEGIN@4 | Log::Log4perl::Config::
1 | 1 | 1 | 10µs | 12µs | BEGIN@5 | Log::Log4perl::Config::
1 | 1 | 1 | 8µs | 8µs | BEGIN@8 | Log::Log4perl::Config::
1 | 1 | 1 | 7µs | 18µs | BEGIN@6 | Log::Log4perl::Config::
1 | 1 | 1 | 6µs | 45µs | BEGIN@9 | Log::Log4perl::Config::
1 | 1 | 1 | 6µs | 32µs | BEGIN@16 | Log::Log4perl::Config::
0 | 0 | 0 | 0s | 0s | _init | Log::Log4perl::Config::
0 | 0 | 0 | 0s | 0s | add_global_cspec | Log::Log4perl::Config::
0 | 0 | 0 | 0s | 0s | add_layout_by_name | Log::Log4perl::Config::
0 | 0 | 0 | 0s | 0s | allow_code | Log::Log4perl::Config::
0 | 0 | 0 | 0s | 0s | allowed_code_ops | Log::Log4perl::Config::
0 | 0 | 0 | 0s | 0s | allowed_code_ops_convenience_map | Log::Log4perl::Config::
0 | 0 | 0 | 0s | 0s | boolean_to_perlish | Log::Log4perl::Config::
0 | 0 | 0 | 0s | 0s | compile_if_perl | Log::Log4perl::Config::
0 | 0 | 0 | 0s | 0s | compile_in_safe_cpt | Log::Log4perl::Config::
0 | 0 | 0 | 0s | 0s | config_file_read | Log::Log4perl::Config::
0 | 0 | 0 | 0s | 0s | config_is_sane | Log::Log4perl::Config::
0 | 0 | 0 | 0s | 0s | config_read | Log::Log4perl::Config::
0 | 0 | 0 | 0s | 0s | create_appender_instance | Log::Log4perl::Config::
0 | 0 | 0 | 0s | 0s | eval_if_perl | Log::Log4perl::Config::
0 | 0 | 0 | 0s | 0s | get_appender_by_name | Log::Log4perl::Config::
0 | 0 | 0 | 0s | 0s | init | Log::Log4perl::Config::
0 | 0 | 0 | 0s | 0s | init_and_watch | Log::Log4perl::Config::
0 | 0 | 0 | 0s | 0s | leaf_path_to_hash | Log::Log4perl::Config::
0 | 0 | 0 | 0s | 0s | leaf_paths | Log::Log4perl::Config::
0 | 0 | 0 | 0s | 0s | set_LWP_UserAgent | Log::Log4perl::Config::
0 | 0 | 0 | 0s | 0s | set_appender_by_name | Log::Log4perl::Config::
0 | 0 | 0 | 0s | 0s | unlog4j | Log::Log4perl::Config::
0 | 0 | 0 | 0s | 0s | var_subst | Log::Log4perl::Config::
0 | 0 | 0 | 0s | 0s | vars_shared_with_safe_compartment | Log::Log4perl::Config::
0 | 0 | 0 | 0s | 0s | watcher | Log::Log4perl::Config::
Line | State ments |
Time on line |
Calls | Time in subs |
Code |
---|---|---|---|---|---|
1 | ################################################## | ||||
2 | package Log::Log4perl::Config; | ||||
3 | ################################################## | ||||
4 | 3 | 27µs | 1 | 18µs | # spent 18µs within Log::Log4perl::Config::BEGIN@4 which was called:
# once (18µs+0s) by Log::Log4perl::Appender::BEGIN@10 at line 4 # spent 18µs making 1 call to Log::Log4perl::Config::BEGIN@4 |
5 | 3 | 18µs | 2 | 14µs | # spent 12µs (10+2) within Log::Log4perl::Config::BEGIN@5 which was called:
# once (10µs+2µs) by Log::Log4perl::Appender::BEGIN@10 at line 5 # spent 12µs making 1 call to Log::Log4perl::Config::BEGIN@5
# spent 2µs making 1 call to strict::import |
6 | 3 | 16µs | 2 | 30µs | # spent 18µs (7+11) within Log::Log4perl::Config::BEGIN@6 which was called:
# once (7µs+11µs) by Log::Log4perl::Appender::BEGIN@10 at line 6 # spent 18µs making 1 call to Log::Log4perl::Config::BEGIN@6
# spent 12µs making 1 call to warnings::import |
7 | |||||
8 | 3 | 22µs | 1 | 8µs | # spent 8µs within Log::Log4perl::Config::BEGIN@8 which was called:
# once (8µs+0s) by Log::Log4perl::Appender::BEGIN@10 at line 8 # spent 8µs making 1 call to Log::Log4perl::Config::BEGIN@8 |
9 | 3 | 17µs | 2 | 84µs | # spent 45µs (6+39) within Log::Log4perl::Config::BEGIN@9 which was called:
# once (6µs+39µs) by Log::Log4perl::Appender::BEGIN@10 at line 9 # spent 45µs making 1 call to Log::Log4perl::Config::BEGIN@9
# spent 39µs making 1 call to Log::Log4perl::Level::import |
10 | 3 | 82µs | 1 | 1.33ms | # spent 1.33ms (634µs+701µs) within Log::Log4perl::Config::BEGIN@10 which was called:
# once (634µs+701µs) by Log::Log4perl::Appender::BEGIN@10 at line 10 # spent 1.33ms making 1 call to Log::Log4perl::Config::BEGIN@10 |
11 | 3 | 86µs | 1 | 453µs | # spent 453µs (340+113) within Log::Log4perl::Config::BEGIN@11 which was called:
# once (340µs+113µs) by Log::Log4perl::Appender::BEGIN@10 at line 11 # spent 453µs making 1 call to Log::Log4perl::Config::BEGIN@11 |
12 | 3 | 77µs | 1 | 567µs | # spent 567µs (414+153) within Log::Log4perl::Config::BEGIN@12 which was called:
# once (414µs+153µs) by Log::Log4perl::Appender::BEGIN@10 at line 12 # spent 567µs making 1 call to Log::Log4perl::Config::BEGIN@12 |
13 | 3 | 78µs | 1 | 757µs | # spent 757µs (507+250) within Log::Log4perl::Config::BEGIN@13 which was called:
# once (507µs+250µs) by Log::Log4perl::Appender::BEGIN@10 at line 13 # spent 757µs making 1 call to Log::Log4perl::Config::BEGIN@13 |
14 | 3 | 83µs | 1 | 814µs | # spent 814µs (772+42) within Log::Log4perl::Config::BEGIN@14 which was called:
# once (772µs+42µs) by Log::Log4perl::Appender::BEGIN@10 at line 14 # spent 814µs making 1 call to Log::Log4perl::Config::BEGIN@14 |
15 | |||||
16 | 3 | 3.26ms | 2 | 59µs | # spent 32µs (6+26) within Log::Log4perl::Config::BEGIN@16 which was called:
# once (6µs+26µs) by Log::Log4perl::Appender::BEGIN@10 at line 16 # spent 32µs making 1 call to Log::Log4perl::Config::BEGIN@16
# spent 26µs making 1 call to constant::import |
17 | |||||
18 | 1 | 800ns | our $CONFIG_FILE_READS = 0; | ||
19 | 1 | 200ns | our $CONFIG_INTEGRITY_CHECK = 1; | ||
20 | 1 | 300ns | our $CONFIG_INTEGRITY_ERROR = undef; | ||
21 | |||||
22 | 1 | 200ns | our $WATCHER; | ||
23 | 1 | 100ns | our $DEFAULT_WATCH_DELAY = 60; # seconds | ||
24 | 1 | 900ns | our $OPTS = {}; | ||
25 | 1 | 100ns | our $OLD_CONFIG; | ||
26 | 1 | 100ns | our $LOGGERS_DEFINED; | ||
27 | |||||
28 | ########################################### | ||||
29 | sub init { | ||||
30 | ########################################### | ||||
31 | Log::Log4perl::Logger->reset(); | ||||
32 | |||||
33 | undef $WATCHER; # just in case there's a one left over (e.g. test cases) | ||||
34 | |||||
35 | return _init(@_); | ||||
36 | } | ||||
37 | |||||
38 | ########################################### | ||||
39 | sub watcher { | ||||
40 | ########################################### | ||||
41 | return $WATCHER; | ||||
42 | } | ||||
43 | |||||
44 | ########################################### | ||||
45 | sub init_and_watch { | ||||
46 | ########################################### | ||||
47 | my ($class, $config, $delay, $opts) = @_; | ||||
48 | # delay can be a signal name - in this case we're gonna | ||||
49 | # set up a signal handler. | ||||
50 | |||||
51 | if(defined $WATCHER) { | ||||
52 | $config = $WATCHER->file(); | ||||
53 | if(defined $Log::Log4perl::Config::Watch::SIGNAL_CAUGHT) { | ||||
54 | $delay = $WATCHER->signal(); | ||||
55 | } else { | ||||
56 | $delay = $WATCHER->check_interval(); | ||||
57 | } | ||||
58 | } | ||||
59 | |||||
60 | print "init_and_watch ($config-$delay). Resetting.\n" if _INTERNAL_DEBUG; | ||||
61 | |||||
62 | Log::Log4perl::Logger->reset(); | ||||
63 | |||||
64 | defined ($delay) or $delay = $DEFAULT_WATCH_DELAY; | ||||
65 | |||||
66 | if (ref $config) { | ||||
67 | die "Log4perl can only watch a file, not a string of " . | ||||
68 | "configuration information"; | ||||
69 | }elsif ($config =~ m!^(https?|ftp|wais|gopher|file):!){ | ||||
70 | die "Log4perl can only watch a file, not a url like $config"; | ||||
71 | } | ||||
72 | |||||
73 | if($delay =~ /\D/) { | ||||
74 | $WATCHER = Log::Log4perl::Config::Watch->new( | ||||
75 | file => $config, | ||||
76 | signal => $delay, | ||||
77 | l4p_internal => 1, | ||||
78 | ); | ||||
79 | } else { | ||||
80 | $WATCHER = Log::Log4perl::Config::Watch->new( | ||||
81 | file => $config, | ||||
82 | check_interval => $delay, | ||||
83 | l4p_internal => 1, | ||||
84 | ); | ||||
85 | } | ||||
86 | |||||
87 | if(defined $opts) { | ||||
88 | die "Parameter $opts needs to be a hash ref" if ref($opts) ne "HASH"; | ||||
89 | $OPTS = $opts; | ||||
90 | } | ||||
91 | |||||
92 | eval { _init($class, $config); }; | ||||
93 | |||||
94 | if($@) { | ||||
95 | die "$@" unless defined $OLD_CONFIG; | ||||
96 | # Call _init with a pre-parsed config to go back to old setting | ||||
97 | _init($class, undef, $OLD_CONFIG); | ||||
98 | warn "Loading new config failed, reverted to old one\n"; | ||||
99 | } | ||||
100 | } | ||||
101 | |||||
102 | ################################################## | ||||
103 | sub _init { | ||||
104 | ################################################## | ||||
105 | my($class, $config, $data) = @_; | ||||
106 | |||||
107 | my %additivity = (); | ||||
108 | |||||
109 | $LOGGERS_DEFINED = 0; | ||||
110 | |||||
111 | print "Calling _init\n" if _INTERNAL_DEBUG; | ||||
112 | |||||
113 | #keep track so we don't create the same one twice | ||||
114 | my %appenders_created = (); | ||||
115 | |||||
116 | #some appenders need to run certain subroutines right at the | ||||
117 | #end of the configuration phase, when all settings are in place. | ||||
118 | my @post_config_subs = (); | ||||
119 | |||||
120 | # This logic is probably suited to win an obfuscated programming | ||||
121 | # contest. It desperately needs to be rewritten. | ||||
122 | # Basically, it works like this: | ||||
123 | # config_read() reads the entire config file into a hash of hashes: | ||||
124 | # log4j.logger.foo.bar.baz: WARN, A1 | ||||
125 | # gets transformed into | ||||
126 | # $data->{log4j}->{logger}->{foo}->{bar}->{baz} = "WARN, A1"; | ||||
127 | # The code below creates the necessary loggers, sets the appenders | ||||
128 | # and the layouts etc. | ||||
129 | # In order to transform parts of this tree back into identifiers | ||||
130 | # (like "foo.bar.baz"), we're using the leaf_paths functions below. | ||||
131 | # Pretty scary. But it allows the lines of the config file to be | ||||
132 | # in *arbitrary* order. | ||||
133 | |||||
134 | $data = config_read($config) unless defined $data; | ||||
135 | |||||
136 | if(_INTERNAL_DEBUG) { | ||||
137 | require Data::Dumper; | ||||
138 | Data::Dumper->import(); | ||||
139 | print Data::Dumper::Dumper($data); | ||||
140 | } | ||||
141 | |||||
142 | my @loggers = (); | ||||
143 | my %filter_names = (); | ||||
144 | |||||
145 | my $system_wide_threshold; | ||||
146 | |||||
147 | # Autocorrect the rootlogger/rootLogger typo | ||||
148 | if(exists $data->{rootlogger} and | ||||
149 | ! exists $data->{rootLogger}) { | ||||
150 | $data->{rootLogger} = $data->{rootlogger}; | ||||
151 | } | ||||
152 | |||||
153 | # Find all logger definitions in the conf file. Start | ||||
154 | # with root loggers. | ||||
155 | if(exists $data->{rootLogger}) { | ||||
156 | $LOGGERS_DEFINED++; | ||||
157 | push @loggers, ["", $data->{rootLogger}->{value}]; | ||||
158 | } | ||||
159 | |||||
160 | # Check if we've got a system-wide threshold setting | ||||
161 | if(exists $data->{threshold}) { | ||||
162 | # yes, we do. | ||||
163 | $system_wide_threshold = $data->{threshold}->{value}; | ||||
164 | } | ||||
165 | |||||
166 | if (exists $data->{oneMessagePerAppender}){ | ||||
167 | $Log::Log4perl::one_message_per_appender = | ||||
168 | $data->{oneMessagePerAppender}->{value}; | ||||
169 | } | ||||
170 | |||||
171 | # Boolean filters | ||||
172 | my %boolean_filters = (); | ||||
173 | |||||
174 | # Continue with lower level loggers. Both 'logger' and 'category' | ||||
175 | # are valid keywords. Also 'additivity' is one, having a logger | ||||
176 | # attached. We'll differenciate between the two further down. | ||||
177 | for my $key (qw(logger category additivity PatternLayout filter)) { | ||||
178 | |||||
179 | if(exists $data->{$key}) { | ||||
180 | |||||
181 | for my $path (@{leaf_paths($data->{$key})}) { | ||||
182 | |||||
183 | print "Path before: @$path\n" if _INTERNAL_DEBUG; | ||||
184 | |||||
185 | my $value = boolean_to_perlish(pop @$path); | ||||
186 | |||||
187 | pop @$path; # Drop the 'value' keyword part | ||||
188 | |||||
189 | if($key eq "additivity") { | ||||
190 | # This isn't a logger but an additivity setting. | ||||
191 | # Save it in a hash under the logger's name for later. | ||||
192 | $additivity{join('.', @$path)} = $value; | ||||
193 | |||||
194 | #a global user-defined conversion specifier (cspec) | ||||
195 | }elsif ($key eq "PatternLayout"){ | ||||
196 | &add_global_cspec(@$path[-1], $value); | ||||
197 | |||||
198 | }elsif ($key eq "filter"){ | ||||
199 | print "Found entry @$path\n" if _INTERNAL_DEBUG; | ||||
200 | $filter_names{@$path[0]}++; | ||||
201 | } else { | ||||
202 | |||||
203 | if (ref($value) eq "ARRAY") { | ||||
204 | die "Multiple definitions of logger ".join('.',@$path)." in log4perl config"; | ||||
205 | } | ||||
206 | |||||
207 | # This is a regular logger | ||||
208 | $LOGGERS_DEFINED++; | ||||
209 | push @loggers, [join('.', @$path), $value]; | ||||
210 | } | ||||
211 | } | ||||
212 | } | ||||
213 | } | ||||
214 | |||||
215 | # Now go over all filters found by name | ||||
216 | for my $filter_name (keys %filter_names) { | ||||
217 | |||||
218 | print "Checking filter $filter_name\n" if _INTERNAL_DEBUG; | ||||
219 | |||||
220 | # The boolean filter needs all other filters already | ||||
221 | # initialized, defer its initialization | ||||
222 | if($data->{filter}->{$filter_name}->{value} eq | ||||
223 | "Log::Log4perl::Filter::Boolean") { | ||||
224 | print "Boolean filter ($filter_name)\n" if _INTERNAL_DEBUG; | ||||
225 | $boolean_filters{$filter_name}++; | ||||
226 | next; | ||||
227 | } | ||||
228 | |||||
229 | my $type = $data->{filter}->{$filter_name}->{value}; | ||||
230 | if(my $code = compile_if_perl($type)) { | ||||
231 | $type = $code; | ||||
232 | } | ||||
233 | |||||
234 | print "Filter $filter_name is of type $type\n" if _INTERNAL_DEBUG; | ||||
235 | |||||
236 | my $filter; | ||||
237 | |||||
238 | if(ref($type) eq "CODE") { | ||||
239 | # Subroutine - map into generic Log::Log4perl::Filter class | ||||
240 | $filter = Log::Log4perl::Filter->new($filter_name, $type); | ||||
241 | } else { | ||||
242 | # Filter class | ||||
243 | die "Filter class '$type' doesn't exist" unless | ||||
244 | Log::Log4perl::Util::module_available($type); | ||||
245 | eval "require $type" or die "Require of $type failed ($!)"; | ||||
246 | |||||
247 | # Invoke with all defined parameter | ||||
248 | # key/values (except the key 'value' which is the entry | ||||
249 | # for the class) | ||||
250 | $filter = $type->new(name => $filter_name, | ||||
251 | map { $_ => $data->{filter}->{$filter_name}->{$_}->{value} } | ||||
252 | grep { $_ ne "value" } | ||||
253 | keys %{$data->{filter}->{$filter_name}}); | ||||
254 | } | ||||
255 | # Register filter with the global filter registry | ||||
256 | $filter->register(); | ||||
257 | } | ||||
258 | |||||
259 | # Initialize boolean filters (they need the other filters to be | ||||
260 | # initialized to be able to compile their logic) | ||||
261 | for my $name (keys %boolean_filters) { | ||||
262 | my $logic = $data->{filter}->{$name}->{logic}->{value}; | ||||
263 | die "No logic defined for boolean filter $name" unless defined $logic; | ||||
264 | my $filter = Log::Log4perl::Filter::Boolean->new( | ||||
265 | name => $name, | ||||
266 | logic => $logic); | ||||
267 | $filter->register(); | ||||
268 | } | ||||
269 | |||||
270 | for (@loggers) { | ||||
271 | my($name, $value) = @$_; | ||||
272 | |||||
273 | my $logger = Log::Log4perl::Logger->get_logger($name); | ||||
274 | my ($level, @appnames) = split /\s*,\s*/, $value; | ||||
275 | |||||
276 | $logger->level( | ||||
277 | Log::Log4perl::Level::to_priority($level), | ||||
278 | 'dont_reset_all'); | ||||
279 | |||||
280 | if(exists $additivity{$name}) { | ||||
281 | $logger->additivity($additivity{$name}); | ||||
282 | } | ||||
283 | |||||
284 | for my $appname (@appnames) { | ||||
285 | |||||
286 | my $appender = create_appender_instance( | ||||
287 | $data, $appname, \%appenders_created, \@post_config_subs, | ||||
288 | $system_wide_threshold); | ||||
289 | |||||
290 | $logger->add_appender($appender, 'dont_reset_all'); | ||||
291 | set_appender_by_name($appname, $appender, \%appenders_created); | ||||
292 | } | ||||
293 | } | ||||
294 | |||||
295 | #run post_config subs | ||||
296 | for(@post_config_subs) { | ||||
297 | $_->(); | ||||
298 | } | ||||
299 | |||||
300 | #now we're done, set up all the output methods (e.g. ->debug('...')) | ||||
301 | Log::Log4perl::Logger::reset_all_output_methods(); | ||||
302 | |||||
303 | #Run a sanity test on the config not disabled | ||||
304 | if($Log::Log4perl::Config::CONFIG_INTEGRITY_CHECK and | ||||
305 | !config_is_sane()) { | ||||
306 | warn "Log::Log4perl configuration looks suspicious: ", | ||||
307 | "$CONFIG_INTEGRITY_ERROR"; | ||||
308 | } | ||||
309 | |||||
310 | # Successful init(), save config for later | ||||
311 | $OLD_CONFIG = $data; | ||||
312 | |||||
313 | $Log::Log4perl::Logger::INITIALIZED = 1; | ||||
314 | } | ||||
315 | |||||
316 | ################################################## | ||||
317 | sub config_is_sane { | ||||
318 | ################################################## | ||||
319 | if(! $LOGGERS_DEFINED) { | ||||
320 | $CONFIG_INTEGRITY_ERROR = "No loggers defined"; | ||||
321 | return 0; | ||||
322 | } | ||||
323 | |||||
324 | if(scalar keys %Log::Log4perl::Logger::APPENDER_BY_NAME == 0) { | ||||
325 | $CONFIG_INTEGRITY_ERROR = "No appenders defined"; | ||||
326 | return 0; | ||||
327 | } | ||||
328 | |||||
329 | return 1; | ||||
330 | } | ||||
331 | |||||
332 | ################################################## | ||||
333 | sub create_appender_instance { | ||||
334 | ################################################## | ||||
335 | my($data, $appname, $appenders_created, $post_config_subs, | ||||
336 | $system_wide_threshold) = @_; | ||||
337 | |||||
338 | my $appenderclass = get_appender_by_name( | ||||
339 | $data, $appname, $appenders_created); | ||||
340 | |||||
341 | print "appenderclass=$appenderclass\n" if _INTERNAL_DEBUG; | ||||
342 | |||||
343 | my $appender; | ||||
344 | |||||
345 | if (ref $appenderclass) { | ||||
346 | $appender = $appenderclass; | ||||
347 | } else { | ||||
348 | die "ERROR: you didn't tell me how to " . | ||||
349 | "implement your appender '$appname'" | ||||
350 | unless $appenderclass; | ||||
351 | |||||
352 | if (Log::Log4perl::JavaMap::translate($appenderclass)){ | ||||
353 | # It's Java. Try to map | ||||
354 | print "Trying to map Java $appname\n" if _INTERNAL_DEBUG; | ||||
355 | $appender = Log::Log4perl::JavaMap::get($appname, | ||||
356 | $data->{appender}->{$appname}); | ||||
357 | |||||
358 | }else{ | ||||
359 | # It's Perl | ||||
360 | my @params = grep { $_ ne "layout" and | ||||
361 | $_ ne "value" | ||||
362 | } keys %{$data->{appender}->{$appname}}; | ||||
363 | |||||
364 | my %param = (); | ||||
365 | foreach my $pname (@params){ | ||||
366 | #this could be simple value like | ||||
367 | #{appender}{myAppender}{file}{value} => 'log.txt' | ||||
368 | #or a structure like | ||||
369 | #{appender}{myAppender}{login} => | ||||
370 | # { name => {value => 'bob'}, | ||||
371 | # pwd => {value => 'xxx'}, | ||||
372 | # } | ||||
373 | #in the latter case we send a hashref to the appender | ||||
374 | if (exists $data->{appender}{$appname} | ||||
375 | {$pname}{value} ) { | ||||
376 | $param{$pname} = $data->{appender}{$appname} | ||||
377 | {$pname}{value}; | ||||
378 | }else{ | ||||
379 | $param{$pname} = {map {$_ => $data->{appender} | ||||
380 | {$appname} | ||||
381 | {$pname} | ||||
382 | {$_} | ||||
383 | {value}} | ||||
384 | keys %{$data->{appender} | ||||
385 | {$appname} | ||||
386 | {$pname}} | ||||
387 | }; | ||||
388 | } | ||||
389 | |||||
390 | } | ||||
391 | |||||
392 | my $depends_on = []; | ||||
393 | |||||
394 | $appender = Log::Log4perl::Appender->new( | ||||
395 | $appenderclass, | ||||
396 | name => $appname, | ||||
397 | l4p_post_config_subs => $post_config_subs, | ||||
398 | l4p_depends_on => $depends_on, | ||||
399 | %param, | ||||
400 | ); | ||||
401 | |||||
402 | for my $dependency (@$depends_on) { | ||||
403 | # If this appender indicates that it needs other appenders | ||||
404 | # to exist (e.g. because it's a composite appender that | ||||
405 | # relays messages on to its appender-refs) then we're | ||||
406 | # creating their instances here. Reason for this is that | ||||
407 | # these appenders are not attached to any logger and are | ||||
408 | # therefore missed by the config parser which goes through | ||||
409 | # the defined loggers and just creates *their* attached | ||||
410 | # appenders. | ||||
411 | $appender->composite(1); | ||||
412 | next if exists $appenders_created->{$appname}; | ||||
413 | my $app = create_appender_instance($data, $dependency, | ||||
414 | $appenders_created, | ||||
415 | $post_config_subs); | ||||
416 | # If the appender appended a subroutine to $post_config_subs | ||||
417 | # (a reference to an array of subroutines) | ||||
418 | # here, the configuration parser will later execute this | ||||
419 | # method. This is used by a composite appender which needs | ||||
420 | # to make sure all of its appender-refs are available when | ||||
421 | # all configuration settings are done. | ||||
422 | |||||
423 | # Smuggle this sub-appender into the hash of known appenders | ||||
424 | # without attaching it to any logger directly. | ||||
425 | $ | ||||
426 | Log::Log4perl::Logger::APPENDER_BY_NAME{$dependency} = $app; | ||||
427 | } | ||||
428 | } | ||||
429 | } | ||||
430 | |||||
431 | add_layout_by_name($data, $appender, $appname) unless | ||||
432 | $appender->composite(); | ||||
433 | |||||
434 | # Check for appender thresholds | ||||
435 | my $threshold = | ||||
436 | $data->{appender}->{$appname}->{Threshold}->{value}; | ||||
437 | |||||
438 | if(defined $system_wide_threshold and | ||||
439 | !defined $threshold) { | ||||
440 | $threshold = $system_wide_threshold; | ||||
441 | } | ||||
442 | |||||
443 | if(defined $threshold) { | ||||
444 | # Need to split into two lines because of CVS | ||||
445 | $appender->threshold($ | ||||
446 | Log::Log4perl::Level::PRIORITY{$threshold}); | ||||
447 | } | ||||
448 | |||||
449 | # Check for custom filters attached to the appender | ||||
450 | my $filtername = | ||||
451 | $data->{appender}->{$appname}->{Filter}->{value}; | ||||
452 | if(defined $filtername) { | ||||
453 | # Need to split into two lines because of CVS | ||||
454 | my $filter = Log::Log4perl::Filter::by_name($filtername); | ||||
455 | die "Filter $filtername doesn't exist" unless defined $filter; | ||||
456 | $appender->filter($filter); | ||||
457 | } | ||||
458 | |||||
459 | if(defined $system_wide_threshold and | ||||
460 | defined $threshold and | ||||
461 | $ | ||||
462 | Log::Log4perl::Level::PRIORITY{$system_wide_threshold} > | ||||
463 | $ | ||||
464 | Log::Log4perl::Level::PRIORITY{$threshold} | ||||
465 | ) { | ||||
466 | $appender->threshold($ | ||||
467 | Log::Log4perl::Level::PRIORITY{$system_wide_threshold}); | ||||
468 | } | ||||
469 | |||||
470 | if(exists $data->{appender}->{$appname}->{threshold}) { | ||||
471 | die "invalid keyword 'threshold' - perhaps you meant 'Threshold'?"; | ||||
472 | } | ||||
473 | |||||
474 | return $appender; | ||||
475 | } | ||||
476 | |||||
477 | ########################################### | ||||
478 | sub add_layout_by_name { | ||||
479 | ########################################### | ||||
480 | my($data, $appender, $appender_name) = @_; | ||||
481 | |||||
482 | my $layout_class = $data->{appender}->{$appender_name}->{layout}->{value}; | ||||
483 | |||||
484 | die "Layout not specified for appender $appender_name" unless $layout_class; | ||||
485 | |||||
486 | $layout_class =~ s/org.apache.log4j./Log::Log4perl::Layout::/; | ||||
487 | |||||
488 | # Check if we have this layout class | ||||
489 | if(!Log::Log4perl::Util::module_available($layout_class)) { | ||||
490 | if(Log::Log4perl::Util::module_available( | ||||
491 | "Log::Log4perl::Layout::$layout_class")) { | ||||
492 | # Someone used the layout shortcut, use the fully qualified | ||||
493 | # module name instead. | ||||
494 | $layout_class = "Log::Log4perl::Layout::$layout_class"; | ||||
495 | } else { | ||||
496 | die "ERROR: trying to set layout for $appender_name to " . | ||||
497 | "'$layout_class' failed"; | ||||
498 | } | ||||
499 | } | ||||
500 | |||||
501 | eval "require $layout_class" or | ||||
502 | die "Require to $layout_class failed ($!)"; | ||||
503 | |||||
504 | $appender->layout($layout_class->new( | ||||
505 | $data->{appender}->{$appender_name}->{layout}, | ||||
506 | )); | ||||
507 | } | ||||
508 | |||||
509 | ########################################### | ||||
510 | sub get_appender_by_name { | ||||
511 | ########################################### | ||||
512 | my($data, $name, $appenders_created) = @_; | ||||
513 | |||||
514 | if (exists $appenders_created->{$name}) { | ||||
515 | return $appenders_created->{$name}; | ||||
516 | } else { | ||||
517 | return $data->{appender}->{$name}->{value}; | ||||
518 | } | ||||
519 | } | ||||
520 | |||||
521 | ########################################### | ||||
522 | sub set_appender_by_name { | ||||
523 | ########################################### | ||||
524 | # keep track of appenders we've already created | ||||
525 | ########################################### | ||||
526 | my($appname, $appender, $appenders_created) = @_; | ||||
527 | |||||
528 | $appenders_created->{$appname} ||= $appender; | ||||
529 | } | ||||
530 | |||||
531 | ################################################## | ||||
532 | sub add_global_cspec { | ||||
533 | ################################################## | ||||
534 | # the config file said | ||||
535 | # log4j.PatternLayout.cspec.Z=sub {return $$*2} | ||||
536 | ################################################## | ||||
537 | my ($letter, $perlcode) = @_; | ||||
538 | |||||
539 | die "error: only single letters allowed in log4j.PatternLayout.cspec.$letter" | ||||
540 | unless ($letter =~ /^[a-zA-Z]$/); | ||||
541 | |||||
542 | Log::Log4perl::Layout::PatternLayout::add_global_cspec($letter, $perlcode); | ||||
543 | } | ||||
544 | |||||
545 | 1 | 300ns | my $LWP_USER_AGENT; | ||
546 | sub set_LWP_UserAgent | ||||
547 | { | ||||
548 | $LWP_USER_AGENT = shift; | ||||
549 | } | ||||
550 | |||||
551 | |||||
552 | ########################################### | ||||
553 | sub config_read { | ||||
554 | ########################################### | ||||
555 | # Read the lib4j configuration and store the | ||||
556 | # values into a nested hash structure. | ||||
557 | ########################################### | ||||
558 | my($config) = @_; | ||||
559 | |||||
560 | die "Configuration not defined" unless defined $config; | ||||
561 | |||||
562 | my @text; | ||||
563 | my $parser; | ||||
564 | |||||
565 | $CONFIG_FILE_READS++; # Count for statistical purposes | ||||
566 | |||||
567 | my $data = {}; | ||||
568 | |||||
569 | if (ref($config) eq 'HASH') { # convert the hashref into a list | ||||
570 | # of name/value pairs | ||||
571 | print "Reading config from hash\n" if _INTERNAL_DEBUG; | ||||
572 | @text = (); | ||||
573 | for my $key ( keys %$config ) { | ||||
574 | if( ref( $config->{$key} ) eq "CODE" ) { | ||||
575 | $config->{$key} = $config->{$key}->(); | ||||
576 | } | ||||
577 | push @text, $key . '=' . $config->{$key} . "\n"; | ||||
578 | } | ||||
579 | } elsif (ref $config eq 'SCALAR') { | ||||
580 | print "Reading config from scalar\n" if _INTERNAL_DEBUG; | ||||
581 | @text = split(/\n/,$$config); | ||||
582 | |||||
583 | } elsif (ref $config eq 'GLOB' or | ||||
584 | ref $config eq 'IO::File') { | ||||
585 | # If we have a file handle, just call the reader | ||||
586 | print "Reading config from file handle\n" if _INTERNAL_DEBUG; | ||||
587 | config_file_read($config, \@text); | ||||
588 | |||||
589 | } elsif (ref $config) { | ||||
590 | # Caller provided a config parser object, which already | ||||
591 | # knows which file (or DB or whatever) to parse. | ||||
592 | print "Reading config from parser object\n" if _INTERNAL_DEBUG; | ||||
593 | $data = $config->parse(); | ||||
594 | return $data; | ||||
595 | |||||
596 | #TBD | ||||
597 | }elsif ($config =~ m|^ldap://|){ | ||||
598 | if(! Log::Log4perl::Util::module_available("Net::LDAP")) { | ||||
599 | die "Log4perl: missing Net::LDAP needed to parse LDAP urls\n$@\n"; | ||||
600 | } | ||||
601 | |||||
602 | require Net::LDAP; | ||||
603 | require Log::Log4perl::Config::LDAPConfigurator; | ||||
604 | |||||
605 | return Log::Log4perl::Config::LDAPConfigurator->new->parse($config); | ||||
606 | |||||
607 | }else{ | ||||
608 | |||||
609 | if ($config =~ /^(https?|ftp|wais|gopher|file):/){ | ||||
610 | my ($result, $ua); | ||||
611 | |||||
612 | die "LWP::UserAgent not available" unless | ||||
613 | Log::Log4perl::Util::module_available("LWP::UserAgent"); | ||||
614 | |||||
615 | require LWP::UserAgent; | ||||
616 | unless (defined $LWP_USER_AGENT) { | ||||
617 | $LWP_USER_AGENT = LWP::UserAgent->new; | ||||
618 | |||||
619 | # Load proxy settings from environment variables, i.e.: | ||||
620 | # http_proxy, ftp_proxy, no_proxy etc (see LWP::UserAgent) | ||||
621 | # You need these to go thru firewalls. | ||||
622 | $LWP_USER_AGENT->env_proxy; | ||||
623 | } | ||||
624 | $ua = $LWP_USER_AGENT; | ||||
625 | |||||
626 | my $req = new HTTP::Request GET => $config; | ||||
627 | my $res = $ua->request($req); | ||||
628 | |||||
629 | if ($res->is_success) { | ||||
630 | @text = split(/\n/, $res->content); | ||||
631 | } else { | ||||
632 | die "Log4perl couln't get $config, ". | ||||
633 | $res->message." "; | ||||
634 | } | ||||
635 | }else{ | ||||
636 | print "Reading config from file '$config'\n" if _INTERNAL_DEBUG; | ||||
637 | open FILE, "<$config" or die "Cannot open config file '$config' - $!"; | ||||
638 | print "Reading ", -s $config, " bytes.\n" if _INTERNAL_DEBUG; | ||||
639 | config_file_read(\*FILE, \@text); | ||||
640 | close FILE; | ||||
641 | } | ||||
642 | } | ||||
643 | |||||
644 | print "Reading $config: [@text]\n" if _INTERNAL_DEBUG; | ||||
645 | |||||
646 | if(! grep /\S/, @text) { | ||||
647 | return $data; | ||||
648 | } | ||||
649 | |||||
650 | if ($text[0] =~ /^<\?xml /) { | ||||
651 | |||||
652 | die "XML::DOM not available" unless | ||||
653 | Log::Log4perl::Util::module_available("XML::DOM"); | ||||
654 | |||||
655 | require XML::DOM; | ||||
656 | require Log::Log4perl::Config::DOMConfigurator; | ||||
657 | |||||
658 | XML::DOM->VERSION($Log::Log4perl::DOM_VERSION_REQUIRED); | ||||
659 | $parser = Log::Log4perl::Config::DOMConfigurator->new(); | ||||
660 | $data = $parser->parse(\@text); | ||||
661 | } else { | ||||
662 | $parser = Log::Log4perl::Config::PropertyConfigurator->new(); | ||||
663 | $data = $parser->parse(\@text); | ||||
664 | } | ||||
665 | |||||
666 | $data = $parser->parse_post_process( $data, leaf_paths($data) ); | ||||
667 | |||||
668 | return $data; | ||||
669 | } | ||||
670 | |||||
671 | |||||
672 | ########################################### | ||||
673 | sub config_file_read { | ||||
674 | ########################################### | ||||
675 | my($handle, $linesref) = @_; | ||||
676 | |||||
677 | # Dennis Gregorovic <dgregor@redhat.com> added this | ||||
678 | # to protect apps which are tinkering with $/ globally. | ||||
679 | local $/ = "\n"; | ||||
680 | |||||
681 | @$linesref = <$handle>; | ||||
682 | } | ||||
683 | |||||
684 | ########################################### | ||||
685 | sub unlog4j { | ||||
686 | ########################################### | ||||
687 | my ($string) = @_; | ||||
688 | |||||
689 | $string =~ s#^org\.apache\.##; | ||||
690 | $string =~ s#^log4j\.##; | ||||
691 | $string =~ s#^l4p\.##; | ||||
692 | $string =~ s#^log4perl\.##i; | ||||
693 | |||||
694 | $string =~ s#\.#::#g; | ||||
695 | |||||
696 | return $string; | ||||
697 | } | ||||
698 | |||||
699 | ############################################################ | ||||
700 | sub leaf_paths { | ||||
701 | ############################################################ | ||||
702 | # Takes a reference to a hash of hashes structure of | ||||
703 | # arbitrary depth, walks the tree and returns a reference | ||||
704 | # to an array of all possible leaf paths (each path is an | ||||
705 | # array again). | ||||
706 | # Example: { a => { b => { c => d }, e => f } } would generate | ||||
707 | # [ [a, b, c, d], [a, e, f] ] | ||||
708 | ############################################################ | ||||
709 | my ($root) = @_; | ||||
710 | |||||
711 | my @stack = (); | ||||
712 | my @result = (); | ||||
713 | |||||
714 | push @stack, [$root, []]; | ||||
715 | |||||
716 | while(@stack) { | ||||
717 | my $item = pop @stack; | ||||
718 | |||||
719 | my($node, $path) = @$item; | ||||
720 | |||||
721 | if(ref($node) eq "HASH") { | ||||
722 | for(keys %$node) { | ||||
723 | push @stack, [$node->{$_}, [@$path, $_]]; | ||||
724 | } | ||||
725 | } else { | ||||
726 | push @result, [@$path, $node]; | ||||
727 | } | ||||
728 | } | ||||
729 | return \@result; | ||||
730 | } | ||||
731 | |||||
732 | ########################################### | ||||
733 | sub leaf_path_to_hash { | ||||
734 | ########################################### | ||||
735 | my($leaf_path, $data) = @_; | ||||
736 | |||||
737 | my $ref = \$data; | ||||
738 | |||||
739 | for my $part ( @$leaf_path[0..$#$leaf_path-1] ) { | ||||
740 | $ref = \$$ref->{ $part }; | ||||
741 | } | ||||
742 | |||||
743 | return $ref; | ||||
744 | } | ||||
745 | |||||
746 | ########################################### | ||||
747 | sub eval_if_perl { | ||||
748 | ########################################### | ||||
749 | my($value) = @_; | ||||
750 | |||||
751 | if(my $cref = compile_if_perl($value)) { | ||||
752 | return $cref->(); | ||||
753 | } | ||||
754 | |||||
755 | return $value; | ||||
756 | } | ||||
757 | |||||
758 | ########################################### | ||||
759 | sub compile_if_perl { | ||||
760 | ########################################### | ||||
761 | my($value) = @_; | ||||
762 | |||||
763 | if($value =~ /^\s*sub\s*{/ ) { | ||||
764 | my $mask; | ||||
765 | unless( Log::Log4perl::Config->allow_code() ) { | ||||
766 | die "\$Log::Log4perl::Config->allow_code() setting " . | ||||
767 | "prohibits Perl code in config file"; | ||||
768 | } | ||||
769 | if( defined( $mask = Log::Log4perl::Config->allowed_code_ops() ) ) { | ||||
770 | return compile_in_safe_cpt($value, $mask ); | ||||
771 | } | ||||
772 | elsif( $mask = Log::Log4perl::Config->allowed_code_ops_convenience_map( | ||||
773 | Log::Log4perl::Config->allow_code() | ||||
774 | ) ) { | ||||
775 | return compile_in_safe_cpt($value, $mask ); | ||||
776 | } | ||||
777 | elsif( Log::Log4perl::Config->allow_code() == 1 ) { | ||||
778 | |||||
779 | # eval without restriction | ||||
780 | my $cref = eval "package main; $value" or | ||||
781 | die "Can't evaluate '$value' ($@)"; | ||||
782 | return $cref; | ||||
783 | } | ||||
784 | else { | ||||
785 | die "Invalid value for \$Log::Log4perl::Config->allow_code(): '". | ||||
786 | Log::Log4perl::Config->allow_code() . "'"; | ||||
787 | } | ||||
788 | } | ||||
789 | |||||
790 | return undef; | ||||
791 | } | ||||
792 | |||||
793 | ########################################### | ||||
794 | sub compile_in_safe_cpt { | ||||
795 | ########################################### | ||||
796 | my($value, $allowed_ops) = @_; | ||||
797 | |||||
798 | # set up a Safe compartment | ||||
799 | require Safe; | ||||
800 | my $safe = Safe->new(); | ||||
801 | $safe->permit_only( @{ $allowed_ops } ); | ||||
802 | |||||
803 | # share things with the compartment | ||||
804 | for( keys %{ Log::Log4perl::Config->vars_shared_with_safe_compartment() } ) { | ||||
805 | my $toshare = Log::Log4perl::Config->vars_shared_with_safe_compartment($_); | ||||
806 | $safe->share_from( $_, $toshare ) | ||||
807 | or die "Can't share @{ $toshare } with Safe compartment"; | ||||
808 | } | ||||
809 | |||||
810 | # evaluate with restrictions | ||||
811 | my $cref = $safe->reval("package main; $value") or | ||||
812 | die "Can't evaluate '$value' in Safe compartment ($@)"; | ||||
813 | return $cref; | ||||
814 | |||||
815 | } | ||||
816 | |||||
817 | ########################################### | ||||
818 | sub boolean_to_perlish { | ||||
819 | ########################################### | ||||
820 | my($value) = @_; | ||||
821 | |||||
822 | # Translate boolean to perlish | ||||
823 | $value = 1 if $value =~ /^true$/i; | ||||
824 | $value = 0 if $value =~ /^false$/i; | ||||
825 | |||||
826 | return $value; | ||||
827 | } | ||||
828 | |||||
829 | ########################################### | ||||
830 | sub vars_shared_with_safe_compartment { | ||||
831 | ########################################### | ||||
832 | my($class, @args) = @_; | ||||
833 | |||||
834 | # Allow both for ...::Config::foo() and ...::Config->foo() | ||||
835 | if(defined $class and $class ne __PACKAGE__) { | ||||
836 | unshift @args, $class; | ||||
837 | } | ||||
838 | |||||
839 | # handle different invocation styles | ||||
840 | if(@args == 1 && ref $args[0] eq 'HASH' ) { | ||||
841 | # replace entire hash of vars | ||||
842 | %Log::Log4perl::VARS_SHARED_WITH_SAFE_COMPARTMENT = %{$args[0]}; | ||||
843 | } | ||||
844 | elsif( @args == 1 ) { | ||||
845 | # return vars for given package | ||||
846 | return $Log::Log4perl::VARS_SHARED_WITH_SAFE_COMPARTMENT{ | ||||
847 | $args[0]}; | ||||
848 | } | ||||
849 | elsif( @args == 2 ) { | ||||
850 | # add/replace package/var pair | ||||
851 | $Log::Log4perl::VARS_SHARED_WITH_SAFE_COMPARTMENT{ | ||||
852 | $args[0]} = $args[1]; | ||||
853 | } | ||||
854 | |||||
855 | return wantarray ? %Log::Log4perl::VARS_SHARED_WITH_SAFE_COMPARTMENT | ||||
856 | : \%Log::Log4perl::VARS_SHARED_WITH_SAFE_COMPARTMENT; | ||||
857 | |||||
858 | } | ||||
859 | |||||
860 | ########################################### | ||||
861 | sub allowed_code_ops { | ||||
862 | ########################################### | ||||
863 | my($class, @args) = @_; | ||||
864 | |||||
865 | # Allow both for ...::Config::foo() and ...::Config->foo() | ||||
866 | if(defined $class and $class ne __PACKAGE__) { | ||||
867 | unshift @args, $class; | ||||
868 | } | ||||
869 | |||||
870 | if(@args) { | ||||
871 | @Log::Log4perl::ALLOWED_CODE_OPS_IN_CONFIG_FILE = @args; | ||||
872 | } | ||||
873 | else { | ||||
874 | # give back 'undef' instead of an empty arrayref | ||||
875 | unless( @Log::Log4perl::ALLOWED_CODE_OPS_IN_CONFIG_FILE ) { | ||||
876 | return; | ||||
877 | } | ||||
878 | } | ||||
879 | |||||
880 | return wantarray ? @Log::Log4perl::ALLOWED_CODE_OPS_IN_CONFIG_FILE | ||||
881 | : \@Log::Log4perl::ALLOWED_CODE_OPS_IN_CONFIG_FILE; | ||||
882 | } | ||||
883 | |||||
884 | ########################################### | ||||
885 | sub allowed_code_ops_convenience_map { | ||||
886 | ########################################### | ||||
887 | my($class, @args) = @_; | ||||
888 | |||||
889 | # Allow both for ...::Config::foo() and ...::Config->foo() | ||||
890 | if(defined $class and $class ne __PACKAGE__) { | ||||
891 | unshift @args, $class; | ||||
892 | } | ||||
893 | |||||
894 | # handle different invocation styles | ||||
895 | if( @args == 1 && ref $args[0] eq 'HASH' ) { | ||||
896 | # replace entire map | ||||
897 | %Log::Log4perl::ALLOWED_CODE_OPS = %{$args[0]}; | ||||
898 | } | ||||
899 | elsif( @args == 1 ) { | ||||
900 | # return single opcode mask | ||||
901 | return $Log::Log4perl::ALLOWED_CODE_OPS{ | ||||
902 | $args[0]}; | ||||
903 | } | ||||
904 | elsif( @args == 2 ) { | ||||
905 | # make sure the mask is an array ref | ||||
906 | if( ref $args[1] ne 'ARRAY' ) { | ||||
907 | die "invalid mask (not an array ref) for convenience name '$args[0]'"; | ||||
908 | } | ||||
909 | # add name/mask pair | ||||
910 | $Log::Log4perl::ALLOWED_CODE_OPS{ | ||||
911 | $args[0]} = $args[1]; | ||||
912 | } | ||||
913 | |||||
914 | return wantarray ? %Log::Log4perl::ALLOWED_CODE_OPS | ||||
915 | : \%Log::Log4perl::ALLOWED_CODE_OPS | ||||
916 | } | ||||
917 | |||||
918 | ########################################### | ||||
919 | sub allow_code { | ||||
920 | ########################################### | ||||
921 | my($class, @args) = @_; | ||||
922 | |||||
923 | # Allow both for ...::Config::foo() and ...::Config->foo() | ||||
924 | if(defined $class and $class ne __PACKAGE__) { | ||||
925 | unshift @args, $class; | ||||
926 | } | ||||
927 | |||||
928 | if(@args) { | ||||
929 | $Log::Log4perl::ALLOW_CODE_IN_CONFIG_FILE = | ||||
930 | $args[0]; | ||||
931 | } | ||||
932 | |||||
933 | return $Log::Log4perl::ALLOW_CODE_IN_CONFIG_FILE; | ||||
934 | } | ||||
935 | |||||
936 | ################################################ | ||||
937 | sub var_subst { | ||||
938 | ################################################ | ||||
939 | my($varname, $subst_hash) = @_; | ||||
940 | |||||
941 | # Throw out blanks | ||||
942 | $varname =~ s/\s+//g; | ||||
943 | |||||
944 | if(exists $subst_hash->{$varname}) { | ||||
945 | print "Replacing variable: '$varname' => '$subst_hash->{$varname}'\n" | ||||
946 | if _INTERNAL_DEBUG; | ||||
947 | return $subst_hash->{$varname}; | ||||
948 | |||||
949 | } elsif(exists $ENV{$varname}) { | ||||
950 | print "Replacing ENV variable: '$varname' => '$ENV{$varname}'\n" | ||||
951 | if _INTERNAL_DEBUG; | ||||
952 | return $ENV{$varname}; | ||||
953 | |||||
954 | } | ||||
955 | |||||
956 | die "Undefined Variable '$varname'"; | ||||
957 | } | ||||
958 | |||||
959 | 1 | 5µs | 1; | ||
960 | |||||
961 | __END__ |