Initial revision
[OpenSRF.git] / src / perlmods / OpenSRF / Utils / Logger.pm
1 package OpenSRF::Utils::Logger;
2 use strict;
3 use vars qw($AUTOLOAD @EXPORT_OK %EXPORT_TAGS);
4 use Exporter;
5 use base qw/OpenSRF Exporter/;
6 use FileHandle;
7 use Time::HiRes qw(gettimeofday);
8 use OpenSRF::Utils::Config;
9 use Fcntl;
10
11 @EXPORT_OK = qw/ NONE ERROR WARN INFO DEBUG INTERNAL /;
12
13 %EXPORT_TAGS = ( level => [ qw/ NONE ERROR WARN INFO DEBUG INTERNAL / ] );
14
15 # XXX Update documentation
16
17 =head1 Description
18
19 OpenSRF::Utils::Logger
20
21 General purpose logging package.  The logger searches $config->logs->$log_name for the 
22 actual file to log to.  Any file in the config may be logged to.  If the user attempts to 
23 log to a log file that does not exist within the config, then the messages will to 
24 to STDERR.  
25
26 There are also a set of predefined log levels.  Currently they are
27 NONE, ERROR, WARN, INFO, DEBUG, INTERNAL, and ALL.  You can select one of these log levels
28 when you send messages to the logger.  The message will be logged if it is of equal or greater
29 'importance' than the global log level, found at $config->system->debug.  If you don't specify
30 a log level, a defaul will be provided.  Current defaults are:
31
32 error                   -> ERROR
33
34 debug                   -> DEBUG
35
36 transport       -> INTERNAL
37
38 message         -> INFO
39
40 method          -> INFO
41
42 All others are logged to INFO by default.
43
44 You write to a log by calling the log's method.  
45
46 use OpenSRF::Utils::Logger qw(:level);
47
48 my $logger = "OpenSRF::Utils::Logger";
49
50 $logger->debug( "degug message" );
51 $logger->transport( "debug message", DEBUG );
52 $logger->blahalb( "I'll likely end up at STDERR with a log level of INFO" );
53
54 will only write the time, line number, and file that the method was called from.
55
56 Note also that all messages with a log level of ERROR are written to the "error" log
57 in addition to the intended log file.
58
59 =cut
60
61 # Just set this first and not during every call to the logger
62 # XXX this should be added to the sig{hup} handler once it exists.
63
64
65 ##############
66 #   1. check config, if file exists write to that file locally
67 #       2. If not in config and set to remote, send to socket.  if not remote log to stderr
68
69 my $config; 
70 my $file_hash;
71 my $trace_active = 0;
72
73 my $port;
74 my $proto;
75 my $peer;
76 my $socket;
77 my $remote_logging = 0;
78
79 my $LEVEL = "OpenSRF::Utils::LogLevel";
80 my $FILE        = "OpenSRF::Utils::LogFile";
81
82 # --- Log levels - values and names
83
84 my $none                        = $LEVEL->new( 1,               "NONE" ); 
85 my $error               = $LEVEL->new( 10,      "ERRR" ); 
86 my $warn                        = $LEVEL->new( 20,      "WARN" ); 
87 my $info                        = $LEVEL->new( 30,      "INFO" );
88 my $debug               = $LEVEL->new( 40,      "DEBG" );
89 my $internal    = $LEVEL->new( 50,      "INTL" );
90 my $all                 = $LEVEL->new( 100,     "ALL " );
91
92
93 sub NONE                        { return $none; } 
94 sub ERROR               { return $error;        } 
95 sub WARN                        { return $warn; } 
96 sub INFO                        { return $info; } 
97 sub DEBUG               { return $debug;        } 
98 sub INTERNAL    { return $internal; }
99 sub ALL                 { return $all;          }
100
101 # Known log files and their default log levels
102 my $known_logs = [
103         $FILE->new( "error",            &ERROR ),
104         $FILE->new( "debug",            &DEBUG ),
105         $FILE->new( "transport",&INTERNAL ),
106         $FILE->new( "message",  &INFO ),
107         $FILE->new( "method",   &INFO ),
108         ];
109
110
111
112
113 # ---------------------------------------------------------
114
115 {
116         my $global_llevel;
117         sub global_llevel { return $global_llevel; }
118
119         sub set_config {
120
121                 $config = OpenSRF::Utils::Config->current;
122
123                 if( defined($config) ) { 
124
125                         $global_llevel =  $config->system->debug; 
126                         $port = $config->system->log_port;
127                         $proto = $config->system->log_proto;
128                         $peer = $config->system->log_server;
129                         $remote_logging = $config->system->remote_log;
130
131                         {
132                                 no strict "refs";
133                                 $global_llevel = &{$global_llevel};
134                         }
135                         #$trace_active = $config->system->trace;
136                         build_file_hash();
137                 }
138
139                 else { 
140                         $global_llevel = DEBUG; 
141                         warn "*** Logger found no suitable config.  Using STDERR ***\n";
142                 }
143         }
144 }
145
146 sub build_file_hash { 
147         $file_hash = {};
148         # XXX This breaks Config encapsulation and should be cleaned.
149         foreach my $log ( grep { !($_ =~ /__id/) } (keys %{$config->logs}) ) {
150                 $file_hash->{$log} = $config->logs->$log;
151         }
152 }
153
154 # ---------------------------------------------------------
155
156 sub AUTOLOAD {
157
158
159         my( $self, $string, $llevel ) = @_;
160         my $log         = $AUTOLOAD;
161         $log                    =~ s/.*://;   # strip fully-qualified portion
162
163         unless( defined($config) or global_llevel() ) {
164                 set_config();
165         }
166
167         # Build the sub here so we can use the enclosed $log variable.
168         # This is some weird Perl s*** that only satan could dream up.
169         # We mangle the symbol table so that future calls to $logger->blah
170         # will no longer require the autoload.  
171         # The $log variable (above) will contain the name of the log 
172         # log file the user is attempting to log to.  This is true, however,  
173         # even though the above code is presumably run only the first time
174         # the call to $logger->blah is made.  
175
176         no strict "refs";
177
178         *{$log} = sub { 
179
180                 if( global_llevel()->level == NONE->level ) { return; }
181
182                 my( $class, $string, $llevel ) = @_;
183
184                 # see if we can return
185                 if( $llevel ) { 
186                         # if level is passed in as a string, cast it to a level object
187                         ref( $llevel ) || do{ $llevel = &{$llevel} };
188                         return if ($llevel->level > global_llevel()->level); 
189                 }
190
191                 else { # see if there is a default llevel, set to INFO if not.
192                         my $log_obj;
193                         foreach my $l ( @$known_logs ) {
194                                 if( $l->name eq $log ) { $log_obj = $l and last; }
195                         }
196                         if( $log_obj ) { $llevel = $log_obj->def_level; }
197                         else { $llevel = INFO; }
198                 }
199
200
201                 # again, see if we can get out of this 
202                 return if ($llevel->level > global_llevel()->level); 
203         
204                 my @caller = caller();
205                 push( @caller, (caller(1))[3] );
206
207                 # In the absense of a config, we write to STDERR
208
209                 if( ! defined($config)  ) { 
210                         _write_stderr( $string, $llevel->name, @caller); 
211                         return;
212                 }
213
214                 if( $remote_logging ) {
215                         _write_net( $log, $string, $llevel->name, @caller );
216                 
217                 } elsif ( my $file = $file_hash->{$log} ) {
218                         _write_local( $file, $string, $llevel->name, @caller );
219
220                 } else {
221                         _write_stderr( $string, $llevel->name, @caller); 
222                 }
223
224         
225                 if( $llevel->name eq ERROR->name ) { # send all error to stderr
226                         _write_stderr( $string, $llevel->name, @caller); 
227                 }
228
229                 if( $llevel->name eq ERROR->name and $log ne "error" ) {
230                         if( my $e_file = $file_hash->{"error"}  ) {
231                                 if( ! $remote_logging ) {
232                                         _write_local( $e_file, $string, $llevel->name, @caller );
233                                 }
234                         }
235                 }
236         
237         };
238         
239         $self->$log( $string, $llevel );
240 }
241
242
243 # write_net expects a log_type_name and not a log_file_name for the first parameter
244 my $net_buffer = "";
245 my $counter = 0;
246 sub _write_net {
247
248
249         my( $log, $string, $llevel, @caller ) = @_;
250         my( $pack, $file, $line_no ) = @caller;
251         my @lines = split( "\n", $string );
252
253         my $message = "$log|"."-" x 33 . 
254                 "\n$log|[$0 $llevel] $line_no $pack".
255                 "\n$log|[$0 $llevel] $file";
256
257         foreach my $line (@lines) {
258                 $message .= "\n$log|[$0 $llevel] $line";
259         }
260
261         $net_buffer .= "$message\n";
262
263         # every 4th load is sent on the socket
264         if( $counter++ % 4 ) { return; }
265
266         unless( $socket ) {
267                 $socket = IO::Socket::INET->new(
268                                 PeerAddr        => $peer,
269                                 PeerPort        => $port,
270                                 Proto           => $proto )
271                         or die "Unable to open socket to log server";  
272         }
273
274         $socket->send( $net_buffer );
275         $net_buffer = "";
276
277 }
278
279 sub _write_local {
280
281         my( $log, $string, $llevel, @caller ) = @_;
282         my( $pack, $file, $line_no ) = @caller;
283         my @lines = split( "\n", $string );
284         my $time = format_time();
285         sysopen( SINK, $log, O_NONBLOCK|O_WRONLY|O_APPEND|O_CREAT ) 
286                 or die "Cannot sysopen $log: $!";
287         binmode(SINK, ':utf8');
288         print SINK "-" x 23 . "\n";
289         print SINK "$time [$0 $llevel] $line_no $pack \n";
290         print SINK "$time [$0 $llevel] $file\n";
291         foreach my $line (@lines) {
292                 print SINK "$time [$0 $llevel] $line\n";
293         }
294         close( SINK );
295
296 }
297
298 sub _write_stderr {
299         my( $string, $llevel, @caller ) = @_;
300         my( $pack, $file, $line_no ) = @caller;
301         my @lines = split( "\n", $string );
302         my $time = format_time();
303         print STDERR "-" x 23 . "\n";
304         print STDERR "$time [$0 $llevel] $line_no $pack\n";
305         print STDERR "$time [$0 $llevel] $file\n";
306         foreach my $line (@lines) {
307                 print STDERR "$time [$0 $llevel] $line\n";
308         }
309 }
310
311 sub format_time {
312         my ($s, $ms) = gettimeofday();
313         my @time = localtime( $s );
314         $ms = substr( $ms, 0, 3 );
315         my $year = $time[5] + 1900;
316         my $mon = $time[4] + 1;
317         my $day = $time[3];
318         my $hour = $time[2];
319         my $min = $time[1];
320         my $sec = $time[0];
321         $mon = "0" . "$mon" if ( length($mon) == 1 );
322         $day = "0" . "$day" if ( length($day) == 1 );
323         $hour = "0" . "$hour" if ( length($hour) == 1 );
324         $min = "0" . "$min" if (length($min) == 1 );
325         $sec = "0" . "$sec" if (length($sec) == 1 );
326
327         my $proc = $$;
328         while( length( $proc ) < 5 ) { $proc = "0" . "$proc"; }
329         return "[$year-$mon-$day $hour:$min:$sec.$ms $proc]";
330 }
331
332
333 # ----------------------------------------------
334 # --- Models a log level
335 package OpenSRF::Utils::LogLevel;
336
337 sub new { return bless( [ $_[1], $_[2] ], $_[0] ); }
338
339 sub level { return $_[0]->[0]; }
340 sub name        { return $_[0]->[1]; }
341
342 # ----------------------------------------------
343
344 package OpenSRF::Utils::LogFile;
345 use OpenSRF::Utils::Config;
346
347 sub new{ return bless( [ $_[1], $_[2] ], $_[0] ); }
348
349 sub name { return $_[0]->[0]; }
350 sub def_level { return $_[0]->[1]; }
351
352
353 # ----------------------------------------------
354
355 1;