1 package OpenSRF::Utils::Logger;
3 use vars qw($AUTOLOAD @EXPORT_OK %EXPORT_TAGS);
5 use base qw/OpenSRF Exporter/;
7 use Time::HiRes qw(gettimeofday);
8 use OpenSRF::Utils::Config;
11 @EXPORT_OK = qw/ NONE ERROR WARN INFO DEBUG INTERNAL /;
13 %EXPORT_TAGS = ( level => [ qw/ NONE ERROR WARN INFO DEBUG INTERNAL / ] );
15 # XXX Update documentation
19 OpenSRF::Utils::Logger
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
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:
42 All others are logged to INFO by default.
44 You write to a log by calling the log's method.
46 use OpenSRF::Utils::Logger qw(:level);
48 my $logger = "OpenSRF::Utils::Logger";
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" );
54 will only write the time, line number, and file that the method was called from.
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.
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.
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
77 my $remote_logging = 0;
79 my $LEVEL = "OpenSRF::Utils::LogLevel";
80 my $FILE = "OpenSRF::Utils::LogFile";
82 # --- Log levels - values and names
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 " );
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; }
101 # Known log files and their default log levels
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 ),
113 # ---------------------------------------------------------
117 sub global_llevel { return $global_llevel; }
121 $config = OpenSRF::Utils::Config->current;
123 if( defined($config) ) {
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;
133 $global_llevel = &{$global_llevel};
135 #$trace_active = $config->system->trace;
140 $global_llevel = DEBUG;
141 warn "*** Logger found no suitable config. Using STDERR ***\n";
146 sub build_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;
154 # ---------------------------------------------------------
159 my( $self, $string, $llevel ) = @_;
161 $log =~ s/.*://; # strip fully-qualified portion
163 unless( defined($config) or global_llevel() ) {
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.
180 if( global_llevel()->level == NONE->level ) { return; }
182 my( $class, $string, $llevel ) = @_;
184 # see if we can return
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);
191 else { # see if there is a default llevel, set to INFO if not.
193 foreach my $l ( @$known_logs ) {
194 if( $l->name eq $log ) { $log_obj = $l and last; }
196 if( $log_obj ) { $llevel = $log_obj->def_level; }
197 else { $llevel = INFO; }
201 # again, see if we can get out of this
202 return if ($llevel->level > global_llevel()->level);
204 my @caller = caller();
205 push( @caller, (caller(1))[3] );
207 # In the absense of a config, we write to STDERR
209 if( ! defined($config) ) {
210 _write_stderr( $string, $llevel->name, @caller);
214 if( $remote_logging ) {
215 _write_net( $log, $string, $llevel->name, @caller );
217 } elsif ( my $file = $file_hash->{$log} ) {
218 _write_local( $file, $string, $llevel->name, @caller );
221 _write_stderr( $string, $llevel->name, @caller);
225 if( $llevel->name eq ERROR->name ) { # send all error to stderr
226 _write_stderr( $string, $llevel->name, @caller);
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 );
239 $self->$log( $string, $llevel );
243 # write_net expects a log_type_name and not a log_file_name for the first parameter
249 my( $log, $string, $llevel, @caller ) = @_;
250 my( $pack, $file, $line_no ) = @caller;
251 my @lines = split( "\n", $string );
253 my $message = "$log|"."-" x 33 .
254 "\n$log|[$0 $llevel] $line_no $pack".
255 "\n$log|[$0 $llevel] $file";
257 foreach my $line (@lines) {
258 $message .= "\n$log|[$0 $llevel] $line";
261 $net_buffer .= "$message\n";
263 # every 4th load is sent on the socket
264 if( $counter++ % 4 ) { return; }
267 $socket = IO::Socket::INET->new(
271 or die "Unable to open socket to log server";
274 $socket->send( $net_buffer );
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";
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";
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;
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 );
328 while( length( $proc ) < 5 ) { $proc = "0" . "$proc"; }
329 return "[$year-$mon-$day $hour:$min:$sec.$ms $proc]";
333 # ----------------------------------------------
334 # --- Models a log level
335 package OpenSRF::Utils::LogLevel;
337 sub new { return bless( [ $_[1], $_[2] ], $_[0] ); }
339 sub level { return $_[0]->[0]; }
340 sub name { return $_[0]->[1]; }
342 # ----------------------------------------------
344 package OpenSRF::Utils::LogFile;
345 use OpenSRF::Utils::Config;
347 sub new{ return bless( [ $_[1], $_[2] ], $_[0] ); }
349 sub name { return $_[0]->[0]; }
350 sub def_level { return $_[0]->[1]; }
353 # ----------------------------------------------