← Index
NYTProf Performance Profile   « block view • line view • sub view »
For xt/tapper-mcp-scheduler-with-db-longrun.t
  Run on Tue May 22 17:18:39 2012
Reported on Tue May 22 17:22:54 2012

Filename/2home/ss5/perl5/perlbrew/perls/perl-5.12.3/lib/site_perl/5.12.3/Log/Log4perl/Config.pm
StatementsExecuted 43 statements in 3.78ms
Subroutines
Calls P F Exclusive
Time
Inclusive
Time
Subroutine
111772µs814µsLog::Log4perl::Config::::BEGIN@14Log::Log4perl::Config::BEGIN@14
111634µs1.33msLog::Log4perl::Config::::BEGIN@10Log::Log4perl::Config::BEGIN@10
111507µs757µsLog::Log4perl::Config::::BEGIN@13Log::Log4perl::Config::BEGIN@13
111414µs567µsLog::Log4perl::Config::::BEGIN@12Log::Log4perl::Config::BEGIN@12
111340µs453µsLog::Log4perl::Config::::BEGIN@11Log::Log4perl::Config::BEGIN@11
11118µs18µsLog::Log4perl::Config::::BEGIN@4Log::Log4perl::Config::BEGIN@4
11110µs12µsLog::Log4perl::Config::::BEGIN@5Log::Log4perl::Config::BEGIN@5
1118µs8µsLog::Log4perl::Config::::BEGIN@8Log::Log4perl::Config::BEGIN@8
1117µs18µsLog::Log4perl::Config::::BEGIN@6Log::Log4perl::Config::BEGIN@6
1116µs45µsLog::Log4perl::Config::::BEGIN@9Log::Log4perl::Config::BEGIN@9
1116µs32µsLog::Log4perl::Config::::BEGIN@16Log::Log4perl::Config::BEGIN@16
0000s0sLog::Log4perl::Config::::_initLog::Log4perl::Config::_init
0000s0sLog::Log4perl::Config::::add_global_cspecLog::Log4perl::Config::add_global_cspec
0000s0sLog::Log4perl::Config::::add_layout_by_nameLog::Log4perl::Config::add_layout_by_name
0000s0sLog::Log4perl::Config::::allow_codeLog::Log4perl::Config::allow_code
0000s0sLog::Log4perl::Config::::allowed_code_opsLog::Log4perl::Config::allowed_code_ops
0000s0sLog::Log4perl::Config::::allowed_code_ops_convenience_mapLog::Log4perl::Config::allowed_code_ops_convenience_map
0000s0sLog::Log4perl::Config::::boolean_to_perlishLog::Log4perl::Config::boolean_to_perlish
0000s0sLog::Log4perl::Config::::compile_if_perlLog::Log4perl::Config::compile_if_perl
0000s0sLog::Log4perl::Config::::compile_in_safe_cptLog::Log4perl::Config::compile_in_safe_cpt
0000s0sLog::Log4perl::Config::::config_file_readLog::Log4perl::Config::config_file_read
0000s0sLog::Log4perl::Config::::config_is_saneLog::Log4perl::Config::config_is_sane
0000s0sLog::Log4perl::Config::::config_readLog::Log4perl::Config::config_read
0000s0sLog::Log4perl::Config::::create_appender_instanceLog::Log4perl::Config::create_appender_instance
0000s0sLog::Log4perl::Config::::eval_if_perlLog::Log4perl::Config::eval_if_perl
0000s0sLog::Log4perl::Config::::get_appender_by_nameLog::Log4perl::Config::get_appender_by_name
0000s0sLog::Log4perl::Config::::initLog::Log4perl::Config::init
0000s0sLog::Log4perl::Config::::init_and_watchLog::Log4perl::Config::init_and_watch
0000s0sLog::Log4perl::Config::::leaf_path_to_hashLog::Log4perl::Config::leaf_path_to_hash
0000s0sLog::Log4perl::Config::::leaf_pathsLog::Log4perl::Config::leaf_paths
0000s0sLog::Log4perl::Config::::set_LWP_UserAgentLog::Log4perl::Config::set_LWP_UserAgent
0000s0sLog::Log4perl::Config::::set_appender_by_nameLog::Log4perl::Config::set_appender_by_name
0000s0sLog::Log4perl::Config::::unlog4jLog::Log4perl::Config::unlog4j
0000s0sLog::Log4perl::Config::::var_substLog::Log4perl::Config::var_subst
0000s0sLog::Log4perl::Config::::vars_shared_with_safe_compartmentLog::Log4perl::Config::vars_shared_with_safe_compartment
0000s0sLog::Log4perl::Config::::watcherLog::Log4perl::Config::watcher
Call graph for these subroutines as a Graphviz dot language file.
Line State
ments
Time
on line
Calls Time
in subs
Code
1##################################################
2package Log::Log4perl::Config;
3##################################################
4327µs118µ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
use 5.006;
# spent 18µs making 1 call to Log::Log4perl::Config::BEGIN@4
5318µs214µ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
use strict;
# spent 12µs making 1 call to Log::Log4perl::Config::BEGIN@5 # spent 2µs making 1 call to strict::import
6316µs230µ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
use warnings;
# spent 18µs making 1 call to Log::Log4perl::Config::BEGIN@6 # spent 12µs making 1 call to warnings::import
7
8322µs18µ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
use Log::Log4perl::Logger;
# spent 8µs making 1 call to Log::Log4perl::Config::BEGIN@8
9317µs284µ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
use Log::Log4perl::Level;
# spent 45µs making 1 call to Log::Log4perl::Config::BEGIN@9 # spent 39µs making 1 call to Log::Log4perl::Level::import
10382µs11.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
use Log::Log4perl::Config::PropertyConfigurator;
# spent 1.33ms making 1 call to Log::Log4perl::Config::BEGIN@10
11386µs1453µ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
use Log::Log4perl::JavaMap;
# spent 453µs making 1 call to Log::Log4perl::Config::BEGIN@11
12377µs1567µ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
use Log::Log4perl::Filter;
# spent 567µs making 1 call to Log::Log4perl::Config::BEGIN@12
13378µs1757µ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
use Log::Log4perl::Filter::Boolean;
# spent 757µs making 1 call to Log::Log4perl::Config::BEGIN@13
14383µs1814µ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
use Log::Log4perl::Config::Watch;
# spent 814µs making 1 call to Log::Log4perl::Config::BEGIN@14
15
1633.26ms259µ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
use constant _INTERNAL_DEBUG => 0;
# spent 32µs making 1 call to Log::Log4perl::Config::BEGIN@16 # spent 26µs making 1 call to constant::import
17
181800nsour $CONFIG_FILE_READS = 0;
191200nsour $CONFIG_INTEGRITY_CHECK = 1;
201300nsour $CONFIG_INTEGRITY_ERROR = undef;
21
221200nsour $WATCHER;
231100nsour $DEFAULT_WATCH_DELAY = 60; # seconds
241900nsour $OPTS = {};
251100nsour $OLD_CONFIG;
261100nsour $LOGGERS_DEFINED;
27
28###########################################
29sub 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###########################################
39sub watcher {
40###########################################
41 return $WATCHER;
42}
43
44###########################################
45sub 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##################################################
103sub _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##################################################
317sub 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##################################################
333sub 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###########################################
478sub 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###########################################
510sub 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###########################################
522sub 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##################################################
532sub 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
5451300nsmy $LWP_USER_AGENT;
546sub set_LWP_UserAgent
547{
548 $LWP_USER_AGENT = shift;
549}
550
551
552###########################################
553sub 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###########################################
673sub 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###########################################
685sub 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############################################################
700sub 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###########################################
733sub 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###########################################
747sub 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###########################################
759sub 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###########################################
794sub 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###########################################
818sub 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###########################################
830sub 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###########################################
861sub 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###########################################
885sub 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###########################################
919sub 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################################################
937sub 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
95915µs1;
960
961__END__