cpan/Class/Logger.pm

## ------------------------------------------------------------------------
##  $Id: Logger.pm,v 1.6 2003/06/06 03:19:09 joko Exp $
## ------------------------------------------------------------------------
##  $Log: Logger.pm,v $
##
## ------------------------------------------------------------------------


=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
        $loggerai @EXPORT
);
@EXPORT = qw($logger);

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