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