cpan/Class/Logger.pm

## ------------------------------------------------------------------------
##  $Id: Logger.pm,v 1.2 2003/12/16 19:27:32 ts-dev Exp $
## ------------------------------------------------------------------------
##  $Log: Logger.pm,v $
##  Revision 1.2  2003/12/16 19:27:32  ts-dev
##  first check-in
##
##
## ------------------------------------------------------------------------


=pod

  This is weird! Forget it.
  But we depend on it!
  Hmmm....


=cut


package Class::Logger;

use strict;
use warnings;

use Data::Dumper;
use Log::Dispatch;
use Log::Dispatch::Screen;
use Log::Dispatch::Config;
use Cwd;
use DesignPattern::Object;
use base qw/Exporter/;
use vars qw(
  $LEVEL_DEFAULT
  $ENABLE_NAMESPACE
  $NAMESPACE_LEVEL
  $ENABLE_METHODS
  $METHOD_LEVELS
  $TRACE_STACK_LEVELS
        $logger @EXPORT
);

# default behaviour
$LEVEL_DEFAULT = 'debug';
$ENABLE_NAMESPACE = 1;
$NAMESPACE_LEVEL = undef;
$ENABLE_METHODS = 0;
$METHOD_LEVELS = [3];
$TRACE_STACK_LEVELS = [];
$logger = Class::Logger->new();
@EXPORT = qw($logger);


# TODO: review, revise and rewire this!
#my $logger = Log::Dispatch::Config->instance;

sub __init {
  my $self = shift;
  my $action = shift;
  my $message = shift;
  #my $options = shift;   # ??? or: $self->{__logger}->{options} already...?

  # configure
  if (!$self->{__logger}->{configured}) {
    $self->{__logger}->{configured} = 1;
    $self->_configure_LogDispatch();
  }
  
  # set passed-in arguments
  $self->{__logger}->{action} = $action;
  $self->{__logger}->{message} = $message;

  # trace
    #my $tmp = caller(2);
    #print Dumper($tmp);
    #exit;
  

  # handle caller

    # determine class- and subroutinename of context calling us
    # this task can be controlled by tuning its behaviour
    # this can be changed by setting
    #   Class::Logger::...
    #   ...
    #   ...
    my $calling_class;
    my $calling_sub;


    # Default behaviour is:
    #   Use classname from $self and suppress subroutine name.
    #   In case of using this together with DesignPattern::Bridge,
    #   the classnames of child objects are suppressed.
    #   Instead, the classname of the parent container object
    #   gets used *always*.
      $calling_class = '';
      $calling_sub = '';

      # Log class names (en-/disabled, take from specified level)
      if ($ENABLE_NAMESPACE) {
        $calling_class = ref $self;
        if ($NAMESPACE_LEVEL) {
          my @entry = caller($NAMESPACE_LEVEL);
          $calling_class = $entry[0];
        }
      }

      # Log method names (en-/disabled, multi-level)
      if ($ENABLE_METHODS) {
        my @methods;
        foreach (@{$METHOD_LEVELS}) {
          (my $c_package, my $c_filename, my $c_line, my $c_subroutine, my $c_hasargs,
          my $c_wantarray, my $c_evaltext, my $c_is_require, my $c_hints, my $c_bitmask) = caller($_);
          $c_subroutine ||= '';
          $c_subroutine =~ s/.*:://;
          push @methods, $c_subroutine;
        }
        $calling_sub = join(': ', @methods) if @methods;
      }
  
    
  # set default arguments
  $self->{__logger}->{classname} = $calling_class;
  $self->{__logger}->{functionname} = $calling_sub;
  # FIXME: deprecate this!
  $self->{__logger}->{caller} = caller;
  
  # set default values
  $self->{__logger}->{action} ||= '';
  $self->{__logger}->{options}->{tag} ||= '';
  
  # FIXME: deprecate this!
  #$self->{__logger}->{level} ||= 'info';
  #$self->{__logger}->{level} ||= 'debug';
  $self->{__logger}->{level} ||= $LEVEL_DEFAULT;

  # handle stacktrace
    foreach (@$TRACE_STACK_LEVELS) {
      #print "trace-level: ", $_, "\n";
      #(my $c_package, my $c_filename, my $c_line, my $c_subroutine, my $c_hasargs,
      #my $c_wantarray, my $c_evaltext, my $c_is_require, my $c_hints, my $c_bitmask) = caller($_);
      my @entry = caller($_);
      push @{$self->{__logger}->{trace}->{stack}}, \@entry;
    }
  
}

sub __out {
  my $self = shift;
  my $message = shift;
  
  # if message given here, append to message stored inside object
  $self->{__logger}->{message} .= ' - ' . $message if $message;
  
  # TODO: refactor this:
  #  - push '$self->__get_prefix()' to additional log-entry-metadata, don't show it on/in any console/logfile output
  #$logger->log( level => $self->{__logger}->{level}, message => $self->__get_prefix_long() . $message );
  #$logger->log( level => $self->{__logger}->{level}, message => $message );
  #$logger->warning( __PACKAGE__ . "->_skip: '$caller' (mixed into '$classname'): ($options->{tag}) $message.");
  #$self->{__logger}->{instance}->log( level => $self->{__logger}->{level}, message => $self->__get_prefix_short() . $self->{__logger}->{message} );
  #$self->{__logger}->{instance}->log( level => $self->{__logger}->{level}, message => $self->__get_prefix_module() . $self->{__logger}->{message} );
  $self->{__logger}->{instance}->log( level => $self->{__logger}->{level}, message => $self->__get_prefix_best() . $self->{__logger}->{message} );
}


sub __handle_options {
  my $self = shift;
  #my $options = shift;   # ??? or: $self->{__logger}->{options} already...?
}

sub __get_prefix_long {
  my $self = shift;
  return __PACKAGE__ . "->$self->{__logger}->{action}: '$self->{__logger}->{caller}' (mixed into '$self->{__logger}->{classname}'): ($self->{__logger}->{options}->{tag}) - ";
}

sub __get_prefix_short {
  my $self = shift;
  my $tag_append = '';
  $tag_append = "$self->{__logger}->{options}->{tag} - " if $self->{__logger}->{options}->{tag};
  return $self->{__logger}->{classname} . "->$self->{__logger}->{action}: $tag_append";
}

sub __get_prefix_module {
  my $self = shift;
  my $tag_append = '';
  $tag_append = "$self->{__logger}->{options}->{tag} - " if $self->{__logger}->{options}->{tag};
  return $self->{__logger}->{classname} . ": $tag_append";
}


sub __get_prefix_best {
  my $self = shift;
  my $namespace = $self->{__logger}->{classname};
  my $method = '';
  my $tag_append = '';
  #$namespace = $namespace . ": " if $namespace;
  $method = "->" . $self->{__logger}->{functionname} if $self->{__logger}->{functionname};
  #$method .= ': ' if $method;
  $tag_append = "$self->{__logger}->{options}->{tag} - " if $self->{__logger}->{options}->{tag};
  
  my @line;
  push @line, $namespace if $namespace;
  push @line, $method if $method;
  push @line, $tag_append if $tag_append;
  
  #print Dumper(@line);
  
  #return join(': ', @line);
  my $result = join('', @line);
  $result .= ': ' if $result;
  
  return $result;
  
}


sub log_ {
  my $self = shift;
  my $message = shift;
  
  # automagically instantiate the object if not there
  # TODO: do this by creating a dummy object inheriting from Class::Logger,
  # for now this just don't work because which dummy one to take: Data::Code::Null?
  #if (! ref $self) {
  #  $self = DesignPattern::Object->fromPackage('Class::Logger');
  #}
  
  $self->{__logger}->{level} = shift;    # TODO: implement propagation of this into Log::Dispatch-object '$logger'!
  $self->{__logger}->{options} = shift;   # TODO: implement additional behaviours: e.g. { exit => 1 } would exit after tracedump
  
        $self->{__logger}->{level} ||= $LEVEL_DEFAULT;
  $self->_configure_LogDispatch();
        local ${Log::Dispatch::Config::CallerDepth} = 3;
  $self->{__logger}->{instance}->log( level => $self->{__logger}->{level}, message => $message );
        #$self->__init('log', $message);
        #$self->__out();
  
}

sub skip {
  my $self = shift;
  my $message = shift;
  my $condition = shift;
  $self->{__logger}->{level} = shift;    # TODO: implement propagation of this into Log::Dispatch-object '$logger'!
  $self->{__logger}->{options} = shift;   # TODO: implement additional behaviours: e.g. { exit => 1 } would exit after tracedump

  my $classname = ref $self;
  my $caller = caller;

  $self->{__logger}->{options}->{tag} ||= '';

  if ($condition) {
    # V1:
    #$logger->warning( __PACKAGE__ . "->_skip: '$caller' (mixed into '$classname'): ($options->{tag}) $message.");
    # V2:
    $self->__init('skip', $message);
    $self->__out();
    return 1;
  }
}

sub trace_ {
  my $self = shift;
  my $message = shift;
  my $data = shift;
  my $condition = shift;
  $self->{__logger}->{level} = shift;    # TODO: implement propagation of this into Log::Dispatch-object '$logger'!
  $self->{__logger}->{options} = shift;   # TODO: implement additional behaviours: e.g. { exit => 1 } would exit after tracedump
  
  my $classname = ref $self;
  my $caller = caller;

  $self->{__logger}->{options}->{tag} ||= '';

  # don't do _any_ tracing if disabled
  return if $self->{TRACE_DISABLED};
  
  # overwrite condition with local configured want-TRACE
  $condition ||= $self->{TRACE};
  
  # dump data
    my $result = 0;
    if ($condition) {
      $message .= " - " . Dumper($data);
      
      # V1:
      # $self->__init('trace');
      # $logger->info( __PACKAGE__ . "->trace: '$caller' (mixed into '$classname'): ($options->{tag}) $message.");
      
      # V2:
                        #local ${Log::Dispatch::Config::CallerDepth} = 3;
        #$self->{__logger}->{instance}->log( level => $self->{__logger}->{level}, message => $message );
            $self->__init('trace', $message);
            $self->__out();
      
      $result = 1;
    } else {
      $result = 0;
    }

  # handle additional options
  if ($self->{TRACE_OPTIONS}) {
    exit if $self->{__logger}->{options}->{exit};
  }

  return $result;
}


sub _configure_LogDispatch {
  my $self = shift;

  my $configurator = DesignPattern::Object->fromPackage('Log::Dispatch::Configurator::Hardwired');
  
  # check if running inside a 'PROJECT' space
  my $basepath = cwd();
  my $postpone = '/..';
  if (-d $basepath . $postpone . '/PROJECT') {
    $basepath .= $postpone;
    $basepath .= "/var/log";
  }
  
  # configure custom logHandler
  
    if ($configurator) {
  
      $configurator->{file_filename} = "$basepath/perl_app.log";
      $configurator->{screen_min_level} = 'info';
      
      if ($self->{quiet}) {
        $configurator->{screen_min_level} = 8;
      }
  
      if ($self->{debug}) {
        $configurator->{screen_min_level} = 'debug';
      }
      
      if ($self->{LOG_VERBOSE}) {
        $configurator->{verbose} = 1;
      }

      Log::Dispatch::Config->configure($configurator);
      $self->{__logger}->{instance} = Log::Dispatch::Config->instance;

    } else {

      #Log::Dispatch::Config->configure();
      #Log::Dispatch->configure();
      #$self->{__logger}->{instance} = Log::Dispatch->new;
      $self->{__logger}->{instance} = Log::Dispatch::Screen->new( name => 'screen', 'min_level' => 'debug', stderr => 1 );
    
    }


}

sub configure_logger {
  my $self = shift;

  # automagically instantiate the object if not there
  # TODO: do this by creating a dummy object inheriting from Class::Logger,
  # for now this just don't work because which dummy one to take: Data::Code::Null?
  if (! ref $self) {
    $self = DesignPattern::Object->fromPackage('Class::Logger');
  }

  #print "logconfig\n";
  $self->_configure_LogDispatch();
}


# for standalone use
sub new { my $class = shift; my $self = {}; bless $self, $class; }

# convenient shortcuts
# FIXME: create these automagically by mungling with symbolic references
# or: make this object tied to recieve kinda events on method calls

BEGIN {
        no strict 'refs';
        foreach my $l ( qw(debug info notice warning err error
                crit critical alert emerg emergency) ) {
                *{$l} = sub {
                        my $self = shift;
                        local ${Log::Dispatch::Config::CallerDepth} =
                                ${Log::Dispatch::Config::CallerDepth} + 1;
                        $self->log( "@_", $l );
                };
        }
}


sub log {
        my $self = shift;
        my ($message, $level) = @_;
        $level ||= 'debug';
        my $logger = $self->_get_instance();
        local ${Log::Dispatch::Config::CallerDepth} = ${Log::Dispatch::Config::CallerDepth} + 1;
        $logger->log( level => $level, message => $message );
}

sub dump {
        my $self = shift;
        my $data = shift;
        local $Data::Dumper::Indent = 1;
        local $Data::Dumper::Sortkeys = 1;
        my $dump = Dumper $data;
        local ${Log::Dispatch::Config::CallerDepth} = ${Log::Dispatch::Config::CallerDepth} + 1;
        $self->log("DUMP: \n$dump", 'debug');
}
sub strace {
        my $self = shift;
        my $levels = shift || 5;
        $levels = 1 if $levels < 1;
        my $message = "\nSTACK-TRACE:\n";
        for (1..$levels) {
                my ($package, $filename, $line, $subroutine) = (caller $_)[0..3];
                last unless defined $package;
                #$message .= qq#  ${subroutine} ($filename line $line)\n#;
                $message .= qq#  ${subroutine} (line $line)\n#;
        }
        local ${Log::Dispatch::Config::CallerDepth} = ${Log::Dispatch::Config::CallerDepth} + 1;
        $self->log($message, 'debug');
}

{
        my $logger;
        my $object;
        sub _create {
                        $object = __PACKAGE__->new();
                        $object->_get_instance(@_);
                        $main::logger = $object;
                        return $object;
        }
        sub _get_instance {
                my $self = shift;
                return $logger if defined $logger;
                my $configurator = $self->_get_configurator();
                if ($configurator) {
                        #warn Dumper $configurator;
                        Log::Dispatch::Config->configure($configurator);
                        $logger = Log::Dispatch::Config->instance;
                }
                else {
                        $logger = Log::Dispatch::Screen->new(
                                 name => 'screen',
                                 'min_level' => 'debug',
                                 stderr => 1
                         );
                }
        }
        sub _get_configurator {
                my $self = shift;
                my $configurator = DesignPattern::Object->fromPackage('Log::Dispatch::Configurator::Hardwired');
                # check if running inside a 'PROJECT' space
                my $basepath = cwd();
                my $postpone = '/..';
                if (-d $basepath . $postpone . '/PROJECT') {
                        $basepath .= $postpone;
                        $basepath .= "/var/log";
                }
                if ($self->{quiet}) {
                        $configurator->{screen_min_level} = 8;
                }
                if ($self->{debug}) {
                        $configurator->{screen_min_level} = 'debug';
                }
                if ($self->{LOG_VERBOSE}) {
                        $configurator->{verbose} = 1;
                }
                $configurator->{file_filename} = "$basepath/perl_app.log";
                $configurator->{screen_min_level} = 'info';
                return $configurator;
        }
}


=pod

=head1 TODO
  
  o $TRACE_STACK_LEVELS   (traces stack history)
  o $ENABLE_DEBUG   (en-/disables level 'debug')
  o $ENABLE_LOG   (en-/disables logging completely)


=cut


1;
__END__
1	ts-dev	1.1	## ------------------------------------------------------------------------
2	ts-dev	1.3	## $Id: Logger.pm,v 1.2 2003/12/16 19:27:32 ts-dev Exp $
3	ts-dev	1.1	## ------------------------------------------------------------------------
4			## $Log: Logger.pm,v $
5	ts-dev	1.3	## Revision 1.2 2003/12/16 19:27:32 ts-dev
6			## first check-in
7			##
8	ts-dev	1.1	##
9			## ------------------------------------------------------------------------
10
11
12			=pod
13
14			This is weird! Forget it.
15			But we depend on it!
16			Hmmm....
17
18
19			=cut
20
21
22			package Class::Logger;
23
24			use strict;
25			use warnings;
26
27			use Data::Dumper;
28			use Log::Dispatch;
29			use Log::Dispatch::Screen;
30			use Log::Dispatch::Config;
31			use Cwd;
32			use DesignPattern::Object;
33			use base qw/Exporter/;
34			use vars qw(
35			$LEVEL_DEFAULT
36			$ENABLE_NAMESPACE
37			$NAMESPACE_LEVEL
38			$ENABLE_METHODS
39			$METHOD_LEVELS
40			$TRACE_STACK_LEVELS
41	ts-dev	1.3	$logger @EXPORT
42	ts-dev	1.1	);
43
44			# default behaviour
45			$LEVEL_DEFAULT = 'debug';
46			$ENABLE_NAMESPACE = 1;
47			$NAMESPACE_LEVEL = undef;
48			$ENABLE_METHODS = 0;
49			$METHOD_LEVELS = [3];
50			$TRACE_STACK_LEVELS = [];
51	ts-dev	1.3	$logger = Class::Logger->new();
52			@EXPORT = qw($logger);
53	ts-dev	1.1
54
55			# TODO: review, revise and rewire this!
56			#my $logger = Log::Dispatch::Config->instance;
57
58			sub __init {
59			my $self = shift;
60			my $action = shift;
61			my $message = shift;
62			#my $options = shift; # ??? or: $self->{__logger}->{options} already...?
63
64			# configure
65			if (!$self->{__logger}->{configured}) {
66			$self->{__logger}->{configured} = 1;
67			$self->_configure_LogDispatch();
68			}
69
70			# set passed-in arguments
71			$self->{__logger}->{action} = $action;
72			$self->{__logger}->{message} = $message;
73
74			# trace
75			#my $tmp = caller(2);
76			#print Dumper($tmp);
77			#exit;
78
79
80			# handle caller
81
82			# determine class- and subroutinename of context calling us
83			# this task can be controlled by tuning its behaviour
84			# this can be changed by setting
85			# Class::Logger::...
86			# ...
87			# ...
88			my $calling_class;
89			my $calling_sub;
90
91
92			# Default behaviour is:
93			# Use classname from $self and suppress subroutine name.
94			# In case of using this together with DesignPattern::Bridge,
95			# the classnames of child objects are suppressed.
96			# Instead, the classname of the parent container object
97			# gets used always.
98			$calling_class = '';
99			$calling_sub = '';
100
101			# Log class names (en-/disabled, take from specified level)
102			if ($ENABLE_NAMESPACE) {
103			$calling_class = ref $self;
104			if ($NAMESPACE_LEVEL) {
105			my @entry = caller($NAMESPACE_LEVEL);
106			$calling_class = $entry[0];
107			}
108			}
109
110			# Log method names (en-/disabled, multi-level)
111			if ($ENABLE_METHODS) {
112			my @methods;
113			foreach (@{$METHOD_LEVELS}) {
114			(my $c_package, my $c_filename, my $c_line, my $c_subroutine, my $c_hasargs,
115			my $c_wantarray, my $c_evaltext, my $c_is_require, my $c_hints, my $c_bitmask) = caller($_);
116			$c_subroutine \|\|= '';
117			$c_subroutine =~ s/.*:://;
118			push @methods, $c_subroutine;
119			}
120			$calling_sub = join(': ', @methods) if @methods;
121			}
122
123
124
125			# set default arguments
126			$self->{__logger}->{classname} = $calling_class;
127			$self->{__logger}->{functionname} = $calling_sub;
128			# FIXME: deprecate this!
129			$self->{__logger}->{caller} = caller;
130
131			# set default values
132			$self->{__logger}->{action} \|\|= '';
133			$self->{__logger}->{options}->{tag} \|\|= '';
134
135			# FIXME: deprecate this!
136			#$self->{__logger}->{level} \|\|= 'info';
137			#$self->{__logger}->{level} \|\|= 'debug';
138			$self->{__logger}->{level} \|\|= $LEVEL_DEFAULT;
139
140			# handle stacktrace
141			foreach (@$TRACE_STACK_LEVELS) {
142			#print "trace-level: ", $_, "\n";
143			#(my $c_package, my $c_filename, my $c_line, my $c_subroutine, my $c_hasargs,
144			#my $c_wantarray, my $c_evaltext, my $c_is_require, my $c_hints, my $c_bitmask) = caller($_);
145			my @entry = caller($_);
146			push @{$self->{__logger}->{trace}->{stack}}, \@entry;
147			}
148
149			}
150
151			sub __out {
152			my $self = shift;
153			my $message = shift;
154
155			# if message given here, append to message stored inside object
156			$self->{__logger}->{message} .= ' - ' . $message if $message;
157
158			# TODO: refactor this:
159			# - push '$self->__get_prefix()' to additional log-entry-metadata, don't show it on/in any console/logfile output
160			#$logger->log( level => $self->{__logger}->{level}, message => $self->__get_prefix_long() . $message );
161			#$logger->log( level => $self->{__logger}->{level}, message => $message );
162			#$logger->warning( __PACKAGE__ . "->_skip: '$caller' (mixed into '$classname'): ($options->{tag}) $message.");
163			#$self->{__logger}->{instance}->log( level => $self->{__logger}->{level}, message => $self->__get_prefix_short() . $self->{__logger}->{message} );
164			#$self->{__logger}->{instance}->log( level => $self->{__logger}->{level}, message => $self->__get_prefix_module() . $self->{__logger}->{message} );
165			$self->{__logger}->{instance}->log( level => $self->{__logger}->{level}, message => $self->__get_prefix_best() . $self->{__logger}->{message} );
166			}
167
168
169			sub __handle_options {
170			my $self = shift;
171			#my $options = shift; # ??? or: $self->{__logger}->{options} already...?
172			}
173
174			sub __get_prefix_long {
175			my $self = shift;
176			return __PACKAGE__ . "->$self->{__logger}->{action}: '$self->{__logger}->{caller}' (mixed into '$self->{__logger}->{classname}'): ($self->{__logger}->{options}->{tag}) - ";
177			}
178
179			sub __get_prefix_short {
180			my $self = shift;
181			my $tag_append = '';
182			$tag_append = "$self->{__logger}->{options}->{tag} - " if $self->{__logger}->{options}->{tag};
183			return $self->{__logger}->{classname} . "->$self->{__logger}->{action}: $tag_append";
184			}
185
186			sub __get_prefix_module {
187			my $self = shift;
188			my $tag_append = '';
189			$tag_append = "$self->{__logger}->{options}->{tag} - " if $self->{__logger}->{options}->{tag};
190			return $self->{__logger}->{classname} . ": $tag_append";
191			}
192
193
194			sub __get_prefix_best {
195			my $self = shift;
196			my $namespace = $self->{__logger}->{classname};
197			my $method = '';
198			my $tag_append = '';
199			#$namespace = $namespace . ": " if $namespace;
200			$method = "->" . $self->{__logger}->{functionname} if $self->{__logger}->{functionname};
201			#$method .= ': ' if $method;
202			$tag_append = "$self->{__logger}->{options}->{tag} - " if $self->{__logger}->{options}->{tag};
203
204			my @line;
205			push @line, $namespace if $namespace;
206			push @line, $method if $method;
207			push @line, $tag_append if $tag_append;
208
209			#print Dumper(@line);
210
211			#return join(': ', @line);
212			my $result = join('', @line);
213			$result .= ': ' if $result;
214
215			return $result;
216
217			}
218
219
220			sub log_ {
221			my $self = shift;
222			my $message = shift;
223
224			# automagically instantiate the object if not there
225			# TODO: do this by creating a dummy object inheriting from Class::Logger,
226			# for now this just don't work because which dummy one to take: Data::Code::Null?
227			#if (! ref $self) {
228			# $self = DesignPattern::Object->fromPackage('Class::Logger');
229			#}
230
231			$self->{__logger}->{level} = shift; # TODO: implement propagation of this into Log::Dispatch-object '$logger'!
232			$self->{__logger}->{options} = shift; # TODO: implement additional behaviours: e.g. { exit => 1 } would exit after tracedump
233
234			$self->{__logger}->{level} \|\|= $LEVEL_DEFAULT;
235			$self->_configure_LogDispatch();
236	ts-dev	1.2	local ${Log::Dispatch::Config::CallerDepth} = 3;
237	ts-dev	1.1	$self->{__logger}->{instance}->log( level => $self->{__logger}->{level}, message => $message );
238			#$self->__init('log', $message);
239			#$self->__out();
240
241			}
242
243			sub skip {
244			my $self = shift;
245			my $message = shift;
246			my $condition = shift;
247			$self->{__logger}->{level} = shift; # TODO: implement propagation of this into Log::Dispatch-object '$logger'!
248			$self->{__logger}->{options} = shift; # TODO: implement additional behaviours: e.g. { exit => 1 } would exit after tracedump
249
250			my $classname = ref $self;
251			my $caller = caller;
252
253			$self->{__logger}->{options}->{tag} \|\|= '';
254
255			if ($condition) {
256			# V1:
257			#$logger->warning( __PACKAGE__ . "->_skip: '$caller' (mixed into '$classname'): ($options->{tag}) $message.");
258			# V2:
259			$self->__init('skip', $message);
260			$self->__out();
261			return 1;
262			}
263			}
264
265			sub trace_ {
266			my $self = shift;
267			my $message = shift;
268			my $data = shift;
269			my $condition = shift;
270			$self->{__logger}->{level} = shift; # TODO: implement propagation of this into Log::Dispatch-object '$logger'!
271			$self->{__logger}->{options} = shift; # TODO: implement additional behaviours: e.g. { exit => 1 } would exit after tracedump
272
273			my $classname = ref $self;
274			my $caller = caller;
275
276			$self->{__logger}->{options}->{tag} \|\|= '';
277
278			# don't do _any_ tracing if disabled
279			return if $self->{TRACE_DISABLED};
280
281			# overwrite condition with local configured want-TRACE
282			$condition \|\|= $self->{TRACE};
283
284			# dump data
285			my $result = 0;
286			if ($condition) {
287			$message .= " - " . Dumper($data);
288
289			# V1:
290			# $self->__init('trace');
291			# $logger->info( __PACKAGE__ . "->trace: '$caller' (mixed into '$classname'): ($options->{tag}) $message.");
292
293			# V2:
294	ts-dev	1.2	#local ${Log::Dispatch::Config::CallerDepth} = 3;
295	ts-dev	1.1	#$self->{__logger}->{instance}->log( level => $self->{__logger}->{level}, message => $message );
296			$self->__init('trace', $message);
297			$self->__out();
298
299			$result = 1;
300			} else {
301			$result = 0;
302			}
303
304			# handle additional options
305			if ($self->{TRACE_OPTIONS}) {
306			exit if $self->{__logger}->{options}->{exit};
307			}
308
309			return $result;
310			}
311
312
313			sub _configure_LogDispatch {
314			my $self = shift;
315
316			my $configurator = DesignPattern::Object->fromPackage('Log::Dispatch::Configurator::Hardwired');
317
318			# check if running inside a 'PROJECT' space
319			my $basepath = cwd();
320			my $postpone = '/..';
321			if (-d $basepath . $postpone . '/PROJECT') {
322			$basepath .= $postpone;
323			$basepath .= "/var/log";
324			}
325
326			# configure custom logHandler
327
328			if ($configurator) {
329
330			$configurator->{file_filename} = "$basepath/perl_app.log";
331			$configurator->{screen_min_level} = 'info';
332
333			if ($self->{quiet}) {
334			$configurator->{screen_min_level} = 8;
335			}
336
337			if ($self->{debug}) {
338			$configurator->{screen_min_level} = 'debug';
339			}
340
341			if ($self->{LOG_VERBOSE}) {
342			$configurator->{verbose} = 1;
343			}
344
345			Log::Dispatch::Config->configure($configurator);
346			$self->{__logger}->{instance} = Log::Dispatch::Config->instance;
347
348			} else {
349
350			#Log::Dispatch::Config->configure();
351			#Log::Dispatch->configure();
352			#$self->{__logger}->{instance} = Log::Dispatch->new;
353			$self->{__logger}->{instance} = Log::Dispatch::Screen->new( name => 'screen', 'min_level' => 'debug', stderr => 1 );
354
355			}
356
357
358			}
359
360			sub configure_logger {
361			my $self = shift;
362
363			# automagically instantiate the object if not there
364			# TODO: do this by creating a dummy object inheriting from Class::Logger,
365			# for now this just don't work because which dummy one to take: Data::Code::Null?
366			if (! ref $self) {
367			$self = DesignPattern::Object->fromPackage('Class::Logger');
368			}
369
370			#print "logconfig\n";
371			$self->_configure_LogDispatch();
372			}
373
374
375
376			# for standalone use
377			sub new { my $class = shift; my $self = {}; bless $self, $class; }
378
379			# convenient shortcuts
380			# FIXME: create these automagically by mungling with symbolic references
381			# or: make this object tied to recieve kinda events on method calls
382
383			BEGIN {
384			no strict 'refs';
385			foreach my $l ( qw(debug info notice warning err error
386			crit critical alert emerg emergency) ) {
387			*{$l} = sub {
388			my $self = shift;
389	ts-dev	1.2	local ${Log::Dispatch::Config::CallerDepth} =
390			${Log::Dispatch::Config::CallerDepth} + 1;
391	ts-dev	1.1	$self->log( "@_", $l );
392			};
393			}
394			}
395
396
397			sub log {
398			my $self = shift;
399			my ($message, $level) = @_;
400			$level \|\|= 'debug';
401			my $logger = $self->_get_instance();
402	ts-dev	1.2	local ${Log::Dispatch::Config::CallerDepth} = ${Log::Dispatch::Config::CallerDepth} + 1;
403	ts-dev	1.1	$logger->log( level => $level, message => $message );
404			}
405
406			sub dump {
407			my $self = shift;
408			my $data = shift;
409			local $Data::Dumper::Indent = 1;
410			local $Data::Dumper::Sortkeys = 1;
411			my $dump = Dumper $data;
412	ts-dev	1.2	local ${Log::Dispatch::Config::CallerDepth} = ${Log::Dispatch::Config::CallerDepth} + 1;
413	ts-dev	1.1	$self->log("DUMP: \n$dump", 'debug');
414			}
415			sub strace {
416			my $self = shift;
417			my $levels = shift \|\| 5;
418			$levels = 1 if $levels < 1;
419			my $message = "\nSTACK-TRACE:\n";
420			for (1..$levels) {
421			my ($package, $filename, $line, $subroutine) = (caller $_)[0..3];
422			last unless defined $package;
423			#$message .= qq# ${subroutine} ($filename line $line)\n#;
424			$message .= qq# ${subroutine} (line $line)\n#;
425			}
426	ts-dev	1.2	local ${Log::Dispatch::Config::CallerDepth} = ${Log::Dispatch::Config::CallerDepth} + 1;
427	ts-dev	1.1	$self->log($message, 'debug');
428			}
429
430			{
431			my $logger;
432			my $object;
433			sub _create {
434			$object = __PACKAGE__->new();
435			$object->_get_instance(@_);
436			$main::logger = $object;
437			return $object;
438			}
439			sub _get_instance {
440			my $self = shift;
441			return $logger if defined $logger;
442			my $configurator = $self->_get_configurator();
443			if ($configurator) {
444			#warn Dumper $configurator;
445			Log::Dispatch::Config->configure($configurator);
446			$logger = Log::Dispatch::Config->instance;
447			}
448			else {
449			$logger = Log::Dispatch::Screen->new(
450			name => 'screen',
451			'min_level' => 'debug',
452			stderr => 1
453			);
454			}
455			}
456			sub _get_configurator {
457			my $self = shift;
458			my $configurator = DesignPattern::Object->fromPackage('Log::Dispatch::Configurator::Hardwired');
459			# check if running inside a 'PROJECT' space
460			my $basepath = cwd();
461			my $postpone = '/..';
462			if (-d $basepath . $postpone . '/PROJECT') {
463			$basepath .= $postpone;
464			$basepath .= "/var/log";
465			}
466			if ($self->{quiet}) {
467			$configurator->{screen_min_level} = 8;
468			}
469			if ($self->{debug}) {
470			$configurator->{screen_min_level} = 'debug';
471			}
472			if ($self->{LOG_VERBOSE}) {
473			$configurator->{verbose} = 1;
474			}
475			$configurator->{file_filename} = "$basepath/perl_app.log";
476			$configurator->{screen_min_level} = 'info';
477			return $configurator;
478			}
479			}
480
481
482			=pod
483
484			=head1 TODO
485
486			o $TRACE_STACK_LEVELS (traces stack history)
487			o $ENABLE_DEBUG (en-/disables level 'debug')
488			o $ENABLE_LOG (en-/disables logging completely)
489
490
491			=cut
492
493
494			1;
495			__END__
MailToCvsAdmin">MailToCvsAdmin	ViewVC Help
Powered by ViewVC 1.1.26