/[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.6 by joko, Fri Jun 6 03:19:09 2003 UTC
# Line 2  Line 2 
2  ##  $Id$  ##  $Id$
3  ## ------------------------------------------------------------------------  ## ------------------------------------------------------------------------
4  ##  $Log$  ##  $Log$
5    ##  Revision 1.6  2003/06/06 03:19:09  joko
6    ##  minor fixes
7    ##
8    ##  Revision 1.5  2003/05/13 08:40:15  joko
9    ##  minor update: renamed attribute
10    ##
11    ##  Revision 1.4  2003/03/29 07:16:00  joko
12    ##  minor update: changed default log-file-name to 'perl_app.log'
13    ##
14    ##  Revision 1.3  2003/03/28 07:23:25  joko
15    ##  fix to basepath calculation
16    ##
17    ##  Revision 1.2  2003/02/20 21:06:27  joko
18    ##  + configurable by package globals
19    ##  + standalone mode (object creation via 'new')
20    ##  + some comments
21    ##  + Log::Dispatch gets configured inside here now
22    ##  + coordinated stack tracing
23    ##  + convenient shortcut methods resembling the syslog levels
24    ##
25  ##  Revision 1.1  2003/02/19 00:34:52  joko  ##  Revision 1.1  2003/02/19 00:34:52  joko
26  ##  + initial commit, again refactored to this place  ##  + initial commit, again refactored to this place
27  ##  ##
# Line 26  Line 46 
46  ## ------------------------------------------------------------------------  ## ------------------------------------------------------------------------
47    
48    
49    =pod
50    
51      This is weird! Forget it.
52      But we depend on it!
53      Hmmm....
54    
55    
56    =cut
57    
58    
59  package DesignPattern::Logger;  package DesignPattern::Logger;
60    
61  use strict;  use strict;
# Line 38  use Log::Dispatch::Config; Line 68  use Log::Dispatch::Config;
68  use Cwd;  use Cwd;
69  use DesignPattern::Object;  use DesignPattern::Object;
70    
71    use vars qw(
72      $LEVEL_DEFAULT
73      $ENABLE_NAMESPACE
74      $NAMESPACE_LEVEL
75      $ENABLE_METHODS
76      $METHOD_LEVELS
77      $TRACE_STACK_LEVELS
78    );
79    
80    # default behaviour
81    $LEVEL_DEFAULT = 'debug';
82    $ENABLE_NAMESPACE = 1;
83    $NAMESPACE_LEVEL = undef;
84    $ENABLE_METHODS = 0;
85    $METHOD_LEVELS = [3];
86    $TRACE_STACK_LEVELS = [];
87    
88    
89  # TODO: review, revise and rewire this!  # TODO: review, revise and rewire this!
90  #my $logger = Log::Dispatch::Config->instance;  #my $logger = Log::Dispatch::Config->instance;
# Line 58  sub __init { Line 105  sub __init {
105    $self->{__logger}->{action} = $action;    $self->{__logger}->{action} = $action;
106    $self->{__logger}->{message} = $message;    $self->{__logger}->{message} = $message;
107    
108      # trace
109        #my $tmp = caller(2);
110        #print Dumper($tmp);
111        #exit;
112      
113    
114      # handle caller
115    
116        # determine class- and subroutinename of context calling us
117        # this task can be controlled by tuning its behaviour
118        # this can be changed by setting
119        #   DesignPattern::Logger::...
120        #   ...
121        #   ...
122        my $calling_class;
123        my $calling_sub;
124    
125    
126        # Default behaviour is:
127        #   Use classname from $self and suppress subroutine name.
128        #   In case of using this together with DesignPattern::Bridge,
129        #   the classnames of child objects are suppressed.
130        #   Instead, the classname of the parent container object
131        #   gets used *always*.
132          $calling_class = '';
133          $calling_sub = '';
134    
135          # Log class names (en-/disabled, take from specified level)
136          if ($ENABLE_NAMESPACE) {
137            $calling_class = ref $self;
138            if ($NAMESPACE_LEVEL) {
139              my @entry = caller($NAMESPACE_LEVEL);
140              $calling_class = $entry[0];
141            }
142          }
143    
144          # Log method names (en-/disabled, multi-level)
145          if ($ENABLE_METHODS) {
146            my @methods;
147            foreach (@{$METHOD_LEVELS}) {
148              (my $c_package, my $c_filename, my $c_line, my $c_subroutine, my $c_hasargs,
149              my $c_wantarray, my $c_evaltext, my $c_is_require, my $c_hints, my $c_bitmask) = caller($_);
150              $c_subroutine ||= '';
151              $c_subroutine =~ s/.*:://;
152              push @methods, $c_subroutine;
153            }
154            $calling_sub = join(': ', @methods) if @methods;
155          }
156      
157        
158    
159    # set default arguments    # set default arguments
160    $self->{__logger}->{classname} = ref $self;    $self->{__logger}->{classname} = $calling_class;
161      $self->{__logger}->{functionname} = $calling_sub;
162      # FIXME: deprecate this!
163    $self->{__logger}->{caller} = caller;    $self->{__logger}->{caller} = caller;
164        
165    # set default values    # set default values
166    $self->{__logger}->{action} ||= '';    $self->{__logger}->{action} ||= '';
167    $self->{__logger}->{options}->{tag} ||= '';    $self->{__logger}->{options}->{tag} ||= '';
168        
169      # FIXME: deprecate this!
170    #$self->{__logger}->{level} ||= 'info';    #$self->{__logger}->{level} ||= 'info';
171    $self->{__logger}->{level} ||= 'debug';    #$self->{__logger}->{level} ||= 'debug';
172      $self->{__logger}->{level} ||= $LEVEL_DEFAULT;
173    
174      # handle stacktrace
175        foreach (@$TRACE_STACK_LEVELS) {
176          #print "trace-level: ", $_, "\n";
177          #(my $c_package, my $c_filename, my $c_line, my $c_subroutine, my $c_hasargs,
178          #my $c_wantarray, my $c_evaltext, my $c_is_require, my $c_hints, my $c_bitmask) = caller($_);
179          my @entry = caller($_);
180          push @{$self->{__logger}->{trace}->{stack}}, \@entry;
181        }
182        
183  }  }
184    
# Line 84  sub __out { Line 195  sub __out {
195    #$logger->log( level => $self->{__logger}->{level}, message => $message );    #$logger->log( level => $self->{__logger}->{level}, message => $message );
196    #$logger->warning( __PACKAGE__ . "->_skip: '$caller' (mixed into '$classname'): ($options->{tag}) $message.");    #$logger->warning( __PACKAGE__ . "->_skip: '$caller' (mixed into '$classname'): ($options->{tag}) $message.");
197    #$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} );
198    $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} );
199      $self->{__logger}->{instance}->log( level => $self->{__logger}->{level}, message => $self->__get_prefix_best() . $self->{__logger}->{message} );
200  }  }
201    
202    
# Line 113  sub __get_prefix_module { Line 225  sub __get_prefix_module {
225  }  }
226    
227    
228    sub __get_prefix_best {
229      my $self = shift;
230      my $namespace = $self->{__logger}->{classname};
231      my $method = '';
232      my $tag_append = '';
233      #$namespace = $namespace . ": " if $namespace;
234      $method = "->" . $self->{__logger}->{functionname} if $self->{__logger}->{functionname};
235      #$method .= ': ' if $method;
236      $tag_append = "$self->{__logger}->{options}->{tag} - " if $self->{__logger}->{options}->{tag};
237      
238      my @line;
239      push @line, $namespace if $namespace;
240      push @line, $method if $method;
241      push @line, $tag_append if $tag_append;
242      
243      #print Dumper(@line);
244      
245      #return join(': ', @line);
246      my $result = join('', @line);
247      $result .= ': ' if $result;
248      
249      return $result;
250      
251    }
252    
253    
254  sub log {  sub log {
255    my $self = shift;    my $self = shift;
256    my $message = shift;    my $message = shift;
# Line 206  sub _configure_LogDispatch { Line 344  sub _configure_LogDispatch {
344    
345    my $configurator = DesignPattern::Object->fromPackage('Log::Dispatch::Configurator::Hardwired');    my $configurator = DesignPattern::Object->fromPackage('Log::Dispatch::Configurator::Hardwired');
346        
347    # FIXME?    # check if running inside a 'PROJECT' space
348    my $basepath = cwd() . '/..';    my $basepath = cwd();
349      my $postpone = '/..';
350      if (-d $basepath . $postpone . '/PROJECT') {
351        $basepath .= $postpone;
352        $basepath .= "/var/log";
353      }
354        
355    # configure custom logHandler    # configure custom logHandler
356        
357      if ($configurator) {      if ($configurator) {
358        
359        $configurator->{file_filename} = "$basepath/var/log/logfile.txt";        $configurator->{file_filename} = "$basepath/perl_app.log";
360        $configurator->{screen_min_level} = 'info';        $configurator->{screen_min_level} = 'info';
361                
362        if ($self->{quiet}) {        if ($self->{quiet}) {
# Line 224  sub _configure_LogDispatch { Line 367  sub _configure_LogDispatch {
367          $configurator->{screen_min_level} = 'debug';          $configurator->{screen_min_level} = 'debug';
368        }        }
369                
370        if ($self->{verbose}) {        if ($self->{LOG_VERBOSE}) {
371          $configurator->{verbose} = 1;          $configurator->{verbose} = 1;
372        }        }
373    
# Line 243  sub _configure_LogDispatch { Line 386  sub _configure_LogDispatch {
386    
387  }  }
388    
389    sub configure_logger {
390      my $self = shift;
391    
392      # automagically instantiate the object if not there
393      # TODO: do this by creating a dummy object inheriting from DesignPattern::Logger,
394      # for now this just don't work because which dummy one to take: Data::Code::Null?
395      if (! ref $self) {
396        $self = DesignPattern::Object->fromPackage('DesignPattern::Logger');
397      }
398    
399      #print "logconfig\n";
400      $self->_configure_LogDispatch();
401    }
402    
403    
404    
405    # for standalone use
406    sub new { my $class = shift; my $self = {}; bless $self, $class; }
407    
408    # convenient shortcuts
409    # FIXME: create these automagically by mungling with symbolic references
410    # or: make this object tied to recieve kinda events on method calls
411    
412    sub debug {
413      my $self = shift;
414      my $message = shift;
415      $self->log($message, 'debug');
416    }
417    
418    sub warning {
419      my $self = shift;
420      my $message = shift;
421      $self->log($message, 'warning');
422    }
423    
424    sub info {
425      my $self = shift;
426      my $message = shift;
427      $self->log($message, 'info');
428    }
429    
430    sub notice {
431      my $self = shift;
432      my $message = shift;
433      $self->log($message, 'notice');
434    }
435    
436    
437    
438    =pod
439    
440    =head1 TODO
441      
442      o $TRACE_STACK_LEVELS   (traces stack history)
443      o $ENABLE_DEBUG   (en-/disables level 'debug')
444      o $ENABLE_LOG   (en-/disables logging completely)
445    
446    
447    =cut
448    
449    
450  1;  1;
451  __END__  __END__
Legend:
Removed from v.1.1  
changed lines
  Added in v.1.6
MailToCvsAdmin">MailToCvsAdmin
 ViewVC Help
Powered by ViewVC 1.1.26 RSS 2.0 feed