OpenSRF/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;