Profile of Log/Log4perl/Config.pm

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

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

Subroutines
Calls | P | F | Exclusive Time | Inclusive Time | Subroutine
--- | --- | --- | --- | --- | ---
1 | 1 | 1 | 772µs | 814µs | Log::Log4perl::Config::::BEGIN@14Log::Log4perl::Config::BEGIN@14
1 | 1 | 1 | 634µs | 1.33ms | Log::Log4perl::Config::::BEGIN@10Log::Log4perl::Config::BEGIN@10
1 | 1 | 1 | 507µs | 757µs | Log::Log4perl::Config::::BEGIN@13Log::Log4perl::Config::BEGIN@13
1 | 1 | 1 | 414µs | 567µs | Log::Log4perl::Config::::BEGIN@12Log::Log4perl::Config::BEGIN@12
1 | 1 | 1 | 340µs | 453µs | Log::Log4perl::Config::::BEGIN@11Log::Log4perl::Config::BEGIN@11
1 | 1 | 1 | 18µs | 18µs | Log::Log4perl::Config::::BEGIN@4Log::Log4perl::Config::BEGIN@4
1 | 1 | 1 | 10µs | 12µs | Log::Log4perl::Config::::BEGIN@5Log::Log4perl::Config::BEGIN@5
1 | 1 | 1 | 8µs | 8µs | Log::Log4perl::Config::::BEGIN@8Log::Log4perl::Config::BEGIN@8
1 | 1 | 1 | 7µs | 18µs | Log::Log4perl::Config::::BEGIN@6Log::Log4perl::Config::BEGIN@6
1 | 1 | 1 | 6µs | 45µs | Log::Log4perl::Config::::BEGIN@9Log::Log4perl::Config::BEGIN@9
1 | 1 | 1 | 6µs | 32µs | Log::Log4perl::Config::::BEGIN@16Log::Log4perl::Config::BEGIN@16
0 | 0 | 0 | 0s | 0s | Log::Log4perl::Config::::_initLog::Log4perl::Config::_init
0 | 0 | 0 | 0s | 0s | Log::Log4perl::Config::::add_global_cspecLog::Log4perl::Config::add_global_cspec
0 | 0 | 0 | 0s | 0s | Log::Log4perl::Config::::add_layout_by_nameLog::Log4perl::Config::add_layout_by_name
0 | 0 | 0 | 0s | 0s | Log::Log4perl::Config::::allow_codeLog::Log4perl::Config::allow_code
0 | 0 | 0 | 0s | 0s | Log::Log4perl::Config::::allowed_code_opsLog::Log4perl::Config::allowed_code_ops
0 | 0 | 0 | 0s | 0s | Log::Log4perl::Config::::allowed_code_ops_convenience_mapLog::Log4perl::Config::allowed_code_ops_convenience_map
0 | 0 | 0 | 0s | 0s | Log::Log4perl::Config::::boolean_to_perlishLog::Log4perl::Config::boolean_to_perlish
0 | 0 | 0 | 0s | 0s | Log::Log4perl::Config::::compile_if_perlLog::Log4perl::Config::compile_if_perl
0 | 0 | 0 | 0s | 0s | Log::Log4perl::Config::::compile_in_safe_cptLog::Log4perl::Config::compile_in_safe_cpt
0 | 0 | 0 | 0s | 0s | Log::Log4perl::Config::::config_file_readLog::Log4perl::Config::config_file_read
0 | 0 | 0 | 0s | 0s | Log::Log4perl::Config::::config_is_saneLog::Log4perl::Config::config_is_sane
0 | 0 | 0 | 0s | 0s | Log::Log4perl::Config::::config_readLog::Log4perl::Config::config_read
0 | 0 | 0 | 0s | 0s | Log::Log4perl::Config::::create_appender_instanceLog::Log4perl::Config::create_appender_instance
0 | 0 | 0 | 0s | 0s | Log::Log4perl::Config::::eval_if_perlLog::Log4perl::Config::eval_if_perl
0 | 0 | 0 | 0s | 0s | Log::Log4perl::Config::::get_appender_by_nameLog::Log4perl::Config::get_appender_by_name
0 | 0 | 0 | 0s | 0s | Log::Log4perl::Config::::initLog::Log4perl::Config::init
0 | 0 | 0 | 0s | 0s | Log::Log4perl::Config::::init_and_watchLog::Log4perl::Config::init_and_watch
0 | 0 | 0 | 0s | 0s | Log::Log4perl::Config::::leaf_path_to_hashLog::Log4perl::Config::leaf_path_to_hash
0 | 0 | 0 | 0s | 0s | Log::Log4perl::Config::::leaf_pathsLog::Log4perl::Config::leaf_paths
0 | 0 | 0 | 0s | 0s | Log::Log4perl::Config::::set_LWP_UserAgentLog::Log4perl::Config::set_LWP_UserAgent
0 | 0 | 0 | 0s | 0s | Log::Log4perl::Config::::set_appender_by_nameLog::Log4perl::Config::set_appender_by_name
0 | 0 | 0 | 0s | 0s | Log::Log4perl::Config::::unlog4jLog::Log4perl::Config::unlog4j
0 | 0 | 0 | 0s | 0s | Log::Log4perl::Config::::var_substLog::Log4perl::Config::var_subst
0 | 0 | 0 | 0s | 0s | Log::Log4perl::Config::::vars_shared_with_safe_compartmentLog::Log4perl::Config::vars_shared_with_safe_compartment
0 | 0 | 0 | 0s | 0s | Log::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 |  |  |  |  | ##################################################
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 use 5.006; # 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 use strict; # 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 use warnings; # 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 use Log::Log4perl::Logger; # 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 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
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 use Log::Log4perl::Config::PropertyConfigurator; # 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 use Log::Log4perl::JavaMap; # 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 use Log::Log4perl::Filter; # 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 use Log::Log4perl::Filter::Boolean; # 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 use Log::Log4perl::Config::Watch; # 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 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 |  |  |  |  |
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__