1################################################## 2package Log::Log4perl::Logger; 3################################################## 4 5use 5.006; 6use strict; 7use warnings; 8 9use Log::Log4perl; 10use Log::Log4perl::Level; 11use Log::Log4perl::Layout; 12use Log::Log4perl::Appender; 13use Log::Log4perl::Appender::String; 14use Log::Log4perl::Filter; 15use Carp; 16 17$Carp::Internal{"Log::Log4perl"}++; 18$Carp::Internal{"Log::Log4perl::Logger"}++; 19 20use constant _INTERNAL_DEBUG => 0; 21 22 # Initialization 23our $ROOT_LOGGER; 24our $LOGGERS_BY_NAME = {}; 25our %APPENDER_BY_NAME = (); 26our $INITIALIZED = 0; 27our $NON_INIT_WARNED; 28our $DIE_DEBUG = 0; 29our $DIE_DEBUG_BUFFER = ""; 30 # Define the default appender that's used for formatting 31 # warn/die/croak etc. messages. 32our $STRING_APP_NAME = "_l4p_warn"; 33our $STRING_APP = Log::Log4perl::Appender->new( 34 "Log::Log4perl::Appender::String", 35 name => $STRING_APP_NAME); 36$STRING_APP->layout(Log::Log4perl::Layout::PatternLayout->new("%m")); 37our $STRING_APP_CODEREF = generate_coderef([[$STRING_APP_NAME, $STRING_APP]]); 38 39__PACKAGE__->reset(); 40 41########################################### 42sub warning_render { 43########################################### 44 my($logger, @message) = @_; 45 46 $STRING_APP->string(""); 47 $STRING_APP_CODEREF->($logger, 48 @message, 49 Log::Log4perl::Level::to_level($ALL)); 50 return $STRING_APP->string(); 51} 52 53################################################## 54sub cleanup { 55################################################## 56 # warn "Logger cleanup"; 57 58 # Nuke all convenience loggers to avoid them causing cleanup to 59 # be delayed until global destruction. Problem is that something like 60 # *{"DEBUG"} = sub { $logger->debug }; 61 # ties up a reference to $logger until global destruction, so we 62 # need to clean up all :easy shortcuts, hence freeing the last 63 # logger references, to then rely on the garbage collector for cleaning 64 # up the loggers. 65 Log::Log4perl->easy_closure_global_cleanup(); 66 67 # Delete all loggers 68 $LOGGERS_BY_NAME = {}; 69 70 # Delete the root logger 71 undef $ROOT_LOGGER; 72 73 # Delete all appenders 74 %APPENDER_BY_NAME = (); 75 76 undef $INITIALIZED; 77} 78 79################################################## 80sub DESTROY { 81################################################## 82 CORE::warn "Destroying logger $_[0] ($_[0]->{category})" 83 if $Log::Log4perl::CHATTY_DESTROY_METHODS; 84} 85 86################################################## 87sub reset { 88################################################## 89 $ROOT_LOGGER = __PACKAGE__->_new("", $OFF); 90# $LOGGERS_BY_NAME = {}; #leave this alone, it's used by 91 #reset_all_output_methods when 92 #the config changes 93 94 %APPENDER_BY_NAME = (); 95 undef $INITIALIZED; 96 undef $NON_INIT_WARNED; 97 Log::Log4perl::Appender::reset(); 98 99 #clear out all the existing appenders 100 foreach my $logger (values %$LOGGERS_BY_NAME){ 101 $logger->{appender_names} = []; 102 103 #this next bit deals with an init_and_watch case where a category 104 #is deleted from the config file, we need to zero out the existing 105 #loggers so ones not in the config file not continue with their old 106 #behavior --kg 107 next if $logger eq $ROOT_LOGGER; 108 $logger->{level} = undef; 109 $logger->level(); #set it from the hierarchy 110 } 111 112 # Clear all filters 113 Log::Log4perl::Filter::reset(); 114} 115 116################################################## 117sub _new { 118################################################## 119 my($class, $category, $level) = @_; 120 121 print("_new: $class/$category/", defined $level ? $level : "undef", 122 "\n") if _INTERNAL_DEBUG; 123 124 die "usage: __PACKAGE__->_new(category)" unless 125 defined $category; 126 127 $category =~ s/::/./g; 128 129 # Have we created it previously? 130 if(exists $LOGGERS_BY_NAME->{$category}) { 131 print "_new: exists already\n" if _INTERNAL_DEBUG; 132 return $LOGGERS_BY_NAME->{$category}; 133 } 134 135 my $self = { 136 category => $category, 137 num_appenders => 0, 138 additivity => 1, 139 level => $level, 140 layout => undef, 141 }; 142 143 bless $self, $class; 144 145 $level ||= $self->level(); 146 147 # Save it in global structure 148 $LOGGERS_BY_NAME->{$category} = $self; 149 150 $self->set_output_methods; 151 152 print("Created logger $self ($category)\n") if _INTERNAL_DEBUG; 153 154 return $self; 155} 156 157################################################## 158sub category { 159################################################## 160 my ($self) = @_; 161 162 return $self->{ category }; 163} 164 165################################################## 166sub reset_all_output_methods { 167################################################## 168 print "reset_all_output_methods: \n" if _INTERNAL_DEBUG; 169 170 foreach my $loggername ( keys %$LOGGERS_BY_NAME){ 171 $LOGGERS_BY_NAME->{$loggername}->set_output_methods; 172 } 173 $ROOT_LOGGER->set_output_methods; 174} 175 176################################################## 177sub set_output_methods { 178# Here's a big performance increase. Instead of having the logger 179# calculate whether to log and whom to log to every time log() is called, 180# we calculcate it once when the logger is created, and recalculate 181# it if the config information ever changes. 182# 183################################################## 184 my ($self) = @_; 185 186 my (@appenders, %seen); 187 188 my ($level) = $self->level(); 189 190 print "set_output_methods: $self->{category}/$level\n" if _INTERNAL_DEBUG; 191 192 #collect the appenders in effect for this category 193 194 for(my $logger = $self; $logger; $logger = parent_logger($logger)) { 195 196 foreach my $appender_name (@{$logger->{appender_names}}){ 197 198 #only one message per appender, (configurable) 199 next if $seen{$appender_name} ++ && 200 $Log::Log4perl::one_message_per_appender; 201 202 push (@appenders, 203 [$appender_name, 204 $APPENDER_BY_NAME{$appender_name}, 205 ] 206 ); 207 } 208 last unless $logger->{additivity}; 209 } 210 211 #make a no-op coderef for inactive levels 212 my $noop = generate_noop_coderef(); 213 214 #make a coderef 215 my $coderef = (! @appenders ? $noop : &generate_coderef(\@appenders)); 216 217 my %priority = %Log::Log4perl::Level::PRIORITY; #convenience and cvs 218 219 # changed to >= from <= as level ints were reversed 220 foreach my $levelname (keys %priority){ 221 if (Log::Log4perl::Level::isGreaterOrEqual($level, 222 $priority{$levelname} 223 )) { 224 print " ($priority{$levelname} <= $level)\n" 225 if _INTERNAL_DEBUG; 226 $self->{$levelname} = $coderef; 227 $self->{"is_$levelname"} = generate_is_xxx_coderef("1"); 228 print "Setting is_$levelname to 1\n" if _INTERNAL_DEBUG; 229 }else{ 230 print " ($priority{$levelname} > $level)\n" if _INTERNAL_DEBUG; 231 $self->{$levelname} = $noop; 232 $self->{"is_$levelname"} = generate_is_xxx_coderef("0"); 233 print "Setting is_$levelname to 0\n" if _INTERNAL_DEBUG; 234 } 235 236 print(" Setting [$self] $self->{category}.$levelname to ", 237 ($self->{$levelname} == $noop ? "NOOP" : 238 ("Coderef [$coderef]: " . scalar @appenders . " appenders")), 239 "\n") if _INTERNAL_DEBUG; 240 } 241} 242 243################################################## 244sub generate_coderef { 245################################################## 246 my $appenders = shift; 247 248 print "generate_coderef: ", scalar @$appenders, 249 " appenders\n" if _INTERNAL_DEBUG; 250 251 my $watch_check_code = generate_watch_code("logger", 1); 252 253 return sub { 254 my $logger = shift; 255 my $level = pop; 256 257 my $message; 258 my $appenders_fired = 0; 259 260 # Evaluate all parameters that need to be evaluated. Two kinds: 261 # 262 # (1) It's a hash like { filter => "filtername", 263 # value => "value" } 264 # => filtername(value) 265 # 266 # (2) It's a code ref 267 # => coderef() 268 # 269 270 $message = [map { ref $_ eq "HASH" && 271 exists $_->{filter} && 272 ref $_->{filter} eq 'CODE' ? 273 $_->{filter}->($_->{value}) : 274 ref $_ eq "CODE" ? 275 $_->() : $_ 276 } @_]; 277 278 print("coderef: $logger->{category}\n") if _INTERNAL_DEBUG; 279 280 if(defined $Log::Log4perl::Config::WATCHER) { 281 return unless $watch_check_code->($logger, @_, $level); 282 } 283 284 foreach my $a (@$appenders) { #note the closure here 285 my ($appender_name, $appender) = @$a; 286 287 print(" Sending message '<$message->[0]>' ($level) " . 288 "to $appender_name\n") if _INTERNAL_DEBUG; 289 290 $appender->log( 291 #these get passed through to Log::Dispatch 292 { name => $appender_name, 293 level => $Log::Log4perl::Level::L4P_TO_LD{ 294 $level}, 295 message => $message, 296 }, 297 #these we need 298 $logger->{category}, 299 $level, 300 ) and $appenders_fired++; 301 # Only counting it if it returns a true value. Otherwise 302 # the appender threshold might have suppressed it after all. 303 304 } #end foreach appenders 305 306 return $appenders_fired; 307 308 }; #end coderef 309} 310 311################################################## 312sub generate_noop_coderef { 313################################################## 314 my $watch_delay_code; 315 316 # This might seem crazy at first, but even in a Log4perl noop, we 317 # need to check if the configuration changed in a init_and_watch 318 # situation. Why? Say, an application is running in a loop that 319 # constantly tries to issue debug() messages, but they're suppressed by 320 # the current Log4perl configuration. If debug() (which is a noop 321 # here) wasn't watching the configuration for changes, it would never 322 # catch the case where someone bumps up the log level and expects 323 # the application to pick it up and start logging debug() statements. 324 325 my $watch_check_code = generate_watch_code("logger", 1); 326 327 my $coderef; 328 329 if(defined $Log::Log4perl::Config::WATCHER) { 330 $coderef = $watch_check_code; 331 } else { 332 $coderef = sub { undef }; 333 } 334 335 return $coderef; 336} 337 338################################################## 339sub generate_is_xxx_coderef { 340################################################## 341 my($return_token) = @_; 342 343 return generate_watch_code("checker", $return_token); 344} 345 346################################################## 347sub generate_watch_code { 348################################################## 349 my($type, $return_token) = @_; 350 351 print "generate_watch_code:\n" if _INTERNAL_DEBUG; 352 353 # No watcher configured, return a no-op as watch code. 354 if(! defined $Log::Log4perl::Config::WATCHER) { 355 return sub { $return_token }; 356 } 357 358 my $cond = generate_watch_conditional(); 359 360 return sub { 361 print "exe_watch_code:\n" if _INTERNAL_DEBUG; 362 363 if(_INTERNAL_DEBUG) { 364 print "Next check: ", 365 "$Log::Log4perl::Config::Watch::NEXT_CHECK_TIME ", 366 " Now: ", time(), " Mod: ", 367 (stat($Log::Log4perl::Config::WATCHER->file()))[9], 368 "\n"; 369 } 370 371 if( $cond->() ) { 372 my $init_permitted = 1; 373 374 if(exists $Log::Log4perl::Config::OPTS->{ preinit_callback } ) { 375 print "Calling preinit_callback\n" if _INTERNAL_DEBUG; 376 $init_permitted = 377 $Log::Log4perl::Config::OPTS->{ preinit_callback }->( 378 Log::Log4perl::Config->watcher()->file() ); 379 print "Callback returned $init_permitted\n" if _INTERNAL_DEBUG; 380 } 381 382 if( $init_permitted ) { 383 Log::Log4perl->init_and_watch(); 384 } else { 385 # It was time to reinit, but init wasn't permitted. 386 # Return true, so that the logger continues as if 387 # it wasn't time to reinit. 388 return 1; 389 } 390 391 my $logger = shift; 392 my $level = pop; 393 394 # Forward call to new configuration 395 if($type eq "checker") { 396 return $logger->$level(); 397 398 } elsif( $type eq "logger") { 399 my $methodname = lc($level); 400 401 # Bump up the caller level by three, since 402 # we've artifically introduced additional levels. 403 local $Log::Log4perl::caller_depth = 404 $Log::Log4perl::caller_depth + 3; 405 406 # Get a new logger for the same category (the old 407 # logger might be obsolete because of the re-init) 408 $logger = Log::Log4perl::get_logger( $logger->{category} ); 409 410 $logger->$methodname(@_); # send the message 411 # to the new configuration 412 return undef; # Return false, so the logger finishes 413 # prematurely and doesn't log the same 414 # message again. 415 } else { 416 die "internal error: unknown type"; 417 } 418 } else { 419 if(_INTERNAL_DEBUG) { 420 print "Conditional returned false\n"; 421 } 422 return $return_token; 423 } 424 }; 425} 426 427################################################## 428sub generate_watch_conditional { 429################################################## 430 431 if(defined $Log::Log4perl::Config::Watch::SIGNAL_CAUGHT) { 432 # In this mode, we just check for the variable indicating 433 # that the signal has been caught 434 return sub { 435 return $Log::Log4perl::Config::Watch::SIGNAL_CAUGHT; 436 }; 437 } 438 439 return sub { 440 return 441 ( time() > $Log::Log4perl::Config::Watch::NEXT_CHECK_TIME and 442 $Log::Log4perl::Config::WATCHER->change_detected() ); 443 }; 444} 445 446################################################## 447sub parent_string { 448################################################## 449 my($string) = @_; 450 451 if($string eq "") { 452 return undef; # root doesn't have a parent. 453 } 454 455 my @components = split /\./, $string; 456 457 if(@components == 1) { 458 return ""; 459 } 460 461 pop @components; 462 463 return join('.', @components); 464} 465 466################################################## 467sub level { 468################################################## 469 my($self, $level, $dont_reset_all) = @_; 470 471 # 'Set' function 472 if(defined $level) { 473 croak "invalid level '$level'" 474 unless Log::Log4perl::Level::is_valid($level); 475 if ($level =~ /\D/){ 476 $level = Log::Log4perl::Level::to_priority($level); 477 } 478 $self->{level} = $level; 479 480 &reset_all_output_methods 481 unless $dont_reset_all; #keep us from getting overworked 482 #if it's the config file calling us 483 484 return $level; 485 } 486 487 # 'Get' function 488 if(defined $self->{level}) { 489 return $self->{level}; 490 } 491 492 for(my $logger = $self; $logger; $logger = parent_logger($logger)) { 493 494 # Does the current logger have the level defined? 495 496 if($logger->{category} eq "") { 497 # It's the root logger 498 return $ROOT_LOGGER->{level}; 499 } 500 501 if(defined $LOGGERS_BY_NAME->{$logger->{category}}->{level}) { 502 return $LOGGERS_BY_NAME->{$logger->{category}}->{level}; 503 } 504 } 505 506 # We should never get here because at least the root logger should 507 # have a level defined 508 die "We should never get here."; 509} 510 511################################################## 512sub parent_logger { 513# Get the parent of the current logger or undef 514################################################## 515 my($logger) = @_; 516 517 # Is it the root logger? 518 if($logger->{category} eq "") { 519 # Root has no parent 520 return undef; 521 } 522 523 # Go to the next defined (!) parent 524 my $parent_class = parent_string($logger->{category}); 525 526 while($parent_class ne "" and 527 ! exists $LOGGERS_BY_NAME->{$parent_class}) { 528 $parent_class = parent_string($parent_class); 529 $logger = $LOGGERS_BY_NAME->{$parent_class}; 530 } 531 532 if($parent_class eq "") { 533 $logger = $ROOT_LOGGER; 534 } else { 535 $logger = $LOGGERS_BY_NAME->{$parent_class}; 536 } 537 538 return $logger; 539} 540 541################################################## 542sub get_root_logger { 543################################################## 544 my($class) = @_; 545 return $ROOT_LOGGER; 546} 547 548################################################## 549sub additivity { 550################################################## 551 my($self, $onoff) = @_; 552 553 if(defined $onoff) { 554 $self->{additivity} = $onoff; 555 } 556 557 return $self->{additivity}; 558} 559 560################################################## 561sub get_logger { 562################################################## 563 my($class, $category) = @_; 564 565 unless(defined $ROOT_LOGGER) { 566 Carp::confess "Internal error: Root Logger not initialized."; 567 } 568 569 return $ROOT_LOGGER if $category eq ""; 570 571 my $logger = $class->_new($category); 572 return $logger; 573} 574 575################################################## 576sub add_appender { 577################################################## 578 my($self, $appender, $dont_reset_all) = @_; 579 580 # We take this as an indicator that we're initialized. 581 $INITIALIZED = 1; 582 583 my $appender_name = $appender->name(); 584 585 $self->{num_appenders}++; #should this be inside the unless? 586 587 # Add newly created appender to the end of the appender array 588 unless (grep{$_ eq $appender_name} @{$self->{appender_names}}){ 589 $self->{appender_names} = [sort @{$self->{appender_names}}, 590 $appender_name]; 591 } 592 593 $APPENDER_BY_NAME{$appender_name} = $appender; 594 595 reset_all_output_methods 596 unless $dont_reset_all; # keep us from getting overworked 597 # if it's the config file calling us 598 599 # For chaining calls ... 600 return $appender; 601} 602 603################################################## 604sub remove_appender { 605################################################## 606 my($self, $appender_name, $dont_reset_all, $sloppy) = @_; 607 608 my %appender_names = map { $_ => 1 } @{$self->{appender_names}}; 609 610 if(!exists $appender_names{$appender_name}) { 611 die "No such appender: $appender_name" unless $sloppy; 612 return undef; 613 } 614 615 delete $appender_names{$appender_name}; 616 $self->{num_appenders}--; 617 $self->{appender_names} = [sort keys %appender_names]; 618 619 &reset_all_output_methods 620 unless $dont_reset_all; 621} 622 623################################################## 624sub eradicate_appender { 625################################################## 626 # If someone calls Logger->... and not Logger::... 627 shift if $_[0] eq __PACKAGE__; 628 629 my($appender_name, $dont_reset_all) = @_; 630 631 return 0 unless exists 632 $APPENDER_BY_NAME{$appender_name}; 633 634 # Remove the given appender from all loggers 635 # and delete all references to it, causing 636 # its DESTROY method to be called. 637 foreach my $logger (values %$LOGGERS_BY_NAME){ 638 $logger->remove_appender($appender_name, 0, 1); 639 } 640 # Also remove it from the root logger 641 $ROOT_LOGGER->remove_appender($appender_name, 0, 1); 642 643 delete $APPENDER_BY_NAME{$appender_name}; 644 645 &reset_all_output_methods 646 unless $dont_reset_all; 647 648 return 1; 649} 650 651################################################## 652sub has_appenders { 653################################################## 654 my($self) = @_; 655 656 return $self->{num_appenders}; 657} 658 659################################################## 660sub log { 661# external api 662################################################## 663 my ($self, $priority, @messages) = @_; 664 665 confess("log: No priority given!") unless defined($priority); 666 667 # Just in case of 'init_and_watch' -- see Changes 0.21 668 $_[0] = $LOGGERS_BY_NAME->{$_[0]->{category}} if 669 defined $Log::Log4perl::Config::WATCHER; 670 671 init_warn() unless $INITIALIZED or $NON_INIT_WARNED; 672 673 croak "priority $priority isn't numeric" if ($priority =~ /\D/); 674 675 my $which = Log::Log4perl::Level::to_level($priority); 676 677 $self->{$which}->($self, @messages, 678 Log::Log4perl::Level::to_level($priority)); 679} 680 681###################################################################### 682# 683# create_custom_level 684# creates a custom level 685# in theory, could be used to create the default ones 686###################################################################### 687sub create_custom_level { 688###################################################################### 689 my $level = shift || die("create_custom_level: " . 690 "forgot to pass in a level string!"); 691 my $after = shift || die("create_custom_level: " . 692 "forgot to pass in a level after which to " . 693 "place the new level!"); 694 my $syslog_equiv = shift; # can be undef 695 my $log_dispatch_level = shift; # optional 696 697 ## only let users create custom levels before initialization 698 699 die("create_custom_level must be called before init or " . 700 "first get_logger() call") if ($INITIALIZED); 701 702 my %PRIORITY = %Log::Log4perl::Level::PRIORITY; #convenience 703 704 die("create_custom_level: no such level \"$after\"! Use one of: ", 705 join(", ", sort keys %PRIORITY)) unless $PRIORITY{$after}; 706 707 # figure out new int value by AFTER + (AFTER+ 1) / 2 708 709 my $next_prio = Log::Log4perl::Level::get_lower_level($PRIORITY{$after}, 1); 710 my $cust_prio = int(($PRIORITY{$after} + $next_prio) / 2); 711 712 die(qq{create_custom_level: Calculated level of $cust_prio already exists! 713 This should only happen if you've made some insane number of custom 714 levels (like 15 one after another) 715 You can usually fix this by re-arranging your code from: 716 create_custom_level("cust1", X); 717 create_custom_level("cust2", X); 718 create_custom_level("cust3", X); 719 create_custom_level("cust4", X); 720 create_custom_level("cust5", X); 721 into: 722 create_custom_level("cust3", X); 723 create_custom_level("cust5", X); 724 create_custom_level("cust4", 4); 725 create_custom_level("cust2", cust3); 726 create_custom_level("cust1", cust2); 727 }) if (${Log::Log4perl::Level::LEVELS{$cust_prio}}); 728 729 Log::Log4perl::Level::add_priority($level, $cust_prio, $syslog_equiv, 730 $log_dispatch_level); 731 732 print("Adding prio $level at $cust_prio\n") if _INTERNAL_DEBUG; 733 734 # get $LEVEL into namespace of Log::Log4perl::Logger to 735 # create $logger->foo nd $logger->is_foo 736 my $name = "Log::Log4perl::Logger::"; 737 my $key = $level; 738 739 no strict qw(refs); 740 # be sure to use ${Log...} as CVS adds log entries for Log 741 *{"$name$key"} = \${Log::Log4perl::Level::PRIORITY{$level}}; 742 743 # now, stick it in the caller's namespace 744 $name = caller(0) . "::"; 745 *{"$name$key"} = \${Log::Log4perl::Level::PRIORITY{$level}}; 746 use strict qw(refs); 747 748 create_log_level_methods($level); 749 750 return 0; 751 752} 753 754######################################## 755# 756# if we were hackin' lisp (or scheme), we'd be returning some lambda 757# expressions. But we aren't. :) So we'll just create some strings and 758# eval them. 759######################################## 760sub create_log_level_methods { 761######################################## 762 my $level = shift || die("create_log_level_methods: " . 763 "forgot to pass in a level string!"); 764 my $lclevel = lc($level); 765 my $levelint = uc($level) . "_INT"; 766 my $initial_cap = ucfirst($lclevel); 767 768 no strict qw(refs); 769 770 # This is a bit better way to create code on the fly than eval'ing strings. 771 # -erik 772 773 *{__PACKAGE__ . "::$lclevel"} = sub { 774 if(_INTERNAL_DEBUG) { 775 my $level_disp = (defined $_[0]->{level} ? $_[0]->{level} 776 : "[undef]"); 777 print "$lclevel: ($_[0]->{category}/$level_disp) [@_]\n"; 778 } 779 init_warn() unless $INITIALIZED or $NON_INIT_WARNED; 780 $_[0]->{$level}->(@_, $level) if defined $_[0]->{$level}; 781 }; 782 783 # Added these to have is_xxx functions as fast as xxx functions 784 # -ms 785 786 my $islevel = "is_" . $level; 787 my $islclevel = "is_" . $lclevel; 788 789 *{__PACKAGE__ . "::is_$lclevel"} = sub { 790 $_[0]->{$islevel}->($_[0], $islclevel); 791 }; 792 793 # Add the isXxxEnabled() methods as identical to the is_xxx 794 # functions. - dviner 795 796 *{__PACKAGE__ . "::is".$initial_cap."Enabled"} = 797 \&{__PACKAGE__ . "::is_$lclevel"}; 798 799 use strict qw(refs); 800 801 return 0; 802} 803 804#now lets autogenerate the logger subs based on the defined priorities 805foreach my $level (keys %Log::Log4perl::Level::PRIORITY){ 806 create_log_level_methods($level); 807} 808 809################################################## 810sub init_warn { 811################################################## 812 CORE::warn "Log4perl: Seems like no initialization happened. " . 813 "Forgot to call init()?\n"; 814 # Only tell this once; 815 $NON_INIT_WARNED = 1; 816} 817 818####################################################### 819# call me from a sub-func to spew the sub-func's caller 820####################################################### 821sub callerline { 822 my $message = join ('', @_); 823 824 my $caller_offset = 825 Log::Log4perl::caller_depth_offset( 826 $Log::Log4perl::caller_depth + 1 ); 827 828 my ($pack, $file, $line) = caller($caller_offset); 829 830 if (not chomp $message) { # no newline 831 $message .= " at $file line $line"; 832 833 # Someday, we'll use Threads. Really. 834 if (defined &Thread::tid) { 835 my $tid = Thread->self->tid; 836 $message .= " thread $tid" if $tid; 837 } 838 } 839 840 return ($message, "\n"); 841} 842 843####################################################### 844sub and_warn { 845####################################################### 846 my $self = shift; 847 CORE::warn(callerline($self->warning_render(@_))); 848} 849 850####################################################### 851sub and_die { 852####################################################### 853 my $self = shift; 854 my $arg = $_[0]; 855 856 my($msg) = callerline($self->warning_render(@_)); 857 858 if($DIE_DEBUG) { 859 $DIE_DEBUG_BUFFER = "DIE_DEBUG: $msg"; 860 } else { 861 if( $Log::Log4perl::STRINGIFY_DIE_MESSAGE ) { 862 die("$msg\n"); 863 } 864 die $arg; 865 } 866} 867 868################################################## 869sub logwarn { 870################################################## 871 my $self = shift; 872 873 local $Log::Log4perl::caller_depth = 874 $Log::Log4perl::caller_depth + 1; 875 876 if ($self->is_warn()) { 877 # Since we're one caller level off now, compensate for that. 878 my @chomped = @_; 879 chomp($chomped[-1]); 880 $self->warn(@chomped); 881 } 882 883 $self->and_warn(@_); 884} 885 886################################################## 887sub logdie { 888################################################## 889 my $self = shift; 890 891 local $Log::Log4perl::caller_depth = 892 $Log::Log4perl::caller_depth + 1; 893 894 if ($self->is_fatal()) { 895 # Since we're one caller level off now, compensate for that. 896 my @chomped = @_; 897 chomp($chomped[-1]); 898 $self->fatal(@chomped); 899 } 900 901 $Log::Log4perl::LOGDIE_MESSAGE_ON_STDERR ? 902 $self->and_die(@_) : 903 exit($Log::Log4perl::LOGEXIT_CODE); 904} 905 906################################################## 907sub logexit { 908################################################## 909 my $self = shift; 910 911 local $Log::Log4perl::caller_depth = 912 $Log::Log4perl::caller_depth + 1; 913 914 if ($self->is_fatal()) { 915 # Since we're one caller level off now, compensate for that. 916 my @chomped = @_; 917 chomp($chomped[-1]); 918 $self->fatal(@chomped); 919 } 920 921 exit $Log::Log4perl::LOGEXIT_CODE; 922} 923 924################################################## 925# clucks and carps are WARN level 926sub logcluck { 927################################################## 928 my $self = shift; 929 930 local $Log::Log4perl::caller_depth = 931 $Log::Log4perl::caller_depth + 1; 932 933 local $Carp::CarpLevel = 934 $Carp::CarpLevel + 1; 935 936 my $msg = $self->warning_render(@_); 937 938 if ($self->is_warn()) { 939 my $message = Carp::longmess($msg); 940 foreach (split(/\n/, $message)) { 941 $self->warn("$_\n"); 942 } 943 } 944 945 Carp::cluck($msg); 946} 947 948################################################## 949sub logcarp { 950################################################## 951 my $self = shift; 952 953 local $Carp::CarpLevel = $Carp::CarpLevel + 1; 954 955 local $Log::Log4perl::caller_depth = 956 $Log::Log4perl::caller_depth + 1; 957 958 my $msg = $self->warning_render(@_); 959 960 if ($self->is_warn()) { 961 my $message = Carp::shortmess($msg); 962 foreach (split(/\n/, $message)) { 963 $self->warn("$_\n"); 964 } 965 } 966 967 Carp::carp($msg); 968} 969 970################################################## 971# croaks and confess are FATAL level 972################################################## 973sub logcroak { 974################################################## 975 my $self = shift; 976 my $arg = $_[0]; 977 978 my $msg = $self->warning_render(@_); 979 980 local $Carp::CarpLevel = 981 $Carp::CarpLevel + 1; 982 983 local $Log::Log4perl::caller_depth = 984 $Log::Log4perl::caller_depth + 1; 985 986 if ($self->is_fatal()) { 987 my $message = Carp::shortmess($msg); 988 foreach (split(/\n/, $message)) { 989 $self->fatal("$_\n"); 990 } 991 } 992 993 my $croak_msg = $arg; 994 995 if( $Log::Log4perl::STRINGIFY_DIE_MESSAGE ) { 996 $croak_msg = $msg; 997 } 998 999 $Log::Log4perl::LOGDIE_MESSAGE_ON_STDERR ? 1000 Carp::croak($croak_msg) : 1001 exit($Log::Log4perl::LOGEXIT_CODE); 1002} 1003 1004################################################## 1005sub logconfess { 1006################################################## 1007 my $self = shift; 1008 my $arg = $_[0]; 1009 1010 local $Carp::CarpLevel = 1011 $Carp::CarpLevel + 1; 1012 1013 local $Log::Log4perl::caller_depth = 1014 $Log::Log4perl::caller_depth + 1; 1015 1016 my $msg = $self->warning_render(@_); 1017 1018 if ($self->is_fatal()) { 1019 my $message = Carp::longmess($msg); 1020 foreach (split(/\n/, $message)) { 1021 $self->fatal("$_\n"); 1022 } 1023 } 1024 1025 my $confess_msg = $arg; 1026 1027 if( $Log::Log4perl::STRINGIFY_DIE_MESSAGE ) { 1028 $confess_msg = $msg; 1029 } 1030 1031 $Log::Log4perl::LOGDIE_MESSAGE_ON_STDERR ? 1032 confess($confess_msg) : 1033 exit($Log::Log4perl::LOGEXIT_CODE); 1034} 1035 1036################################################## 1037# in case people prefer to use error for warning 1038################################################## 1039sub error_warn { 1040################################################## 1041 my $self = shift; 1042 1043 local $Log::Log4perl::caller_depth = 1044 $Log::Log4perl::caller_depth + 1; 1045 1046 if ($self->is_error()) { 1047 $self->error(@_); 1048 } 1049 1050 $self->and_warn(@_); 1051} 1052 1053################################################## 1054sub error_die { 1055################################################## 1056 my $self = shift; 1057 1058 local $Log::Log4perl::caller_depth = 1059 $Log::Log4perl::caller_depth + 1; 1060 1061 my $msg = $self->warning_render(@_); 1062 1063 if ($self->is_error()) { 1064 $self->error($msg); 1065 } 1066 1067 $Log::Log4perl::LOGDIE_MESSAGE_ON_STDERR ? 1068 $self->and_die($msg) : 1069 exit($Log::Log4perl::LOGEXIT_CODE); 1070} 1071 1072################################################## 1073sub more_logging { 1074################################################## 1075 my ($self) = shift; 1076 return $self->dec_level(@_); 1077} 1078 1079################################################## 1080sub inc_level { 1081################################################## 1082 my ($self, $delta) = @_; 1083 1084 $delta ||= 1; 1085 1086 $self->level(Log::Log4perl::Level::get_higher_level($self->level(), 1087 $delta)); 1088 1089 $self->set_output_methods; 1090} 1091 1092################################################## 1093sub less_logging { 1094################################################## 1095 my ($self) = shift; 1096 return $self->inc_level(@_); 1097} 1098 1099################################################## 1100sub dec_level { 1101################################################## 1102 my ($self, $delta) = @_; 1103 1104 $delta ||= 1; 1105 1106 $self->level(Log::Log4perl::Level::get_lower_level($self->level(), $delta)); 1107 1108 $self->set_output_methods; 1109} 1110 11111; 1112 1113__END__ 1114 1115=head1 NAME 1116 1117Log::Log4perl::Logger - Main Logger Class 1118 1119=head1 SYNOPSIS 1120 1121 # It's not here 1122 1123=head1 DESCRIPTION 1124 1125While everything that makes Log4perl tick is implemented here, 1126please refer to L<Log::Log4perl> for documentation. 1127 1128=head1 LICENSE 1129 1130Copyright 2002-2012 by Mike Schilli E<lt>m@perlmeister.comE<gt> 1131and Kevin Goess E<lt>cpan@goess.orgE<gt>. 1132 1133This library is free software; you can redistribute it and/or modify 1134it under the same terms as Perl itself. 1135 1136=head1 AUTHOR 1137 1138Please contribute patches to the project on Github: 1139 1140 http://github.com/mschilli/log4perl 1141 1142Send bug reports or requests for enhancements to the authors via our 1143 1144MAILING LIST (questions, bug reports, suggestions/patches): 1145log4perl-devel@lists.sourceforge.net 1146 1147Authors (please contact them via the list above, not directly): 1148Mike Schilli <m@perlmeister.com>, 1149Kevin Goess <cpan@goess.org> 1150 1151Contributors (in alphabetical order): 1152Ateeq Altaf, Cory Bennett, Jens Berthold, Jeremy Bopp, Hutton 1153Davidson, Chris R. Donnelly, Matisse Enzer, Hugh Esco, Anthony 1154Foiani, James FitzGibbon, Carl Franks, Dennis Gregorovic, Andy 1155Grundman, Paul Harrington, David Hull, Robert Jacobson, Jason Kohles, 1156Jeff Macdonald, Markus Peter, Brett Rann, Peter Rabbitson, Erik 1157Selberg, Aaron Straup Cope, Lars Thegler, David Viner, Mac Yang. 1158 1159