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->bootstrap->debug;
 126                         $port = "";
 127                         $proto = "";
 128                         $peer = "";
 129                         $remote_logging = 0;
 130
 131                         {
 132                                 no strict "refs";
 133                                 $global_llevel = &{$global_llevel};
 134                         }
 135                         build_file_hash();
 136                 }
 137
 138                 else {
 139                         $global_llevel = DEBUG;
 140                         warn "*** Logger found no suitable config.  Using STDERR ***\n";
 141                 }
 142         }
 143 }
 144
 145 sub build_file_hash {
 146         $file_hash = {};
 147         my $path = $config->bootstrap->log_dir;
 148         $file_hash->{"error"} = join("/",$path,$config->logs->error);
 149         $file_hash->{"transport"} = join("/",$path,$config->logs->transport);
 150         $file_hash->{"debug"} = join("/",$path,$config->logs->debug);
 151 }
 152
 153 # ---------------------------------------------------------
 154
 155 sub AUTOLOAD {
 156
 157
 158         my( $self, $string, $llevel ) = @_;
 159         my $log         = $AUTOLOAD;
 160         $log                    =~ s/.*://;   # strip fully-qualified portion
 161
 162         unless( defined($config) or global_llevel() ) {
 163                 set_config();
 164         }
 165
 166         # Build the sub here so we can use the enclosed $log variable.
 167         # This is some weird Perl s*** that only satan could dream up.
 168         # We mangle the symbol table so that future calls to $logger->blah
 169         # will no longer require the autoload.
 170         # The $log variable (above) will contain the name of the log
 171         # log file the user is attempting to log to.  This is true, however,
 172         # even though the above code is presumably run only the first time
 173         # the call to $logger->blah is made.
 174
 175         no strict "refs";
 176
 177         *{$log} = sub {
 178
 179                 if( global_llevel()->level == NONE->level ) { return; }
 180
 181                 my( $class, $string, $llevel ) = @_;
 182
 183                 # see if we can return
 184                 if( $llevel ) {
 185                         # if level is passed in as a string, cast it to a level object
 186                         ref( $llevel ) || do{ $llevel = &{$llevel} };
 187                         return if ($llevel->level > global_llevel()->level);
 188                 }
 189
 190                 else { # see if there is a default llevel, set to INFO if not.
 191                         my $log_obj;
 192                         foreach my $l ( @$known_logs ) {
 193                                 if( $l->name eq $log ) { $log_obj = $l and last; }
 194                         }
 195                         if( $log_obj ) { $llevel = $log_obj->def_level; }
 196                         else { $llevel = INFO; }
 197                 }
 198
 199
 200                 # again, see if we can get out of this
 201                 return if ($llevel->level > global_llevel()->level);
 202
 203                 my @caller = caller();
 204                 push( @caller, (caller(1))[3] );
 205
 206                 # In the absense of a config, we write to STDERR
 207
 208                 if( ! defined($config)  ) {
 209                         _write_stderr( $string, $llevel->name, @caller);
 210                         return;
 211                 }
 212
 213                 if( $remote_logging ) {
 214                         _write_net( $log, $string, $llevel->name, @caller );
 215
 216                 } elsif ( my $file = $file_hash->{$log} ) {
 217                         _write_local( $file, $string, $llevel->name, @caller );
 218
 219                 } else {
 220                         _write_stderr( $string, $llevel->name, @caller);
 221                 }
 222
 223
 224                 if( $llevel->name eq ERROR->name ) { # send all error to stderr
 225                         _write_stderr( $string, $llevel->name, @caller);
 226                 }
 227
 228                 if( $llevel->name eq ERROR->name and $log ne "error" ) {
 229                         if( my $e_file = $file_hash->{"error"}  ) {
 230                                 if( ! $remote_logging ) {
 231                                         _write_local( $e_file, $string, $llevel->name, @caller );
 232                                 }
 233                         }
 234                 }
 235
 236         };
 237
 238         $self->$log( $string, $llevel );
 239 }
 240
 241
 242 # write_net expects a log_type_name and not a log_file_name for the first parameter
 243 my $net_buffer = "";
 244 my $counter = 0;
 245 sub _write_net {
 246
 247
 248         my( $log, $string, $llevel, @caller ) = @_;
 249         my( $pack, $file, $line_no ) = @caller;
 250         my @lines = split( "\n", $string );
 251
 252         my $message = "$log|"."-" x 33 .
 253                 "\n$log|[$0 $llevel] $line_no $pack".
 254                 "\n$log|[$0 $llevel] $file";
 255
 256         foreach my $line (@lines) {
 257                 $message .= "\n$log|[$0 $llevel] $line";
 258         }
 259
 260         $net_buffer .= "$message\n";
 261
 262         # every 4th load is sent on the socket
 263         if( $counter++ % 4 ) { return; }
 264
 265         unless( $socket ) {
 266                 $socket = IO::Socket::INET->new(
 267                                 PeerAddr        => $peer,
 268                                 PeerPort        => $port,
 269                                 Proto           => $proto )
 270                         or die "Unable to open socket to log server";
 271         }
 272
 273         $socket->send( $net_buffer );
 274         $net_buffer = "";
 275
 276 }
 277
 278 sub _write_local {
 279
 280         my( $log, $string, $llevel, @caller ) = @_;
 281         my( $pack, $file, $line_no ) = @caller;
 282         my @lines = split( "\n", $string );
 283         my $time = format_time();
 284         sysopen( SINK, $log, O_NONBLOCK|O_WRONLY|O_APPEND|O_CREAT )
 285                 or die "Cannot sysopen $log: $!";
 286         binmode(SINK, ':utf8');
 287         print SINK "-" x 23 . "\n";
 288         print SINK "$time [$0 $llevel] $line_no $pack \n";
 289         print SINK "$time [$0 $llevel] $file\n";
 290         foreach my $line (@lines) {
 291                 print SINK "$time [$0 $llevel] $line\n";
 292         }
 293         close( SINK );
 294
 295 }
 296
 297 sub _write_stderr {
 298         my( $string, $llevel, @caller ) = @_;
 299         my( $pack, $file, $line_no ) = @caller;
 300         my @lines = split( "\n", $string );
 301         my $time = format_time();
 302         print STDERR "-" x 23 . "\n";
 303         print STDERR "$time [$0 $llevel] $line_no $pack\n";
 304         print STDERR "$time [$0 $llevel] $file\n";
 305         foreach my $line (@lines) {
 306                 print STDERR "$time [$0 $llevel] $line\n";
 307         }
 308 }
 309
 310 sub format_time {
 311         my ($s, $ms) = gettimeofday();
 312         my @time = localtime( $s );
 313         $ms = substr( $ms, 0, 3 );
 314         my $year = $time[5] + 1900;
 315         my $mon = $time[4] + 1;
 316         my $day = $time[3];
 317         my $hour = $time[2];
 318         my $min = $time[1];
 319         my $sec = $time[0];
 320         $mon = "0" . "$mon" if ( length($mon) == 1 );
 321         $day = "0" . "$day" if ( length($day) == 1 );
 322         $hour = "0" . "$hour" if ( length($hour) == 1 );
 323         $min = "0" . "$min" if (length($min) == 1 );
 324         $sec = "0" . "$sec" if (length($sec) == 1 );
 325
 326         my $proc = $$;
 327         while( length( $proc ) < 5 ) { $proc = "0" . "$proc"; }
 328         return "[$year-$mon-$day $hour:$min:$sec.$ms $proc]";
 329 }
 330
 331
 332 # ----------------------------------------------
 333 # --- Models a log level
 334 package OpenSRF::Utils::LogLevel;
 335
 336 sub new { return bless( [ $_[1], $_[2] ], $_[0] ); }
 337
 338 sub level { return $_[0]->[0]; }
 339 sub name        { return $_[0]->[1]; }
 340
 341 # ----------------------------------------------
 342
 343 package OpenSRF::Utils::LogFile;
 344 use OpenSRF::Utils::Config;
 345
 346 sub new{ return bless( [ $_[1], $_[2] ], $_[0] ); }
 347
 348 sub name { return $_[0]->[0]; }
 349 sub def_level { return $_[0]->[1]; }
 350
 351
 352 # ----------------------------------------------
 353
 354 1;