/[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.4 by joko, Sat Mar 29 07:16:00 2003 UTC
# Line 2  Line 2 
2  ##  $Id$  ##  $Id$
3  ## ------------------------------------------------------------------------  ## ------------------------------------------------------------------------
4  ##  $Log$  ##  $Log$
5    ##  Revision 1.4  2003/03/29 07:16:00  joko
6    ##  minor update: changed default log-file-name to 'perl_app.log'
7    ##
8    ##  Revision 1.3  2003/03/28 07:23:25  joko
9    ##  fix to basepath calculation
10    ##
11    ##  Revision 1.2  2003/02/20 21:06:27  joko
12    ##  + configurable by package globals
13    ##  + standalone mode (object creation via 'new')
14    ##  + some comments
15    ##  + Log::Dispatch gets configured inside here now
16    ##  + coordinated stack tracing
17    ##  + convenient shortcut methods resembling the syslog levels
18    ##
19  ##  Revision 1.1  2003/02/19 00:34:52  joko  ##  Revision 1.1  2003/02/19 00:34:52  joko
20  ##  + initial commit, again refactored to this place  ##  + initial commit, again refactored to this place
21  ##  ##
# Line 38  use Log::Dispatch::Config; Line 52  use Log::Dispatch::Config;
52  use Cwd;  use Cwd;
53  use DesignPattern::Object;  use DesignPattern::Object;
54    
55    use vars qw(
56      $LEVEL_DEFAULT
57      $ENABLE_NAMESPACE
58      $NAMESPACE_LEVEL
59      $ENABLE_METHODS
60      $METHOD_LEVELS
61      $TRACE_STACK_LEVELS
62    );
63    
64    # default behaviour
65    $LEVEL_DEFAULT = 'debug';
66    $ENABLE_NAMESPACE = 1;
67    $NAMESPACE_LEVEL = undef;
68    $ENABLE_METHODS = 0;
69    $METHOD_LEVELS = [3];
70    $TRACE_STACK_LEVELS = [];
71    
72    
73  # TODO: review, revise and rewire this!  # TODO: review, revise and rewire this!
74  #my $logger = Log::Dispatch::Config->instance;  #my $logger = Log::Dispatch::Config->instance;
# Line 58  sub __init { Line 89  sub __init {
89    $self->{__logger}->{action} = $action;    $self->{__logger}->{action} = $action;
90    $self->{__logger}->{message} = $message;    $self->{__logger}->{message} = $message;
91    
92      # trace
93        #my $tmp = caller(2);
94        #print Dumper($tmp);
95        #exit;
96      
97    
98      # handle caller
99    
100        # determine class- and subroutinename of context calling us
101        # this task can be controlled by tuning its behaviour
102        # this can be changed by setting
103        #   DesignPattern::Logger::...
104        #   ...
105        #   ...
106        my $calling_class;
107        my $calling_sub;
108    
109    
110        # Default behaviour is:
111        #   Use classname from $self and suppress subroutine name.
112        #   In case of using this together with DesignPattern::Bridge,
113        #   the classnames of child objects are suppressed.
114        #   Instead, the classname of the parent container object
115        #   gets used *always*.
116          $calling_class = '';
117          $calling_sub = '';
118    
119          # Log class names (en-/disabled, take from specified level)
120          if ($ENABLE_NAMESPACE) {
121            $calling_class = ref $self;
122            if ($NAMESPACE_LEVEL) {
123              my @entry = caller($NAMESPACE_LEVEL);
124              $calling_class = $entry[0];
125            }
126          }
127    
128          # Log method names (en-/disabled, multi-level)
129          if ($ENABLE_METHODS) {
130            my @methods;
131            foreach (@{$METHOD_LEVELS}) {
132              (my $c_package, my $c_filename, my $c_line, my $c_subroutine, my $c_hasargs,
133              my $c_wantarray, my $c_evaltext, my $c_is_require, my $c_hints, my $c_bitmask) = caller($_);
134              $c_subroutine =~ s/.*:://;
135              push @methods, $c_subroutine;
136            }
137            $calling_sub = join(': ', @methods);
138          }
139      
140        
141    
142    # set default arguments    # set default arguments
143    $self->{__logger}->{classname} = ref $self;    $self->{__logger}->{classname} = $calling_class;
144      $self->{__logger}->{functionname} = $calling_sub;
145      # FIXME: deprecate this!
146    $self->{__logger}->{caller} = caller;    $self->{__logger}->{caller} = caller;
147        
148    # set default values    # set default values
149    $self->{__logger}->{action} ||= '';    $self->{__logger}->{action} ||= '';
150    $self->{__logger}->{options}->{tag} ||= '';    $self->{__logger}->{options}->{tag} ||= '';
151        
152      # FIXME: deprecate this!
153    #$self->{__logger}->{level} ||= 'info';    #$self->{__logger}->{level} ||= 'info';
154    $self->{__logger}->{level} ||= 'debug';    #$self->{__logger}->{level} ||= 'debug';
155      $self->{__logger}->{level} ||= $LEVEL_DEFAULT;
156    
157      # handle stacktrace
158        foreach (@$TRACE_STACK_LEVELS) {
159          #print "trace-level: ", $_, "\n";
160          #(my $c_package, my $c_filename, my $c_line, my $c_subroutine, my $c_hasargs,
161          #my $c_wantarray, my $c_evaltext, my $c_is_require, my $c_hints, my $c_bitmask) = caller($_);
162          my @entry = caller($_);
163          push @{$self->{__logger}->{trace}->{stack}}, \@entry;
164        }
165        
166  }  }
167    
# Line 84  sub __out { Line 178  sub __out {
178    #$logger->log( level => $self->{__logger}->{level}, message => $message );    #$logger->log( level => $self->{__logger}->{level}, message => $message );
179    #$logger->warning( __PACKAGE__ . "->_skip: '$caller' (mixed into '$classname'): ($options->{tag}) $message.");    #$logger->warning( __PACKAGE__ . "->_skip: '$caller' (mixed into '$classname'): ($options->{tag}) $message.");
180    #$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} );
181    $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} );
182      $self->{__logger}->{instance}->log( level => $self->{__logger}->{level}, message => $self->__get_prefix_best() . $self->{__logger}->{message} );
183  }  }
184    
185    
# Line 113  sub __get_prefix_module { Line 208  sub __get_prefix_module {
208  }  }
209    
210    
211    sub __get_prefix_best {
212      my $self = shift;
213      my $namespace = $self->{__logger}->{classname};
214      my $method = '';
215      my $tag_append = '';
216      #$namespace = $namespace . ": " if $namespace;
217      $method = "->" . $self->{__logger}->{functionname} if $self->{__logger}->{functionname};
218      #$method .= ': ' if $method;
219      $tag_append = "$self->{__logger}->{options}->{tag} - " if $self->{__logger}->{options}->{tag};
220      
221      my @line;
222      push @line, $namespace if $namespace;
223      push @line, $method if $method;
224      push @line, $tag_append if $tag_append;
225      
226      #print Dumper(@line);
227      
228      #return join(': ', @line);
229      my $result = join('', @line);
230      $result .= ': ' if $result;
231      
232      return $result;
233      
234    }
235    
236    
237  sub log {  sub log {
238    my $self = shift;    my $self = shift;
239    my $message = shift;    my $message = shift;
# Line 206  sub _configure_LogDispatch { Line 327  sub _configure_LogDispatch {
327    
328    my $configurator = DesignPattern::Object->fromPackage('Log::Dispatch::Configurator::Hardwired');    my $configurator = DesignPattern::Object->fromPackage('Log::Dispatch::Configurator::Hardwired');
329        
330    # FIXME?    # check if running inside a 'PROJECT' space
331    my $basepath = cwd() . '/..';    my $basepath = cwd();
332      my $postpone = '/..';
333      if (-d $basepath . $postpone . '/PROJECT') {
334        $basepath .= $postpone;
335        $basepath .= "/var/log";
336      }
337        
338    # configure custom logHandler    # configure custom logHandler
339        
340      if ($configurator) {      if ($configurator) {
341        
342        $configurator->{file_filename} = "$basepath/var/log/logfile.txt";        $configurator->{file_filename} = "$basepath/perl_app.log";
343        $configurator->{screen_min_level} = 'info';        $configurator->{screen_min_level} = 'info';
344                
345        if ($self->{quiet}) {        if ($self->{quiet}) {
# Line 243  sub _configure_LogDispatch { Line 369  sub _configure_LogDispatch {
369    
370  }  }
371    
372    sub configure_logger {
373      my $self = shift;
374    
375      # automagically instantiate the object if not there
376      # TODO: do this by creating a dummy object inheriting from DesignPattern::Logger,
377      # for now this just don't work because which dummy one to take: Data::Code::Null?
378      if (! ref $self) {
379        $self = DesignPattern::Object->fromPackage('DesignPattern::Logger');
380      }
381    
382      #print "logconfig\n";
383      $self->_configure_LogDispatch();
384    }
385    
386    
387    
388    # for standalone use
389    sub new { my $class = shift; my $self = {}; bless $self, $class; }
390    
391    # convenient shortcuts
392    # FIXME: create these automagically by mungling with symbolic references
393    # or: make this object tied to recieve kinda events on method calls
394    
395    sub debug {
396      my $self = shift;
397      my $message = shift;
398      $self->log($message, 'debug');
399    }
400    
401    sub warning {
402      my $self = shift;
403      my $message = shift;
404      $self->log($message, 'warning');
405    }
406    
407    sub info {
408      my $self = shift;
409      my $message = shift;
410      $self->log($message, 'info');
411    }
412    
413    sub notice {
414      my $self = shift;
415      my $message = shift;
416      $self->log($message, 'notice');
417    }
418    
419    
420    
421    =pod
422    
423    =head1 TODO
424      
425      o $TRACE_STACK_LEVELS   (traces stack history)
426      o $ENABLE_DEBUG   (en-/disables level 'debug')
427      o $ENABLE_LOG   (en-/disables logging completely)
428    
429    
430    =cut
431    
432    
433  1;  1;
434  __END__  __END__
Legend:
Removed from v.1.1  
changed lines
  Added in v.1.4
MailToCvsAdmin">MailToCvsAdmin
 ViewVC Help
Powered by ViewVC 1.1.26 RSS 2.0 feed