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