1################################################## 2package Log::Log4perl::Config; 3################################################## 4use 5.006; 5use strict; 6use warnings; 7 8use Log::Log4perl::Logger; 9use Log::Log4perl::Level; 10use Log::Log4perl::Config::PropertyConfigurator; 11use Log::Log4perl::JavaMap; 12use Log::Log4perl::Filter; 13use Log::Log4perl::Filter::Boolean; 14use Log::Log4perl::Config::Watch; 15 16use constant _INTERNAL_DEBUG => 0; 17 18our $CONFIG_FILE_READS = 0; 19our $CONFIG_INTEGRITY_CHECK = 1; 20our $CONFIG_INTEGRITY_ERROR = undef; 21 22our $WATCHER; 23our $DEFAULT_WATCH_DELAY = 60; # seconds 24our $OPTS = {}; 25our $OLD_CONFIG; 26our $LOGGERS_DEFINED; 27our $UTF8 = 0; 28 29########################################### 30sub init { 31########################################### 32 Log::Log4perl::Logger->reset(); 33 34 undef $WATCHER; # just in case there's a one left over (e.g. test cases) 35 36 return _init(@_); 37} 38 39########################################### 40sub utf8 { 41########################################### 42 my( $class, $flag ) = @_; 43 44 $UTF8 = $flag if defined $flag; 45 46 return $UTF8; 47} 48 49########################################### 50sub watcher { 51########################################### 52 return $WATCHER; 53} 54 55########################################### 56sub init_and_watch { 57########################################### 58 my ($class, $config, $delay, $opts) = @_; 59 # delay can be a signal name - in this case we're gonna 60 # set up a signal handler. 61 62 if(defined $WATCHER) { 63 $config = $WATCHER->file(); 64 if(defined $Log::Log4perl::Config::Watch::SIGNAL_CAUGHT) { 65 $delay = $WATCHER->signal(); 66 } else { 67 $delay = $WATCHER->check_interval(); 68 } 69 } 70 71 print "init_and_watch ($config-$delay). Resetting.\n" if _INTERNAL_DEBUG; 72 73 Log::Log4perl::Logger->reset(); 74 75 defined ($delay) or $delay = $DEFAULT_WATCH_DELAY; 76 77 if (ref $config) { 78 die "Log4perl can only watch a file, not a string of " . 79 "configuration information"; 80 }elsif ($config =~ m!^(https?|ftp|wais|gopher|file):!){ 81 die "Log4perl can only watch a file, not a url like $config"; 82 } 83 84 if($delay =~ /\D/) { 85 $WATCHER = Log::Log4perl::Config::Watch->new( 86 file => $config, 87 signal => $delay, 88 l4p_internal => 1, 89 ); 90 } else { 91 $WATCHER = Log::Log4perl::Config::Watch->new( 92 file => $config, 93 check_interval => $delay, 94 l4p_internal => 1, 95 ); 96 } 97 98 if(defined $opts) { 99 die "Parameter $opts needs to be a hash ref" if ref($opts) ne "HASH"; 100 $OPTS = $opts; 101 } 102 103 eval { _init($class, $config); }; 104 105 if($@) { 106 die "$@" unless defined $OLD_CONFIG; 107 # Call _init with a pre-parsed config to go back to old setting 108 _init($class, undef, $OLD_CONFIG); 109 warn "Loading new config failed, reverted to old one\n"; 110 } 111} 112 113################################################## 114sub _init { 115################################################## 116 my($class, $config, $data) = @_; 117 118 my %additivity = (); 119 120 $LOGGERS_DEFINED = 0; 121 122 print "Calling _init\n" if _INTERNAL_DEBUG; 123 124 #keep track so we don't create the same one twice 125 my %appenders_created = (); 126 127 #some appenders need to run certain subroutines right at the 128 #end of the configuration phase, when all settings are in place. 129 my @post_config_subs = (); 130 131 # This logic is probably suited to win an obfuscated programming 132 # contest. It desperately needs to be rewritten. 133 # Basically, it works like this: 134 # config_read() reads the entire config file into a hash of hashes: 135 # log4j.logger.foo.bar.baz: WARN, A1 136 # gets transformed into 137 # $data->{log4j}->{logger}->{foo}->{bar}->{baz} = "WARN, A1"; 138 # The code below creates the necessary loggers, sets the appenders 139 # and the layouts etc. 140 # In order to transform parts of this tree back into identifiers 141 # (like "foo.bar.baz"), we're using the leaf_paths functions below. 142 # Pretty scary. But it allows the lines of the config file to be 143 # in *arbitrary* order. 144 145 $data = config_read($config) unless defined $data; 146 147 if(_INTERNAL_DEBUG) { 148 require Data::Dumper; 149 Data::Dumper->import(); 150 print Data::Dumper::Dumper($data); 151 } 152 153 my @loggers = (); 154 my %filter_names = (); 155 156 my $system_wide_threshold; 157 158 # Autocorrect the rootlogger/rootLogger typo 159 if(exists $data->{rootlogger} and 160 ! exists $data->{rootLogger}) { 161 $data->{rootLogger} = $data->{rootlogger}; 162 } 163 164 # Find all logger definitions in the conf file. Start 165 # with root loggers. 166 if(exists $data->{rootLogger}) { 167 $LOGGERS_DEFINED++; 168 push @loggers, ["", $data->{rootLogger}->{value}]; 169 } 170 171 # Check if we've got a system-wide threshold setting 172 if(exists $data->{threshold}) { 173 # yes, we do. 174 $system_wide_threshold = $data->{threshold}->{value}; 175 } 176 177 if (exists $data->{oneMessagePerAppender}){ 178 $Log::Log4perl::one_message_per_appender = 179 $data->{oneMessagePerAppender}->{value}; 180 } 181 182 # Boolean filters 183 my %boolean_filters = (); 184 185 # Continue with lower level loggers. Both 'logger' and 'category' 186 # are valid keywords. Also 'additivity' is one, having a logger 187 # attached. We'll differenciate between the two further down. 188 for my $key (qw(logger category additivity PatternLayout filter)) { 189 190 if(exists $data->{$key}) { 191 192 for my $path (@{leaf_paths($data->{$key})}) { 193 194 print "Path before: @$path\n" if _INTERNAL_DEBUG; 195 196 my $value = boolean_to_perlish(pop @$path); 197 198 pop @$path; # Drop the 'value' keyword part 199 200 if($key eq "additivity") { 201 # This isn't a logger but an additivity setting. 202 # Save it in a hash under the logger's name for later. 203 $additivity{join('.', @$path)} = $value; 204 205 #a global user-defined conversion specifier (cspec) 206 }elsif ($key eq "PatternLayout"){ 207 &add_global_cspec(@$path[-1], $value); 208 209 }elsif ($key eq "filter"){ 210 print "Found entry @$path\n" if _INTERNAL_DEBUG; 211 $filter_names{@$path[0]}++; 212 } else { 213 214 if (ref($value) eq "ARRAY") { 215 die "Multiple definitions of logger ".join('.',@$path)." in log4perl config"; 216 } 217 218 # This is a regular logger 219 $LOGGERS_DEFINED++; 220 push @loggers, [join('.', @$path), $value]; 221 } 222 } 223 } 224 } 225 226 # Now go over all filters found by name 227 for my $filter_name (keys %filter_names) { 228 229 print "Checking filter $filter_name\n" if _INTERNAL_DEBUG; 230 231 # The boolean filter needs all other filters already 232 # initialized, defer its initialization 233 if($data->{filter}->{$filter_name}->{value} eq 234 "Log::Log4perl::Filter::Boolean") { 235 print "Boolean filter ($filter_name)\n" if _INTERNAL_DEBUG; 236 $boolean_filters{$filter_name}++; 237 next; 238 } 239 240 my $type = $data->{filter}->{$filter_name}->{value}; 241 if(my $code = compile_if_perl($type)) { 242 $type = $code; 243 } 244 245 print "Filter $filter_name is of type $type\n" if _INTERNAL_DEBUG; 246 247 my $filter; 248 249 if(ref($type) eq "CODE") { 250 # Subroutine - map into generic Log::Log4perl::Filter class 251 $filter = Log::Log4perl::Filter->new($filter_name, $type); 252 } else { 253 # Filter class 254 die "Filter class '$type' doesn't exist" unless 255 Log::Log4perl::Util::module_available($type); 256 eval "require $type" or die "Require of $type failed ($!)"; 257 258 # Invoke with all defined parameter 259 # key/values (except the key 'value' which is the entry 260 # for the class) 261 $filter = $type->new(name => $filter_name, 262 map { $_ => $data->{filter}->{$filter_name}->{$_}->{value} } 263 grep { $_ ne "value" } 264 keys %{$data->{filter}->{$filter_name}}); 265 } 266 # Register filter with the global filter registry 267 $filter->register(); 268 } 269 270 # Initialize boolean filters (they need the other filters to be 271 # initialized to be able to compile their logic) 272 for my $name (keys %boolean_filters) { 273 my $logic = $data->{filter}->{$name}->{logic}->{value}; 274 die "No logic defined for boolean filter $name" unless defined $logic; 275 my $filter = Log::Log4perl::Filter::Boolean->new( 276 name => $name, 277 logic => $logic); 278 $filter->register(); 279 } 280 281 for (@loggers) { 282 my($name, $value) = @$_; 283 284 my $logger = Log::Log4perl::Logger->get_logger($name); 285 my ($level, @appnames) = split /\s*,\s*/, $value; 286 287 $logger->level( 288 Log::Log4perl::Level::to_priority($level), 289 'dont_reset_all'); 290 291 if(exists $additivity{$name}) { 292 $logger->additivity($additivity{$name}); 293 } 294 295 for my $appname (@appnames) { 296 297 my $appender = create_appender_instance( 298 $data, $appname, \%appenders_created, \@post_config_subs, 299 $system_wide_threshold); 300 301 $logger->add_appender($appender, 'dont_reset_all'); 302 set_appender_by_name($appname, $appender, \%appenders_created); 303 } 304 } 305 306 #run post_config subs 307 for(@post_config_subs) { 308 $_->(); 309 } 310 311 #now we're done, set up all the output methods (e.g. ->debug('...')) 312 Log::Log4perl::Logger::reset_all_output_methods(); 313 314 #Run a sanity test on the config not disabled 315 if($Log::Log4perl::Config::CONFIG_INTEGRITY_CHECK and 316 !config_is_sane()) { 317 warn "Log::Log4perl configuration looks suspicious: ", 318 "$CONFIG_INTEGRITY_ERROR"; 319 } 320 321 # Successful init(), save config for later 322 $OLD_CONFIG = $data; 323 324 $Log::Log4perl::Logger::INITIALIZED = 1; 325} 326 327################################################## 328sub config_is_sane { 329################################################## 330 if(! $LOGGERS_DEFINED) { 331 $CONFIG_INTEGRITY_ERROR = "No loggers defined"; 332 return 0; 333 } 334 335 if(scalar keys %Log::Log4perl::Logger::APPENDER_BY_NAME == 0) { 336 $CONFIG_INTEGRITY_ERROR = "No appenders defined"; 337 return 0; 338 } 339 340 return 1; 341} 342 343################################################## 344sub create_appender_instance { 345################################################## 346 my($data, $appname, $appenders_created, $post_config_subs, 347 $system_wide_threshold) = @_; 348 349 my $appenderclass = get_appender_by_name( 350 $data, $appname, $appenders_created); 351 352 print "appenderclass=$appenderclass\n" if _INTERNAL_DEBUG; 353 354 my $appender; 355 356 if (ref $appenderclass) { 357 $appender = $appenderclass; 358 } else { 359 die "ERROR: you didn't tell me how to " . 360 "implement your appender '$appname'" 361 unless $appenderclass; 362 363 if (Log::Log4perl::JavaMap::translate($appenderclass)){ 364 # It's Java. Try to map 365 print "Trying to map Java $appname\n" if _INTERNAL_DEBUG; 366 $appender = Log::Log4perl::JavaMap::get($appname, 367 $data->{appender}->{$appname}); 368 369 }else{ 370 # It's Perl 371 my @params = grep { $_ ne "layout" and 372 $_ ne "value" 373 } keys %{$data->{appender}->{$appname}}; 374 375 my %param = (); 376 foreach my $pname (@params){ 377 #this could be simple value like 378 #{appender}{myAppender}{file}{value} => 'log.txt' 379 #or a structure like 380 #{appender}{myAppender}{login} => 381 # { name => {value => 'bob'}, 382 # pwd => {value => 'xxx'}, 383 # } 384 #in the latter case we send a hashref to the appender 385 if (exists $data->{appender}{$appname} 386 {$pname}{value} ) { 387 $param{$pname} = $data->{appender}{$appname} 388 {$pname}{value}; 389 }else{ 390 $param{$pname} = {map {$_ => $data->{appender} 391 {$appname} 392 {$pname} 393 {$_} 394 {value}} 395 keys %{$data->{appender} 396 {$appname} 397 {$pname}} 398 }; 399 } 400 401 } 402 403 my $depends_on = []; 404 405 $appender = Log::Log4perl::Appender->new( 406 $appenderclass, 407 name => $appname, 408 l4p_post_config_subs => $post_config_subs, 409 l4p_depends_on => $depends_on, 410 %param, 411 ); 412 413 for my $dependency (@$depends_on) { 414 # If this appender indicates that it needs other appenders 415 # to exist (e.g. because it's a composite appender that 416 # relays messages on to its appender-refs) then we're 417 # creating their instances here. Reason for this is that 418 # these appenders are not attached to any logger and are 419 # therefore missed by the config parser which goes through 420 # the defined loggers and just creates *their* attached 421 # appenders. 422 $appender->composite(1); 423 next if exists $appenders_created->{$appname}; 424 my $app = create_appender_instance($data, $dependency, 425 $appenders_created, 426 $post_config_subs); 427 # If the appender appended a subroutine to $post_config_subs 428 # (a reference to an array of subroutines) 429 # here, the configuration parser will later execute this 430 # method. This is used by a composite appender which needs 431 # to make sure all of its appender-refs are available when 432 # all configuration settings are done. 433 434 # Smuggle this sub-appender into the hash of known appenders 435 # without attaching it to any logger directly. 436 $ 437 Log::Log4perl::Logger::APPENDER_BY_NAME{$dependency} = $app; 438 } 439 } 440 } 441 442 add_layout_by_name($data, $appender, $appname) unless 443 $appender->composite(); 444 445 # Check for appender thresholds 446 my $threshold = 447 $data->{appender}->{$appname}->{Threshold}->{value}; 448 449 if(defined $system_wide_threshold and 450 !defined $threshold) { 451 $threshold = $system_wide_threshold; 452 } 453 454 if(defined $threshold) { 455 # Need to split into two lines because of CVS 456 $appender->threshold($ 457 Log::Log4perl::Level::PRIORITY{$threshold}); 458 } 459 460 # Check for custom filters attached to the appender 461 my $filtername = 462 $data->{appender}->{$appname}->{Filter}->{value}; 463 if(defined $filtername) { 464 # Need to split into two lines because of CVS 465 my $filter = Log::Log4perl::Filter::by_name($filtername); 466 die "Filter $filtername doesn't exist" unless defined $filter; 467 $appender->filter($filter); 468 } 469 470 if(defined $system_wide_threshold and 471 defined $threshold and 472 $ 473 Log::Log4perl::Level::PRIORITY{$system_wide_threshold} > 474 $ 475 Log::Log4perl::Level::PRIORITY{$threshold} 476 ) { 477 $appender->threshold($ 478 Log::Log4perl::Level::PRIORITY{$system_wide_threshold}); 479 } 480 481 if(exists $data->{appender}->{$appname}->{threshold}) { 482 die "invalid keyword 'threshold' - perhaps you meant 'Threshold'?"; 483 } 484 485 return $appender; 486} 487 488########################################### 489sub add_layout_by_name { 490########################################### 491 my($data, $appender, $appender_name) = @_; 492 493 my $layout_class = $data->{appender}->{$appender_name}->{layout}->{value}; 494 495 die "Layout not specified for appender $appender_name" unless $layout_class; 496 497 $layout_class =~ s/org.apache.log4j./Log::Log4perl::Layout::/; 498 499 # Check if we have this layout class 500 if(!Log::Log4perl::Util::module_available($layout_class)) { 501 if(Log::Log4perl::Util::module_available( 502 "Log::Log4perl::Layout::$layout_class")) { 503 # Someone used the layout shortcut, use the fully qualified 504 # module name instead. 505 $layout_class = "Log::Log4perl::Layout::$layout_class"; 506 } else { 507 die "ERROR: trying to set layout for $appender_name to " . 508 "'$layout_class' failed"; 509 } 510 } 511 512 eval "require $layout_class" or 513 die "Require to $layout_class failed ($!)"; 514 515 $appender->layout($layout_class->new( 516 $data->{appender}->{$appender_name}->{layout}, 517 )); 518} 519 520########################################### 521sub get_appender_by_name { 522########################################### 523 my($data, $name, $appenders_created) = @_; 524 525 if (exists $appenders_created->{$name}) { 526 return $appenders_created->{$name}; 527 } else { 528 return $data->{appender}->{$name}->{value}; 529 } 530} 531 532########################################### 533sub set_appender_by_name { 534########################################### 535# keep track of appenders we've already created 536########################################### 537 my($appname, $appender, $appenders_created) = @_; 538 539 $appenders_created->{$appname} ||= $appender; 540} 541 542################################################## 543sub add_global_cspec { 544################################################## 545# the config file said 546# log4j.PatternLayout.cspec.Z=sub {return $$*2} 547################################################## 548 my ($letter, $perlcode) = @_; 549 550 die "error: only single letters allowed in log4j.PatternLayout.cspec.$letter" 551 unless ($letter =~ /^[a-zA-Z]$/); 552 553 Log::Log4perl::Layout::PatternLayout::add_global_cspec($letter, $perlcode); 554} 555 556my $LWP_USER_AGENT; 557sub set_LWP_UserAgent 558{ 559 $LWP_USER_AGENT = shift; 560} 561 562 563########################################### 564sub config_read { 565########################################### 566# Read the lib4j configuration and store the 567# values into a nested hash structure. 568########################################### 569 my($config) = @_; 570 571 die "Configuration not defined" unless defined $config; 572 573 my @text; 574 my $parser; 575 576 $CONFIG_FILE_READS++; # Count for statistical purposes 577 578 my $base_configurator = Log::Log4perl::Config::BaseConfigurator->new( 579 utf8 => $UTF8, 580 ); 581 582 my $data = {}; 583 584 if (ref($config) eq 'HASH') { # convert the hashref into a list 585 # of name/value pairs 586 print "Reading config from hash\n" if _INTERNAL_DEBUG; 587 @text = (); 588 for my $key ( keys %$config ) { 589 if( ref( $config->{$key} ) eq "CODE" ) { 590 $config->{$key} = $config->{$key}->(); 591 } 592 push @text, $key . '=' . $config->{$key} . "\n"; 593 } 594 } elsif (ref $config eq 'SCALAR') { 595 print "Reading config from scalar\n" if _INTERNAL_DEBUG; 596 @text = split(/\n/,$$config); 597 598 } elsif (ref $config eq 'GLOB' or 599 ref $config eq 'IO::File') { 600 # If we have a file handle, just call the reader 601 print "Reading config from file handle\n" if _INTERNAL_DEBUG; 602 @text = @{ $base_configurator->file_h_read( $config ) }; 603 604 } elsif (ref $config) { 605 # Caller provided a config parser object, which already 606 # knows which file (or DB or whatever) to parse. 607 print "Reading config from parser object\n" if _INTERNAL_DEBUG; 608 $data = $config->parse(); 609 return $data; 610 611 } elsif ($config =~ m|^ldap://|){ 612 if(! Log::Log4perl::Util::module_available("Net::LDAP")) { 613 die "Log4perl: missing Net::LDAP needed to parse LDAP urls\n$@\n"; 614 } 615 616 require Net::LDAP; 617 require Log::Log4perl::Config::LDAPConfigurator; 618 619 return Log::Log4perl::Config::LDAPConfigurator->new->parse($config); 620 621 } else { 622 623 if ($config =~ /^(https?|ftp|wais|gopher|file):/){ 624 my ($result, $ua); 625 626 die "LWP::UserAgent not available" unless 627 Log::Log4perl::Util::module_available("LWP::UserAgent"); 628 629 require LWP::UserAgent; 630 unless (defined $LWP_USER_AGENT) { 631 $LWP_USER_AGENT = LWP::UserAgent->new; 632 633 # Load proxy settings from environment variables, i.e.: 634 # http_proxy, ftp_proxy, no_proxy etc (see LWP::UserAgent) 635 # You need these to go thru firewalls. 636 $LWP_USER_AGENT->env_proxy; 637 } 638 $ua = $LWP_USER_AGENT; 639 640 my $req = new HTTP::Request GET => $config; 641 my $res = $ua->request($req); 642 643 if ($res->is_success) { 644 @text = split(/\n/, $res->content); 645 } else { 646 die "Log4perl couln't get $config, ". 647 $res->message." "; 648 } 649 } else { 650 print "Reading config from file '$config'\n" if _INTERNAL_DEBUG; 651 print "Reading ", -s $config, " bytes.\n" if _INTERNAL_DEBUG; 652 # Use the BaseConfigurator's file reader to avoid duplicating 653 # utf8 handling here. 654 $base_configurator->file( $config ); 655 @text = @{ $base_configurator->text() }; 656 } 657 } 658 659 print "Reading $config: [@text]\n" if _INTERNAL_DEBUG; 660 661 if(! grep /\S/, @text) { 662 return $data; 663 } 664 665 if ($text[0] =~ /^<\?xml /) { 666 667 die "XML::DOM not available" unless 668 Log::Log4perl::Util::module_available("XML::DOM"); 669 670 require XML::DOM; 671 require Log::Log4perl::Config::DOMConfigurator; 672 673 XML::DOM->VERSION($Log::Log4perl::DOM_VERSION_REQUIRED); 674 $parser = Log::Log4perl::Config::DOMConfigurator->new(); 675 $data = $parser->parse(\@text); 676 } else { 677 $parser = Log::Log4perl::Config::PropertyConfigurator->new(); 678 $data = $parser->parse(\@text); 679 } 680 681 $data = $parser->parse_post_process( $data, leaf_paths($data) ); 682 683 return $data; 684} 685 686########################################### 687sub unlog4j { 688########################################### 689 my ($string) = @_; 690 691 $string =~ s#^org\.apache\.##; 692 $string =~ s#^log4j\.##; 693 $string =~ s#^l4p\.##; 694 $string =~ s#^log4perl\.##i; 695 696 $string =~ s#\.#::#g; 697 698 return $string; 699} 700 701############################################################ 702sub leaf_paths { 703############################################################ 704# Takes a reference to a hash of hashes structure of 705# arbitrary depth, walks the tree and returns a reference 706# to an array of all possible leaf paths (each path is an 707# array again). 708# Example: { a => { b => { c => d }, e => f } } would generate 709# [ [a, b, c, d], [a, e, f] ] 710############################################################ 711 my ($root) = @_; 712 713 my @stack = (); 714 my @result = (); 715 716 push @stack, [$root, []]; 717 718 while(@stack) { 719 my $item = pop @stack; 720 721 my($node, $path) = @$item; 722 723 if(ref($node) eq "HASH") { 724 for(keys %$node) { 725 push @stack, [$node->{$_}, [@$path, $_]]; 726 } 727 } else { 728 push @result, [@$path, $node]; 729 } 730 } 731 return \@result; 732} 733 734########################################### 735sub leaf_path_to_hash { 736########################################### 737 my($leaf_path, $data) = @_; 738 739 my $ref = \$data; 740 741 for my $part ( @$leaf_path[0..$#$leaf_path-1] ) { 742 $ref = \$$ref->{ $part }; 743 } 744 745 return $ref; 746} 747 748########################################### 749sub eval_if_perl { 750########################################### 751 my($value) = @_; 752 753 if(my $cref = compile_if_perl($value)) { 754 return $cref->(); 755 } 756 757 return $value; 758} 759 760########################################### 761sub compile_if_perl { 762########################################### 763 my($value) = @_; 764 765 if($value =~ /^\s*sub\s*{/ ) { 766 my $mask; 767 unless( Log::Log4perl::Config->allow_code() ) { 768 die "\$Log::Log4perl::Config->allow_code() setting " . 769 "prohibits Perl code in config file"; 770 } 771 if( defined( $mask = Log::Log4perl::Config->allowed_code_ops() ) ) { 772 return compile_in_safe_cpt($value, $mask ); 773 } 774 elsif( $mask = Log::Log4perl::Config->allowed_code_ops_convenience_map( 775 Log::Log4perl::Config->allow_code() 776 ) ) { 777 return compile_in_safe_cpt($value, $mask ); 778 } 779 elsif( Log::Log4perl::Config->allow_code() == 1 ) { 780 781 # eval without restriction 782 my $cref = eval "package main; $value" or 783 die "Can't evaluate '$value' ($@)"; 784 return $cref; 785 } 786 else { 787 die "Invalid value for \$Log::Log4perl::Config->allow_code(): '". 788 Log::Log4perl::Config->allow_code() . "'"; 789 } 790 } 791 792 return undef; 793} 794 795########################################### 796sub compile_in_safe_cpt { 797########################################### 798 my($value, $allowed_ops) = @_; 799 800 # set up a Safe compartment 801 require Safe; 802 my $safe = Safe->new(); 803 $safe->permit_only( @{ $allowed_ops } ); 804 805 # share things with the compartment 806 for( keys %{ Log::Log4perl::Config->vars_shared_with_safe_compartment() } ) { 807 my $toshare = Log::Log4perl::Config->vars_shared_with_safe_compartment($_); 808 $safe->share_from( $_, $toshare ) 809 or die "Can't share @{ $toshare } with Safe compartment"; 810 } 811 812 # evaluate with restrictions 813 my $cref = $safe->reval("package main; $value") or 814 die "Can't evaluate '$value' in Safe compartment ($@)"; 815 return $cref; 816 817} 818 819########################################### 820sub boolean_to_perlish { 821########################################### 822 my($value) = @_; 823 824 # Translate boolean to perlish 825 $value = 1 if $value =~ /^true$/i; 826 $value = 0 if $value =~ /^false$/i; 827 828 return $value; 829} 830 831########################################### 832sub vars_shared_with_safe_compartment { 833########################################### 834 my($class, @args) = @_; 835 836 # Allow both for ...::Config::foo() and ...::Config->foo() 837 if(defined $class and $class ne __PACKAGE__) { 838 unshift @args, $class; 839 } 840 841 # handle different invocation styles 842 if(@args == 1 && ref $args[0] eq 'HASH' ) { 843 # replace entire hash of vars 844 %Log::Log4perl::VARS_SHARED_WITH_SAFE_COMPARTMENT = %{$args[0]}; 845 } 846 elsif( @args == 1 ) { 847 # return vars for given package 848 return $Log::Log4perl::VARS_SHARED_WITH_SAFE_COMPARTMENT{ 849 $args[0]}; 850 } 851 elsif( @args == 2 ) { 852 # add/replace package/var pair 853 $Log::Log4perl::VARS_SHARED_WITH_SAFE_COMPARTMENT{ 854 $args[0]} = $args[1]; 855 } 856 857 return wantarray ? %Log::Log4perl::VARS_SHARED_WITH_SAFE_COMPARTMENT 858 : \%Log::Log4perl::VARS_SHARED_WITH_SAFE_COMPARTMENT; 859 860} 861 862########################################### 863sub allowed_code_ops { 864########################################### 865 my($class, @args) = @_; 866 867 # Allow both for ...::Config::foo() and ...::Config->foo() 868 if(defined $class and $class ne __PACKAGE__) { 869 unshift @args, $class; 870 } 871 872 if(@args) { 873 @Log::Log4perl::ALLOWED_CODE_OPS_IN_CONFIG_FILE = @args; 874 } 875 else { 876 # give back 'undef' instead of an empty arrayref 877 unless( @Log::Log4perl::ALLOWED_CODE_OPS_IN_CONFIG_FILE ) { 878 return; 879 } 880 } 881 882 return wantarray ? @Log::Log4perl::ALLOWED_CODE_OPS_IN_CONFIG_FILE 883 : \@Log::Log4perl::ALLOWED_CODE_OPS_IN_CONFIG_FILE; 884} 885 886########################################### 887sub allowed_code_ops_convenience_map { 888########################################### 889 my($class, @args) = @_; 890 891 # Allow both for ...::Config::foo() and ...::Config->foo() 892 if(defined $class and $class ne __PACKAGE__) { 893 unshift @args, $class; 894 } 895 896 # handle different invocation styles 897 if( @args == 1 && ref $args[0] eq 'HASH' ) { 898 # replace entire map 899 %Log::Log4perl::ALLOWED_CODE_OPS = %{$args[0]}; 900 } 901 elsif( @args == 1 ) { 902 # return single opcode mask 903 return $Log::Log4perl::ALLOWED_CODE_OPS{ 904 $args[0]}; 905 } 906 elsif( @args == 2 ) { 907 # make sure the mask is an array ref 908 if( ref $args[1] ne 'ARRAY' ) { 909 die "invalid mask (not an array ref) for convenience name '$args[0]'"; 910 } 911 # add name/mask pair 912 $Log::Log4perl::ALLOWED_CODE_OPS{ 913 $args[0]} = $args[1]; 914 } 915 916 return wantarray ? %Log::Log4perl::ALLOWED_CODE_OPS 917 : \%Log::Log4perl::ALLOWED_CODE_OPS 918} 919 920########################################### 921sub allow_code { 922########################################### 923 my($class, @args) = @_; 924 925 # Allow both for ...::Config::foo() and ...::Config->foo() 926 if(defined $class and $class ne __PACKAGE__) { 927 unshift @args, $class; 928 } 929 930 if(@args) { 931 $Log::Log4perl::ALLOW_CODE_IN_CONFIG_FILE = 932 $args[0]; 933 } 934 935 return $Log::Log4perl::ALLOW_CODE_IN_CONFIG_FILE; 936} 937 938################################################ 939sub var_subst { 940################################################ 941 my($varname, $subst_hash) = @_; 942 943 # Throw out blanks 944 $varname =~ s/\s+//g; 945 946 if(exists $subst_hash->{$varname}) { 947 print "Replacing variable: '$varname' => '$subst_hash->{$varname}'\n" 948 if _INTERNAL_DEBUG; 949 return $subst_hash->{$varname}; 950 951 } elsif(exists $ENV{$varname}) { 952 print "Replacing ENV variable: '$varname' => '$ENV{$varname}'\n" 953 if _INTERNAL_DEBUG; 954 return $ENV{$varname}; 955 956 } 957 958 die "Undefined Variable '$varname'"; 959} 960 9611; 962 963__END__ 964 965=head1 NAME 966 967Log::Log4perl::Config - Log4perl configuration file syntax 968 969=head1 DESCRIPTION 970 971In C<Log::Log4perl>, configuration files are used to describe how the 972system's loggers ought to behave. 973 974The format is the same as the one as used for C<log4j>, just with 975a few perl-specific extensions, like enabling the C<Bar::Twix> 976syntax instead of insisting on the Java-specific C<Bar.Twix>. 977 978Comment lines (starting with arbitrary whitespace and a #) and 979blank lines (all whitespace or empty) are ignored. 980 981Also, blanks between syntactical entities are ignored, it doesn't 982matter if you write 983 984 log4perl.logger.Bar.Twix=WARN,Screen 985 986or 987 988 log4perl.logger.Bar.Twix = WARN, Screen 989 990C<Log::Log4perl> will strip the blanks while parsing your input. 991 992Assignments need to be on a single line. However, you can break the 993line if you want to by using a continuation character at the end of the 994line. Instead of writing 995 996 log4perl.appender.A1.layout=Log::Log4perl::Layout::SimpleLayout 997 998you can break the line at any point by putting a backslash at the very (!) 999end of the line to be continued: 1000 1001 log4perl.appender.A1.layout=\ 1002 Log::Log4perl::Layout::SimpleLayout 1003 1004Watch out for trailing blanks after the backslash, which would prevent 1005the line from being properly concatenated. 1006 1007=head2 Loggers 1008 1009Loggers are addressed by category: 1010 1011 log4perl.logger.Bar.Twix = WARN, Screen 1012 1013This sets all loggers under the C<Bar::Twix> hierarchy on priority 1014C<WARN> and attaches a later-to-be-defined C<Screen> appender to them. 1015Settings for the root appender (which doesn't have a name) can be 1016accomplished by simply omitting the name: 1017 1018 log4perl.logger = FATAL, Database, Mailer 1019 1020This sets the root appender's level to C<FATAL> and also attaches the 1021later-to-be-defined appenders C<Database> and C<Mailer> to it. 1022 1023The additivity flag of a logger is set or cleared via the 1024C<additivity> keyword: 1025 1026 log4perl.additivity.Bar.Twix = 0|1 1027 1028(Note the reversed order of keyword and logger name, resulting 1029from the dilemma that a logger name could end in C<.additivity> 1030according to the log4j documentation). 1031 1032=head2 Appenders and Layouts 1033 1034Appender names used in Log4perl configuration file 1035lines need to be resolved later on, in order to 1036define the appender's properties and its layout. To specify properties 1037of an appender, just use the C<appender> keyword after the 1038C<log4perl> intro and the appender's name: 1039 1040 # The Bar::Twix logger and its appender 1041 log4perl.logger.Bar.Twix = DEBUG, A1 1042 log4perl.appender.A1=Log::Log4perl::Appender::File 1043 log4perl.appender.A1.filename=test.log 1044 log4perl.appender.A1.mode=append 1045 log4perl.appender.A1.layout=Log::Log4perl::Layout::SimpleLayout 1046 1047This sets a priority of C<DEBUG> for loggers in the C<Bar::Twix> 1048hierarchy and assigns the C<A1> appender to it, which is later on 1049resolved to be an appender of type C<Log::Log4perl::Appender::File>, simply 1050appending to a log file. According to the C<Log::Log4perl::Appender::File> 1051manpage, the C<filename> parameter specifies the name of the log file 1052and the C<mode> parameter can be set to C<append> or C<write> (the 1053former will append to the logfile if one with the specified name 1054already exists while the latter would clobber and overwrite it). 1055 1056The order of the entries in the configuration file is not important, 1057C<Log::Log4perl> will read in the entire file first and try to make 1058sense of the lines after it knows the entire context. 1059 1060You can very well define all loggers first and then their appenders 1061(you could even define your appenders first and then your loggers, 1062but let's not go there): 1063 1064 log4perl.logger.Bar.Twix = DEBUG, A1 1065 log4perl.logger.Bar.Snickers = FATAL, A2 1066 1067 log4perl.appender.A1=Log::Log4perl::Appender::File 1068 log4perl.appender.A1.filename=test.log 1069 log4perl.appender.A1.mode=append 1070 log4perl.appender.A1.layout=Log::Log4perl::Layout::SimpleLayout 1071 1072 log4perl.appender.A2=Log::Log4perl::Appender::Screen 1073 log4perl.appender.A2.stderr=0 1074 log4perl.appender.A2.layout=Log::Log4perl::Layout::PatternLayout 1075 log4perl.appender.A2.layout.ConversionPattern = %d %m %n 1076 1077Note that you have to specify the full path to the layout class 1078and that C<ConversionPattern> is the keyword to specify the printf-style 1079formatting instructions. 1080 1081=head1 Configuration File Cookbook 1082 1083Here's some examples of often-used Log4perl configuration files: 1084 1085=head2 Append to STDERR 1086 1087 log4perl.category.Bar.Twix = WARN, Screen 1088 log4perl.appender.Screen = Log::Log4perl::Appender::Screen 1089 log4perl.appender.Screen.layout = \ 1090 Log::Log4perl::Layout::PatternLayout 1091 log4perl.appender.Screen.layout.ConversionPattern = %d %m %n 1092 1093=head2 Append to STDOUT 1094 1095 log4perl.category.Bar.Twix = WARN, Screen 1096 log4perl.appender.Screen = Log::Log4perl::Appender::Screen 1097 log4perl.appender.Screen.stderr = 0 1098 log4perl.appender.Screen.layout = \ 1099 Log::Log4perl::Layout::PatternLayout 1100 log4perl.appender.Screen.layout.ConversionPattern = %d %m %n 1101 1102=head2 Append to a log file 1103 1104 log4perl.logger.Bar.Twix = DEBUG, A1 1105 log4perl.appender.A1=Log::Log4perl::Appender::File 1106 log4perl.appender.A1.filename=test.log 1107 log4perl.appender.A1.mode=append 1108 log4perl.appender.A1.layout = \ 1109 Log::Log4perl::Layout::PatternLayout 1110 log4perl.appender.A1.layout.ConversionPattern = %d %m %n 1111 1112Note that you could even leave out 1113 1114 log4perl.appender.A1.mode=append 1115 1116and still have the logger append to the logfile by default, although 1117the C<Log::Log4perl::Appender::File> module does exactly the opposite. 1118This is due to some nasty trickery C<Log::Log4perl> performs behind 1119the scenes to make sure that beginner's CGI applications don't clobber 1120the log file every time they're called. 1121 1122=head2 Write a log file from scratch 1123 1124If you loathe the Log::Log4perl's append-by-default strategy, you can 1125certainly override it: 1126 1127 log4perl.logger.Bar.Twix = DEBUG, A1 1128 log4perl.appender.A1=Log::Log4perl::Appender::File 1129 log4perl.appender.A1.filename=test.log 1130 log4perl.appender.A1.mode=write 1131 log4perl.appender.A1.layout=Log::Log4perl::Layout::SimpleLayout 1132 1133C<write> is the C<mode> that has C<Log::Log4perl::Appender::File> 1134explicitely clobber the log file if it exists. 1135 1136=head2 Configuration files encoded in utf-8 1137 1138If your configuration file is encoded in utf-8 (which matters if you 1139e.g. specify utf8-encoded appender filenames in it), then you need to 1140tell Log4perl before running init(): 1141 1142 use Log::Log4perl::Config; 1143 Log::Log4perl::Config->utf( 1 ); 1144 1145 Log::Log4perl->init( ... ); 1146 1147This makes sure Log4perl interprets utf8-encoded config files correctly. 1148This setting might become the default at some point. 1149 1150=head1 SEE ALSO 1151 1152Log::Log4perl::Config::PropertyConfigurator 1153 1154Log::Log4perl::Config::DOMConfigurator 1155 1156Log::Log4perl::Config::LDAPConfigurator (coming soon!) 1157 1158=head1 LICENSE 1159 1160Copyright 2002-2012 by Mike Schilli E<lt>m@perlmeister.comE<gt> 1161and Kevin Goess E<lt>cpan@goess.orgE<gt>. 1162 1163This library is free software; you can redistribute it and/or modify 1164it under the same terms as Perl itself. 1165 1166=head1 AUTHOR 1167 1168Please contribute patches to the project on Github: 1169 1170 http://github.com/mschilli/log4perl 1171 1172Send bug reports or requests for enhancements to the authors via our 1173 1174MAILING LIST (questions, bug reports, suggestions/patches): 1175log4perl-devel@lists.sourceforge.net 1176 1177Authors (please contact them via the list above, not directly): 1178Mike Schilli <m@perlmeister.com>, 1179Kevin Goess <cpan@goess.org> 1180 1181Contributors (in alphabetical order): 1182Ateeq Altaf, Cory Bennett, Jens Berthold, Jeremy Bopp, Hutton 1183Davidson, Chris R. Donnelly, Matisse Enzer, Hugh Esco, Anthony 1184Foiani, James FitzGibbon, Carl Franks, Dennis Gregorovic, Andy 1185Grundman, Paul Harrington, David Hull, Robert Jacobson, Jason Kohles, 1186Jeff Macdonald, Markus Peter, Brett Rann, Peter Rabbitson, Erik 1187Selberg, Aaron Straup Cope, Lars Thegler, David Viner, Mac Yang. 1188 1189