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