| 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 | Log::Log4perl::Config::BEGIN@14 |
| 1 | 1 | 1 | 634µs | 1.33ms | Log::Log4perl::Config::BEGIN@10 |
| 1 | 1 | 1 | 507µs | 757µs | Log::Log4perl::Config::BEGIN@13 |
| 1 | 1 | 1 | 414µs | 567µs | Log::Log4perl::Config::BEGIN@12 |
| 1 | 1 | 1 | 340µs | 453µs | Log::Log4perl::Config::BEGIN@11 |
| 1 | 1 | 1 | 18µs | 18µs | Log::Log4perl::Config::BEGIN@4 |
| 1 | 1 | 1 | 10µs | 12µs | Log::Log4perl::Config::BEGIN@5 |
| 1 | 1 | 1 | 8µs | 8µs | Log::Log4perl::Config::BEGIN@8 |
| 1 | 1 | 1 | 7µs | 18µs | Log::Log4perl::Config::BEGIN@6 |
| 1 | 1 | 1 | 6µs | 45µs | Log::Log4perl::Config::BEGIN@9 |
| 1 | 1 | 1 | 6µs | 32µs | Log::Log4perl::Config::BEGIN@16 |
| 0 | 0 | 0 | 0s | 0s | Log::Log4perl::Config::_init |
| 0 | 0 | 0 | 0s | 0s | Log::Log4perl::Config::add_global_cspec |
| 0 | 0 | 0 | 0s | 0s | Log::Log4perl::Config::add_layout_by_name |
| 0 | 0 | 0 | 0s | 0s | Log::Log4perl::Config::allow_code |
| 0 | 0 | 0 | 0s | 0s | Log::Log4perl::Config::allowed_code_ops |
| 0 | 0 | 0 | 0s | 0s | Log::Log4perl::Config::allowed_code_ops_convenience_map |
| 0 | 0 | 0 | 0s | 0s | Log::Log4perl::Config::boolean_to_perlish |
| 0 | 0 | 0 | 0s | 0s | Log::Log4perl::Config::compile_if_perl |
| 0 | 0 | 0 | 0s | 0s | Log::Log4perl::Config::compile_in_safe_cpt |
| 0 | 0 | 0 | 0s | 0s | Log::Log4perl::Config::config_file_read |
| 0 | 0 | 0 | 0s | 0s | Log::Log4perl::Config::config_is_sane |
| 0 | 0 | 0 | 0s | 0s | Log::Log4perl::Config::config_read |
| 0 | 0 | 0 | 0s | 0s | Log::Log4perl::Config::create_appender_instance |
| 0 | 0 | 0 | 0s | 0s | Log::Log4perl::Config::eval_if_perl |
| 0 | 0 | 0 | 0s | 0s | Log::Log4perl::Config::get_appender_by_name |
| 0 | 0 | 0 | 0s | 0s | Log::Log4perl::Config::init |
| 0 | 0 | 0 | 0s | 0s | Log::Log4perl::Config::init_and_watch |
| 0 | 0 | 0 | 0s | 0s | Log::Log4perl::Config::leaf_path_to_hash |
| 0 | 0 | 0 | 0s | 0s | Log::Log4perl::Config::leaf_paths |
| 0 | 0 | 0 | 0s | 0s | Log::Log4perl::Config::set_LWP_UserAgent |
| 0 | 0 | 0 | 0s | 0s | Log::Log4perl::Config::set_appender_by_name |
| 0 | 0 | 0 | 0s | 0s | Log::Log4perl::Config::unlog4j |
| 0 | 0 | 0 | 0s | 0s | Log::Log4perl::Config::var_subst |
| 0 | 0 | 0 | 0s | 0s | Log::Log4perl::Config::vars_shared_with_safe_compartment |
| 0 | 0 | 0 | 0s | 0s | Log::Log4perl::Config::watcher |
| 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__ |