libs/DesignPattern/Logger.pm

## ------------------------------------------------------------------------
##  $Id: Logger.pm,v 1.5 2003/05/13 08:40:15 joko Exp $
## ------------------------------------------------------------------------
##  $Log: Logger.pm,v $
##  Revision 1.5  2003/05/13 08:40:15  joko
##  minor update: renamed attribute
##
##  Revision 1.4  2003/03/29 07:16:00  joko
##  minor update: changed default log-file-name to 'perl_app.log'
##
##  Revision 1.3  2003/03/28 07:23:25  joko
##  fix to basepath calculation
##
##  Revision 1.2  2003/02/20 21:06:27  joko
##  + configurable by package globals
##  + standalone mode (object creation via 'new')
##  + some comments
##  + Log::Dispatch gets configured inside here now
##  + coordinated stack tracing
##  + convenient shortcut methods resembling the syslog levels
##
##  Revision 1.1  2003/02/19 00:34:52  joko
##  + initial commit, again refactored to this place
##
##  Revision 1.3  2003/02/18 18:33:59  joko
##  + fix: just logs if possible
##
##  Revision 1.2  2003/02/18 16:37:22  joko
##  + fix: ...::Hardwired is an optional module
##
##  Revision 1.1  2003/02/18 15:57:34  joko
##  + initial commit, refactored from DesignPattern::Object::Logger
##
##  Revision 1.2  2003/02/14 14:20:42  joko
##  + decreased default log-level to debug
##
##  Revision 1.1  2002/12/22 14:17:38  joko
##  + initial check-in, refactored
##
##  Revision 1.1  2002/12/19 01:14:48  cvsjoko
##  + initial check-in
##
## ------------------------------------------------------------------------


=pod

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


=cut


package DesignPattern::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 vars qw(
  $LEVEL_DEFAULT
  $ENABLE_NAMESPACE
  $NAMESPACE_LEVEL
  $ENABLE_METHODS
  $METHOD_LEVELS
  $TRACE_STACK_LEVELS
);

# default behaviour
$LEVEL_DEFAULT = 'debug';
$ENABLE_NAMESPACE = 1;
$NAMESPACE_LEVEL = undef;
$ENABLE_METHODS = 0;
$METHOD_LEVELS = [3];
$TRACE_STACK_LEVELS = [];


# 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
    #   DesignPattern::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 DesignPattern::Logger,
  # for now this just don't work because which dummy one to take: Data::Code::Null?
  #if (! ref $self) {
  #  $self = DesignPattern::Object->fromPackage('DesignPattern::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->__init('log', $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:
      $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 DesignPattern::Logger,
  # for now this just don't work because which dummy one to take: Data::Code::Null?
  if (! ref $self) {
    $self = DesignPattern::Object->fromPackage('DesignPattern::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

sub debug {
  my $self = shift;
  my $message = shift;
  $self->log($message, 'debug');
}

sub warning {
  my $self = shift;
  my $message = shift;
  $self->log($message, 'warning');
}

sub info {
  my $self = shift;
  my $message = shift;
  $self->log($message, 'info');
}

sub notice {
  my $self = shift;
  my $message = shift;
  $self->log($message, 'notice');
}


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