/[cvs]/nfo/perl/libs/DesignPattern/Logger.pm
ViewVC logotype

Diff of /nfo/perl/libs/DesignPattern/Logger.pm

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.1 by joko, Wed Feb 19 00:34:52 2003 UTC revision 1.2 by joko, Thu Feb 20 21:06:27 2003 UTC
# Line 2  Line 2 
2  ##  $Id$  ##  $Id$
3  ## ------------------------------------------------------------------------  ## ------------------------------------------------------------------------
4  ##  $Log$  ##  $Log$
5    ##  Revision 1.2  2003/02/20 21:06:27  joko
6    ##  + configurable by package globals
7    ##  + standalone mode (object creation via 'new')
8    ##  + some comments
9    ##  + Log::Dispatch gets configured inside here now
10    ##  + coordinated stack tracing
11    ##  + convenient shortcut methods resembling the syslog levels
12    ##
13  ##  Revision 1.1  2003/02/19 00:34:52  joko  ##  Revision 1.1  2003/02/19 00:34:52  joko
14  ##  + initial commit, again refactored to this place  ##  + initial commit, again refactored to this place
15  ##  ##
# Line 38  use Log::Dispatch::Config; Line 46  use Log::Dispatch::Config;
46  use Cwd;  use Cwd;
47  use DesignPattern::Object;  use DesignPattern::Object;
48    
49    use vars qw(
50      $LEVEL_DEFAULT
51      $ENABLE_NAMESPACE
52      $NAMESPACE_LEVEL
53      $ENABLE_METHODS
54      $METHOD_LEVELS
55      $TRACE_STACK_LEVELS
56    );
57    
58    # default behaviour
59    $LEVEL_DEFAULT = 'debug';
60    $ENABLE_NAMESPACE = 1;
61    $NAMESPACE_LEVEL = undef;
62    $ENABLE_METHODS = 0;
63    $METHOD_LEVELS = [3];
64    $TRACE_STACK_LEVELS = [];
65    
66    
67  # TODO: review, revise and rewire this!  # TODO: review, revise and rewire this!
68  #my $logger = Log::Dispatch::Config->instance;  #my $logger = Log::Dispatch::Config->instance;
# Line 58  sub __init { Line 83  sub __init {
83    $self->{__logger}->{action} = $action;    $self->{__logger}->{action} = $action;
84    $self->{__logger}->{message} = $message;    $self->{__logger}->{message} = $message;
85    
86      # trace
87        #my $tmp = caller(2);
88        #print Dumper($tmp);
89        #exit;
90      
91    
92      # handle caller
93    
94        # determine class- and subroutinename of context calling us
95        # this task can be controlled by tuning its behaviour
96        # this can be changed by setting
97        #   DesignPattern::Logger::...
98        #   ...
99        #   ...
100        my $calling_class;
101        my $calling_sub;
102    
103    
104        # Default behaviour is:
105        #   Use classname from $self and suppress subroutine name.
106        #   In case of using this together with DesignPattern::Bridge,
107        #   the classnames of child objects are suppressed.
108        #   Instead, the classname of the parent container object
109        #   gets used *always*.
110          $calling_class = '';
111          $calling_sub = '';
112    
113          # Log class names (en-/disabled, take from specified level)
114          if ($ENABLE_NAMESPACE) {
115            $calling_class = ref $self;
116            if ($NAMESPACE_LEVEL) {
117              my @entry = caller($NAMESPACE_LEVEL);
118              $calling_class = $entry[0];
119            }
120          }
121    
122          # Log method names (en-/disabled, multi-level)
123          if ($ENABLE_METHODS) {
124            my @methods;
125            foreach (@{$METHOD_LEVELS}) {
126              (my $c_package, my $c_filename, my $c_line, my $c_subroutine, my $c_hasargs,
127              my $c_wantarray, my $c_evaltext, my $c_is_require, my $c_hints, my $c_bitmask) = caller($_);
128              $c_subroutine =~ s/.*:://;
129              push @methods, $c_subroutine;
130            }
131            $calling_sub = join(': ', @methods);
132          }
133      
134        
135    
136    # set default arguments    # set default arguments
137    $self->{__logger}->{classname} = ref $self;    $self->{__logger}->{classname} = $calling_class;
138      $self->{__logger}->{functionname} = $calling_sub;
139      # FIXME: deprecate this!
140    $self->{__logger}->{caller} = caller;    $self->{__logger}->{caller} = caller;
141        
142    # set default values    # set default values
143    $self->{__logger}->{action} ||= '';    $self->{__logger}->{action} ||= '';
144    $self->{__logger}->{options}->{tag} ||= '';    $self->{__logger}->{options}->{tag} ||= '';
145        
146      # FIXME: deprecate this!
147    #$self->{__logger}->{level} ||= 'info';    #$self->{__logger}->{level} ||= 'info';
148    $self->{__logger}->{level} ||= 'debug';    #$self->{__logger}->{level} ||= 'debug';
149      $self->{__logger}->{level} ||= $LEVEL_DEFAULT;
150    
151      # handle stacktrace
152        foreach (@$TRACE_STACK_LEVELS) {
153          #print "trace-level: ", $_, "\n";
154          #(my $c_package, my $c_filename, my $c_line, my $c_subroutine, my $c_hasargs,
155          #my $c_wantarray, my $c_evaltext, my $c_is_require, my $c_hints, my $c_bitmask) = caller($_);
156          my @entry = caller($_);
157          push @{$self->{__logger}->{trace}->{stack}}, \@entry;
158        }
159        
160  }  }
161    
# Line 84  sub __out { Line 172  sub __out {
172    #$logger->log( level => $self->{__logger}->{level}, message => $message );    #$logger->log( level => $self->{__logger}->{level}, message => $message );
173    #$logger->warning( __PACKAGE__ . "->_skip: '$caller' (mixed into '$classname'): ($options->{tag}) $message.");    #$logger->warning( __PACKAGE__ . "->_skip: '$caller' (mixed into '$classname'): ($options->{tag}) $message.");
174    #$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_short() . $self->{__logger}->{message} );
175    $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_module() . $self->{__logger}->{message} );
176      $self->{__logger}->{instance}->log( level => $self->{__logger}->{level}, message => $self->__get_prefix_best() . $self->{__logger}->{message} );
177  }  }
178    
179    
# Line 113  sub __get_prefix_module { Line 202  sub __get_prefix_module {
202  }  }
203    
204    
205    sub __get_prefix_best {
206      my $self = shift;
207      my $namespace = $self->{__logger}->{classname};
208      my $method = '';
209      my $tag_append = '';
210      #$namespace = $namespace . ": " if $namespace;
211      $method = "->" . $self->{__logger}->{functionname} if $self->{__logger}->{functionname};
212      #$method .= ': ' if $method;
213      $tag_append = "$self->{__logger}->{options}->{tag} - " if $self->{__logger}->{options}->{tag};
214      
215      my @line;
216      push @line, $namespace if $namespace;
217      push @line, $method if $method;
218      push @line, $tag_append if $tag_append;
219      
220      #print Dumper(@line);
221      
222      #return join(': ', @line);
223      my $result = join('', @line);
224      $result .= ': ' if $result;
225      
226      return $result;
227      
228    }
229    
230    
231  sub log {  sub log {
232    my $self = shift;    my $self = shift;
233    my $message = shift;    my $message = shift;
# Line 243  sub _configure_LogDispatch { Line 358  sub _configure_LogDispatch {
358    
359  }  }
360    
361    sub configure_logger {
362      my $self = shift;
363    
364      # automagically instantiate the object if not there
365      # TODO: do this by creating a dummy object inheriting from DesignPattern::Logger,
366      # for now this just don't work because which dummy one to take: Data::Code::Null?
367      if (! ref $self) {
368        $self = DesignPattern::Object->fromPackage('DesignPattern::Logger');
369      }
370    
371      #print "logconfig\n";
372      $self->_configure_LogDispatch();
373    }
374    
375    
376    
377    # for standalone use
378    sub new { my $class = shift; my $self = {}; bless $self, $class; }
379    
380    # convenient shortcuts
381    # FIXME: create these automagically by mungling with symbolic references
382    # or: make this object tied to recieve kinda events on method calls
383    
384    sub debug {
385      my $self = shift;
386      my $message = shift;
387      $self->log($message, 'debug');
388    }
389    
390    sub warning {
391      my $self = shift;
392      my $message = shift;
393      $self->log($message, 'warning');
394    }
395    
396    sub info {
397      my $self = shift;
398      my $message = shift;
399      $self->log($message, 'info');
400    }
401    
402    sub notice {
403      my $self = shift;
404      my $message = shift;
405      $self->log($message, 'notice');
406    }
407    
408    
409    
410    =pod
411    
412    =head1 TODO
413      
414      o $TRACE_STACK_LEVELS   (traces stack history)
415      o $ENABLE_DEBUG   (en-/disables level 'debug')
416      o $ENABLE_LOG   (en-/disables logging completely)
417    
418    
419    =cut
420    
421    
422  1;  1;
423  __END__  __END__
Legend:
Removed from v.1.1  
changed lines
  Added in v.1.2
MailToCvsAdmin">MailToCvsAdmin
 ViewVC Help
Powered by ViewVC 1.1.26 RSS 2.0 feed