home *** CD-ROM | disk | FTP | other *** search
/ PC Professionell 2004 December / PCpro_2004_12.ISO / files / webserver / tsw / TSW_3.4.0.exe / Apache2 / perl / Logger.pm < prev    next >
Encoding:
Perl POD Document  |  2003-09-16  |  23.5 KB  |  850 lines
  1. ##################################################
  2. package Log::Log4perl::Logger;
  3. ##################################################
  4.  
  5. use 5.006;
  6. use strict;
  7. use warnings;
  8.  
  9. use Log::Log4perl::Level;
  10. use Log::Log4perl::Layout;
  11. use Log::Log4perl::Appender;
  12. use Log::Dispatch;
  13. use Carp;
  14.  
  15. use constant DEBUG => 0;
  16.  
  17.     # Initialization
  18. our $ROOT_LOGGER;
  19. our $LOGGERS_BY_NAME = {};
  20. our %APPENDER_BY_NAME = ();
  21. our $INITIALIZED;
  22.  
  23. our $DISPATCHER = Log::Dispatch->new();
  24.  
  25. __PACKAGE__->reset();
  26.  
  27. ##################################################
  28. sub reset {
  29. ##################################################
  30.     $ROOT_LOGGER        = __PACKAGE__->_new("", $DEBUG);
  31. #    $LOGGERS_BY_NAME    = {};  #leave this alone, it's used by 
  32.                                 #reset_all_output_methods when the config changes
  33.  
  34.  
  35.     #we've got a circular reference thing going on somewhere
  36.     foreach my $appendername (keys %APPENDER_BY_NAME){
  37.         delete $APPENDER_BY_NAME{$appendername}->{appender} 
  38.                 if (exists $APPENDER_BY_NAME{$appendername} &&
  39.                     exists $APPENDER_BY_NAME{$appendername}->{appender});
  40.     }
  41.     %APPENDER_BY_NAME   = ();
  42.     $DISPATCHER         = Log::Dispatch->new();
  43.     undef $INITIALIZED;
  44.     Log::Log4perl::Appender::reset();
  45.  
  46.     #clear out all the existing appenders
  47.     foreach my $logger (values %$LOGGERS_BY_NAME){
  48.         $logger->{appender_names} = ();
  49.  
  50.     #this next bit deals with an init_and_watch case where a category
  51.     #is deleted from the config file, we need to zero out the existing
  52.     #loggers so ones not in the config file not continue with their old
  53.     #behavior --kg
  54.         next if $logger eq $ROOT_LOGGER;
  55.         $logger->{level} = undef;
  56.         $logger->level();  #set it from the heirarchy
  57.     }
  58.  
  59.     # Clear all filters
  60.     Log::Log4perl::Filter::reset();
  61. }
  62.  
  63. ##################################################
  64. sub _new {
  65. ##################################################
  66.     my($class, $category, $level) = @_;
  67.  
  68.     print("_new: $class/$category/", defined $level ? $level : "undef",
  69.           "\n") if DEBUG;
  70.  
  71.     die "usage: __PACKAGE__->_new(category)" unless
  72.         defined $category;
  73.     
  74.     $category  =~ s/::/./g;
  75.  
  76.        # Have we created it previously?
  77.     if(exists $LOGGERS_BY_NAME->{$category}) {
  78.         print "_new: exists already\n" if DEBUG;
  79.         return $LOGGERS_BY_NAME->{$category};
  80.     }
  81.  
  82.     my $self  = {
  83.         category  => $category,
  84.         num_appenders => 0,
  85.         additivity    => 1,
  86.         level         => $level,
  87.         layout        => undef,
  88.                 };
  89.  
  90.    bless $self, $class;
  91.  
  92.    $level ||= $self->level();
  93.  
  94.         # Save it in global structure
  95.    $LOGGERS_BY_NAME->{$category} = $self;
  96.  
  97.    $self->set_output_methods;
  98.  
  99.    return $self;
  100. }
  101.  
  102. ##################################################
  103. sub reset_all_output_methods {
  104. ##################################################
  105.     print "reset_all_output_methods: \n" if DEBUG;
  106.  
  107.     foreach my $loggername ( keys %$LOGGERS_BY_NAME){
  108.         $LOGGERS_BY_NAME->{$loggername}->set_output_methods;
  109.     }
  110.     $ROOT_LOGGER->set_output_methods;
  111. }
  112.  
  113. ##################################################
  114. sub set_output_methods {
  115. # Here's a big performance increase.  Instead of having the logger
  116. # calculate whether to log and whom to log to every time log() is called,
  117. # we calculcate it once when the logger is created, and recalculate
  118. # it if the config information ever changes.
  119. #
  120. ##################################################
  121.    my ($self) = @_;
  122.     
  123.    my (@appenders, %seen);
  124.  
  125.    my ($level) = $self->level();
  126.  
  127.    print "set_output_methods: $self->{category}/$level\n" if DEBUG;
  128.  
  129.    #collect the appenders in effect for this category    
  130.  
  131.    for(my $logger = $self; $logger; $logger = parent_logger($logger)) {
  132.  
  133.         foreach my $appender_name (@{$logger->{appender_names}}){
  134.  
  135.                 #only one message per appender, (configurable)
  136.             next if $seen{$appender_name} ++ && 
  137.                     $Log::Log4perl::one_message_per_appender;
  138.  
  139.             push (@appenders,     
  140.                    [$appender_name,
  141.                     $APPENDER_BY_NAME{$appender_name},
  142.                    ]
  143.             );
  144.         }
  145.         last unless $logger->{additivity};
  146.     }
  147.  
  148.         #make a no-op coderef for inactive levels
  149.     my $noop = generate_noop_coderef();
  150.  
  151.        #make a coderef
  152.     my $coderef = (! @appenders ? $noop : &generate_coderef(\@appenders)); 
  153.  
  154.     my %priority = %Log::Log4perl::Level::PRIORITY; #convenience and cvs
  155.  
  156.    # changed to >= from <= as level ints were reversed
  157.     foreach my $levelname (keys %priority){
  158.         if (Log::Log4perl::Level::isGreaterOrEqual($level,
  159.                            $priority{$levelname}
  160.                            )) {
  161.             print "  ($priority{$levelname} <= $level)\n"
  162.                   if DEBUG;
  163.             $self->{$levelname} = $coderef;
  164.         }else{
  165.             print "  ($priority{$levelname} > $level)\n" if DEBUG;
  166.             $self->{$levelname} = $noop;
  167.         }
  168.  
  169.         print("  Setting [$self] $self->{category}.$levelname to ",
  170.               ($self->{$levelname} == $noop ? "NOOP" : 
  171.               ("Coderef [$coderef]: " . scalar @appenders . " appenders")), 
  172.               "\n") if DEBUG;
  173.     }
  174. }
  175.  
  176. ##################################################
  177. sub generate_coderef {
  178. ##################################################
  179.     my $appenders = shift;
  180.                     
  181.     print "generate_coderef: ", scalar @$appenders, 
  182.           " appenders\n" if DEBUG;
  183.  
  184.     my $coderef = '';
  185.     my $watch_delay_code = '';
  186.  
  187.     # Doing this with eval strings to sacrifice init/reload time
  188.     # for runtime efficiency, so the conditional won't be included
  189.     # if it's not needed
  190.  
  191.     if (defined $Log::Log4perl::Config::WATCHER) {
  192.         $watch_delay_code = generate_watch_code();
  193.     }
  194.  
  195.     my $code = <<EOL;
  196.     \$coderef = sub {
  197.       my (\$logger)  = shift;
  198.       my (\$level)   = pop;
  199.       my \$message;
  200.       my \$appenders_fired = 0;
  201.       
  202.       # Evaluate all parameters that need to evaluated. Two kinds:
  203.       #
  204.       # (1) It's a hash like { filter => "filtername",
  205.       #                        value  => "value" }
  206.       #     => filtername(value)
  207.       #
  208.       # (2) It's a code ref
  209.       #     => coderef()
  210.       #
  211.  
  212.       \$message   = [map { ref \$_ eq "HASH" && 
  213.                            exists \$_->{filter} && 
  214.                            ref \$_->{filter} eq 'CODE' ?
  215.                                \$_->{filter}->(\$_->{value}) :
  216.                            ref \$_ eq "CODE" ?
  217.                                \$_->() : \$_ 
  218.                           } \@_];                  
  219.       
  220.       print("coderef: \$logger->{category}\n") if DEBUG;
  221.  
  222.       $watch_delay_code;  #note interpolation here
  223.       
  224.       foreach my \$a (\@\$appenders) {   #note the closure here
  225.           my (\$appender_name, \$appender) = \@\$a;
  226.  
  227.           print("  Sending message '<\$message>' (\$level) " .
  228.                 "to \$appender_name\n") if DEBUG;
  229.                 
  230.           \$appender->log(
  231.               #these get passed through to Log::Dispatch
  232.               { name    => \$appender_name,
  233.                 level   => \$Log: Logger.pm,v $
  234.                 level   => \Revision 1.2  2003/09/16 18:16:42  joker
  235.                 level   => \Neuer NSIS-Entwicklungsbranch (gueltig ab Version 2.04beta)
  236.                 level   => \level},   
  237.                 message => \$message,
  238.               },
  239.               #these we need
  240.               \$logger->{category},
  241.               \$level,
  242.           ) and \$appenders_fired++;
  243.               # Only counting it if it returns a true value. Otherwise
  244.               # the appender threshold might have suppressed it after all.
  245.     
  246.       } #end foreach appenders
  247.     
  248.       return \$appenders_fired;
  249.  
  250.     }; #end coderef
  251.  
  252. EOL
  253.  
  254.     eval $code or die "$@";
  255.  
  256.     return $coderef;
  257. }
  258.  
  259. ##################################################
  260. sub generate_noop_coderef {
  261. ##################################################
  262.     my $coderef = '';
  263.     my $watch_delay_code = '';
  264.  
  265.     if (defined $Log::Log4perl::Config::WATCHER) {
  266.         $watch_delay_code = generate_watch_code();
  267.         $watch_delay_code = <<EOL;
  268.         my (\$logger)  = shift;
  269.         my (\$level)   = pop;
  270.         $watch_delay_code
  271. EOL
  272.     }
  273.  
  274.     my $code = <<EOL;
  275.     \$coderef = sub {
  276.         print("noop: \n") if DEBUG;
  277.         $watch_delay_code
  278.         return undef;
  279.      };
  280. EOL
  281.  
  282.     eval $code or die "$@";
  283.  
  284.     return $coderef;
  285. }
  286.  
  287.  
  288. ##################################################
  289. sub generate_watch_code {
  290. ##################################################
  291.     print "generate_watch_code:\n" if DEBUG;
  292.  
  293.     return <<'EOL';
  294.         print "exe_watch_code:\n" if DEBUG;
  295.                        
  296.         # more closures here
  297.         if(time() > $Log::Log4perl::Config::Watch::NEXT_CHECK_TIME) {
  298.             Log::Log4perl->init_and_watch();
  299.                        
  300.             my $methodname = lc($level);
  301.             $logger->$methodname(@_); # send the message
  302.                                       # to the new configuration
  303.             return;        #and return, we're done with this incarnation
  304.         }
  305. EOL
  306. }
  307.  
  308. ##################################################
  309. sub parent_string {
  310. ##################################################
  311.     my($string) = @_;
  312.  
  313.     if($string eq "") {
  314.         return undef; # root doesn't have a parent.
  315.     }
  316.  
  317.     my @components = split /\./, $string;
  318.     
  319.     if(@components == 1) {
  320.         return "";
  321.     }
  322.  
  323.     pop @components;
  324.  
  325.     return join('.', @components);
  326. }
  327.  
  328. ##################################################
  329. sub level {
  330. ##################################################
  331.     my($self, $level, $dont_reset_all) = @_;
  332.  
  333.         # 'Set' function
  334.     if(defined $level) {
  335.         croak "invalid level '$level'" 
  336.                 unless Log::Log4perl::Level::is_valid($level);
  337.         $self->{level} = $level;   
  338.  
  339.         &reset_all_output_methods
  340.             unless $dont_reset_all;  #keep us from getting overworked 
  341.                                      #if it's the config file calling us 
  342.  
  343.         return $level;
  344.     }
  345.  
  346.         # 'Get' function
  347.     if(defined $self->{level}) {
  348.         return $self->{level};
  349.     }
  350.  
  351.     for(my $logger = $self; $logger; $logger = parent_logger($logger)) {
  352.  
  353.         # Does the current logger have the level defined?
  354.  
  355.         if($logger->{category} eq "") {
  356.             # It's the root logger
  357.             return $ROOT_LOGGER->{level};
  358.         }
  359.             
  360.         if(defined $LOGGERS_BY_NAME->{$logger->{category}}->{level}) {
  361.             return $LOGGERS_BY_NAME->{$logger->{category}}->{level};
  362.         }
  363.     }
  364.  
  365.     # We should never get here because at least the root logger should
  366.     # have a level defined
  367.     die "We should never get here.";
  368. }
  369.  
  370. ##################################################
  371. sub parent_logger {
  372. # Get the parent of the current logger or undef
  373. ##################################################
  374.     my($logger) = @_;
  375.  
  376.         # Is it the root logger?
  377.     if($logger->{category} eq "") {
  378.         # Root has no parent
  379.         return undef;
  380.     }
  381.  
  382.         # Go to the next defined (!) parent
  383.     my $parent_class = parent_string($logger->{category});
  384.  
  385.     while($parent_class ne "" and
  386.           ! exists $LOGGERS_BY_NAME->{$parent_class}) {
  387.         $parent_class = parent_string($parent_class);
  388.         $logger =  $LOGGERS_BY_NAME->{$parent_class};
  389.     }
  390.  
  391.     if($parent_class eq "") {
  392.         $logger = $ROOT_LOGGER;
  393.     } else {
  394.         $logger = $LOGGERS_BY_NAME->{$parent_class};
  395.     }
  396.  
  397.     return $logger;
  398. }
  399.  
  400. ##################################################
  401. sub get_root_logger {
  402. ##################################################
  403.     my($class) = @_;
  404.     return $ROOT_LOGGER;    
  405. }
  406.  
  407. ##################################################
  408. sub additivity {
  409. ##################################################
  410.     my($self, $onoff) = @_;
  411.  
  412.     if(defined $onoff) {
  413.         $self->{additivity} = $onoff;
  414.     }
  415.  
  416.     return $self->{additivity};
  417. }
  418.  
  419. ##################################################
  420. sub get_logger {
  421. ##################################################
  422.     my($class, $category) = @_;
  423.  
  424.     unless(defined $ROOT_LOGGER) {
  425.         die "Internal error: Root Logger not initialized.";
  426.     }
  427.  
  428.     return $ROOT_LOGGER if $category eq "";
  429.  
  430.     my $logger = $class->_new($category);
  431.     return $logger;
  432. }
  433.  
  434. ##################################################
  435. sub add_appender {
  436. ##################################################
  437.     my($self, $appender, $dont_reset_all) = @_;
  438.  
  439.     my $not_to_dispatcher = 0;
  440.  
  441.         # We take this as an indicator that we're initialized.
  442.     $INITIALIZED = 1;
  443.  
  444.     my $appender_name = $appender->name();
  445.  
  446.     $self->{num_appenders}++;  #should this be inside the unless?
  447.  
  448.     unless (grep{$_ eq $appender_name} @{$self->{appender_names}}){
  449.         $self->{appender_names} = [sort @{$self->{appender_names}}, 
  450.                                         $appender_name];
  451.     }
  452.  
  453.     if ($APPENDER_BY_NAME{$appender_name}) {
  454.         $not_to_dispatcher = 1;
  455.     }else{
  456.         $APPENDER_BY_NAME{$appender_name} = $appender;
  457.     }
  458.  
  459.     &reset_all_output_methods
  460.                 unless $dont_reset_all;  # keep us from getting overworked
  461.                                          # if it's  the config file calling us
  462.  
  463.  
  464.     #$self->{dispatcher}->add($appender) unless $not_to_dispatcher;    
  465.     $DISPATCHER->add($appender) unless $not_to_dispatcher;    
  466.         # while we want to track the names of
  467.         # all the appenders in a category, we only
  468.         # want to add it to log_dispatch *once*
  469. }
  470.  
  471. ##################################################
  472. sub has_appenders {
  473. ##################################################
  474.     my($self) = @_;
  475.  
  476.     return $self->{num_appenders};
  477. }
  478.  
  479. ##################################################
  480. sub log {
  481. # external api
  482. ##################################################
  483.     my ($self, $priority, @messages) = @_;
  484.  
  485.     confess("log: No priority given!") unless defined($priority);
  486.  
  487.        # Just in case of 'init_and_watch' -- see Changes 0.21
  488.     $_[0] = $LOGGERS_BY_NAME->{$_[0]->{category}} if 
  489.         defined $Log::Log4perl::Config::WATCHER;
  490.  
  491.     init_warn() unless $INITIALIZED;
  492.  
  493.     croak "priority $priority isn't numeric" if ($priority =~ /\D/);
  494.  
  495.     my $which = Log::Log4perl::Level::to_level($priority);
  496.  
  497.     $self->{$which}->($self, @messages, 
  498.                     Log::Log4perl::Level::to_level($priority));
  499. }
  500.  
  501. ######################################################################
  502. #
  503. # create_custom_level 
  504. # creates a custom level
  505. # in theory, could be used to create the default ones
  506.  
  507. sub create_custom_level {
  508.   my $level = shift || die("create_custom_level: forgot to pass in a level string!");
  509.   my $after = shift || die("create_custom_level: forgot to pass in a level after which to place the new level!");
  510.   my $syslog_equiv = shift; # can be undef
  511.  
  512.   ## only let users create custom levels before initialization
  513.  
  514.   die("create_custom_level must be called before init or first get_logger() call") if ($INITIALIZED);
  515.  
  516.   my %PRIORITY = %Log::Log4perl::Level::PRIORITY; #convenience
  517.  
  518.   die("create_custom_level: no such level \"$after\"! Use one of: ", join(", ", sort keys %PRIORITY))
  519.     unless $PRIORITY{$after};
  520.  
  521.   # figure out new int value by AFTER + (AFTER+ 1) / 2
  522.  
  523.   my $next_prio = Log::Log4perl::Level::get_lower_level($PRIORITY{$after}, 1);
  524.   my $cust_prio = int(($PRIORITY{$after} + $next_prio) / 2);
  525.  
  526. #   CORE::warn("Creating prio $cust_prio between $PRIORITY{$after} and $next_prio");
  527.  
  528.   die(qq{create_custom_level: Calculated level of $cust_prio already exists!
  529.       This should only happen if you've made some insane number of custom
  530.       levels (like 15 one after another)
  531.       You can usually fix this by re-arranging your code from:
  532.       create_custom_level("cust1", X);
  533.       create_custom_level("cust2", X);
  534.       create_custom_level("cust3", X);
  535.       create_custom_level("cust4", X);
  536.       create_custom_level("cust5", X);
  537.       into:
  538.       create_custom_level("cust3", X);
  539.       create_custom_level("cust5", X);
  540.       create_custom_level("cust4", 4);
  541.       create_custom_level("cust2", cust3);
  542.       create_custom_level("cust1", cust2);
  543.    }) if (${Log::Log4perl::Level::LEVELS{$cust_prio}});
  544.  
  545.   Log::Log4perl::Level::add_priority($level, $cust_prio, $syslog_equiv);
  546.  
  547.   print("Adding prio $level at $cust_prio\n") if DEBUG;
  548.  
  549.   # get $LEVEL into namespace of Log::Log4perl::Logger to 
  550.   # create $logger->foo nd $logger->is_foo
  551.   my $name = "Log::Log4perl::Logger::";
  552.   my $key = $level;
  553.  
  554.   no strict qw(refs);
  555.   # be sure to use ${Log...} as CVS adds log entries for Log
  556.   *{"$name$key"} = \${Log::Log4perl::Level::PRIORITY{$level}};
  557.  
  558.   # now, stick it in the caller's namespace
  559.   $name = caller(0) . "::";
  560.   *{"$name$key"} = \${Log::Log4perl::Level::PRIORITY{$level}};
  561.   use strict qw(refs);
  562.  
  563.   create_log_level_methods($level);
  564.  
  565.   return 0;
  566.  
  567. }
  568.  
  569. ########################################
  570. #
  571. # if we were hackin' lisp (or scheme), we'd be returning some lambda
  572. # expressions. But we aren't. :) So we'll just create some strings and
  573. # eval them.
  574. sub create_log_level_methods {
  575.   my $level = shift || die("create_log_level_methods: forgot to pass in a level string!");
  576.   my $lclevel = lc($level);
  577.   my $levelint = uc($level) . "_INT";
  578.  
  579.   no strict qw(refs);
  580.  
  581.   # This is a bit better way to create code on the fly than eval'ing strings.
  582.   # -erik
  583.  
  584.   *{__PACKAGE__ . "::$lclevel"} = sub {
  585.         print "$lclevel: ($_[0]->{category}/$_[0]->{level}) [@_]\n" if DEBUG;
  586.         init_warn() unless $INITIALIZED;
  587.         $_[0]->{$level}->(@_, $level);
  588.      };
  589.  
  590.   *{__PACKAGE__ . "::is_$lclevel"} = sub { 
  591.     return Log::Log4perl::Level::isGreaterOrEqual($_[0]->level(),
  592.                           $$level
  593.                           ); 
  594.   };
  595.   
  596.   use strict qw(refs);
  597.  
  598.   return 0;
  599.  
  600. }
  601.  
  602. #now lets autogenerate the logger subs based on the defined priorities
  603. foreach my $level (keys %Log::Log4perl::Level::PRIORITY){
  604.   create_log_level_methods($level);
  605. }
  606.  
  607. ##################################################
  608. #expected args are $logger, $msg, $levelname
  609.  
  610. #sub fatal {
  611. #   print "fatal: ($_[0]->{category}/$_[0]->{level}) [@_]\n" if DEBUG;
  612. #   init_warn() unless $INITIALIZED;
  613. #   $_[0]->{FATAL}(@_, 'FATAL');
  614. #}
  615. #
  616. #sub error {
  617. #   print "error: ($_[0]->{category}/$_[0]->{level}) [@_]\n" if DEBUG;
  618. #   init_warn() unless $INITIALIZED;
  619. #   $_[0]->{ERROR}(@_, 'ERROR');
  620. #}
  621. #
  622. #sub warn {
  623. #   print "warn: ($_[0]->{category}/$_[0]->{level}) [@_]\n" if DEBUG;
  624. #   init_warn() unless $INITIALIZED;
  625. #   $_[0]->{WARN} (@_, 'WARN' );
  626. #}
  627. #
  628. #sub info {
  629. #   print "info: ($_[0]->{category}/$_[0]->{level}) [@_]\n" if DEBUG;
  630. #   init_warn() unless $INITIALIZED;
  631. #   $_[0]->{INFO} (@_, 'INFO' );
  632. #}
  633. #
  634. #sub debug {
  635. #   print "debug: ($_[0]->{category}/$_[0]->{level}) [@_]\n" if DEBUG;
  636. #   init_warn() unless $INITIALIZED;
  637. #   $_[0]->{DEBUG}(@_, 'DEBUG');
  638. #}
  639.  
  640. #sub is_debug { return $_[0]->level() >= $DEBUG; }
  641. #sub is_info  { return $_[0]->level() >= $INFO; }
  642. #sub is_warn  { return $_[0]->level() >= $WARN; }
  643. #sub is_error { return $_[0]->level() >= $ERROR; }
  644. #sub is_fatal { return $_[0]->level() >= $FATAL; }
  645. sub init_warn {
  646.     CORE::warn "Log4perl: Seems like no initialization happened. Forgot to call init()?\n";
  647.     # Only tell this once;
  648.     $INITIALIZED = 1;
  649.               }
  650.  
  651. ##################################################
  652. # call me from a sub-func to spew the sub-func's caller
  653. sub callerline {
  654.   # the below could all be just:
  655.   # my ($pack, $file, $line) = caller(2);
  656.   # but if we every bury this further, it'll break. So we do this
  657.   # little trick stolen and paraphrased from Carp/Heavy.pm
  658.  
  659.   my $i = 0;
  660.   my (undef, $localfile, undef) = caller($i++);
  661.   my ($pack, $file, $line);
  662.   do {
  663.     ($pack, $file, $line) = caller($i++);
  664.   } while ($file && $file eq $localfile);
  665.  
  666.   # now, create the return message
  667.   my $mess = " at $file line $line";
  668.   # Someday, we'll use Threads. Really.
  669.   if (defined &Thread::tid) {
  670.     my $tid = Thread->self->tid;
  671.     $mess .= " thread $tid" if $tid;
  672.   }
  673.   return (@_, $mess, "\n");
  674. }
  675.  
  676. sub and_warn {
  677.   my $self = shift;
  678.   my $msg = join("", @_[0 .. $#_]);
  679.   chomp $msg;
  680.   CORE::warn(callerline($msg));
  681. }
  682.  
  683. sub and_die {
  684.   my $self = shift;
  685.   my $msg = join("", @_[0 .. $#_]);
  686.   chomp $msg;
  687.   die(callerline($msg));
  688. }
  689.  
  690. ##################################################
  691.  
  692. sub logwarn {
  693.   my $self = shift;
  694.   if ($self->is_warn()) {
  695.         # Since we're one caller level off now, compensate for that.
  696.     $Log::Log4perl::caller_depth++;
  697.     $self->warn(@_);
  698.     $Log::Log4perl::caller_depth--;
  699.     $self->and_warn(@_);
  700.   }
  701. }
  702.  
  703. sub logdie {
  704.   my $self = shift;
  705.   if ($self->is_fatal()) {
  706.         # Since we're one caller level off now, compensate for that.
  707.     $Log::Log4perl::caller_depth++;
  708.     $self->fatal(@_);
  709.     $Log::Log4perl::caller_depth--;
  710.   }
  711.   # no matter what, we die... 'cuz logdie wants you to die.
  712.   $self->and_die(@_);
  713. }
  714.  
  715. ##################################################
  716.  
  717. # for die and warn, carp long/shortmess return line #s and the like
  718. sub noop {
  719.   return @_;
  720. }
  721.  
  722. ##################################################
  723.  
  724. # clucks and carps are WARN level
  725. sub logcluck {
  726.   my $self = shift;
  727.   if ($self->is_warn()) {
  728.     my $message = Carp::longmess(@_);
  729.     foreach (split(/\n/, $message)) {
  730.       $self->warn("$_\n");
  731.     }
  732.     CORE::warn(noop($message));
  733.   }
  734. }
  735.  
  736. sub logcarp {
  737.   my $self = shift;
  738.   if ($self->is_warn()) {
  739.     my $message = Carp::shortmess(@_);
  740.     foreach (split(/\n/, $message)) {
  741.       $self->warn("$_\n");
  742.     }
  743.     CORE::warn(noop($message));
  744.   }
  745. } 
  746.  
  747. # croaks and confess are FATAL level
  748. sub logcroak {
  749.   my $self = shift;
  750.   my $message = Carp::shortmess(@_);
  751.   if ($self->is_fatal()) {
  752.     foreach (split(/\n/, $message)) {
  753.       $self->fatal("$_\n");
  754.     }
  755.   }
  756.   # again, we die no matter what
  757.   die(noop($message));
  758. }
  759.  
  760. sub logconfess {
  761.   my $self = shift;
  762.   my $message = Carp::longmess(@_);
  763.   if ($self->is_fatal()) {
  764.     foreach (split(/\n/, $message)) {
  765.       $self->fatal("$_\n");
  766.     }
  767.   }
  768.   # again, we die no matter what
  769.   die(noop($message));
  770. }
  771.  
  772. ##################################################
  773. # 
  774. # in case people prefer to use error for warning
  775.  
  776. sub error_warn {
  777.   my $self = shift;
  778.   if ($self->is_error()) {
  779.     $self->error(@_);
  780.     $self->and_warn(@_);
  781.   }
  782. }
  783.  
  784. sub error_die {
  785.   my $self = shift;
  786.   if ($self->is_error()) {
  787.     $self->error(@_);
  788.   }
  789.   $self->and_die(@_);
  790. }
  791.  
  792. sub more_logging {
  793.   my ($self) = shift;
  794.   return $self->dec_level(@_);
  795. }
  796.  
  797. sub inc_level {
  798.     my ($self, $delta) = @_;
  799.  
  800.     $delta ||= 1;
  801.  
  802.     $self->level(Log::Log4perl::Level::get_higher_level($self->level(), $delta));
  803.  
  804.     $self->set_output_methods;
  805.  
  806. }
  807.  
  808. sub less_logging {
  809.   my ($self) = shift;
  810.   return $self->inc_level(@_);
  811. }
  812.  
  813. sub dec_level {
  814.     my ($self, $delta) = @_;
  815.  
  816.     $delta ||= 1;
  817.  
  818.     $self->level(Log::Log4perl::Level::get_lower_level($self->level(), $delta));
  819.  
  820.     $self->set_output_methods;
  821. }
  822.  
  823. ##################################################
  824.  
  825. 1;
  826.  
  827. __END__
  828.  
  829. =head1 NAME
  830.  
  831. Log::Log4perl::Logger - Main Logger Class
  832.  
  833. =head1 SYNOPSIS
  834.  
  835.     # It's not here
  836.  
  837. =head1 DESCRIPTION
  838.  
  839. While everything that makes Log4perl tick is implemented here,
  840. please refer to L<Log::Log4perl> for documentation.
  841.  
  842. =head1 SEE ALSO
  843.  
  844. =head1 AUTHOR
  845.  
  846.     Mike Schilli, <log4perl@perlmeister.com>
  847.     Kevin Goess, <cpan@goess.org>
  848.  
  849. =cut
  850.