src/logger.pl

   1 #
   2 # logger.pl: logger functions!
   3 #    Author: dms
   4 #   Version: v0.4 (20000923)
   5 #  FVersion: 19991205
   6 #      NOTE: Based on code by Kevin Lenzo & Patrick Cole  (c) 1997
   7 #
   8
   9 use strict;
  10 use utf8;
  11
  12 use vars qw($statcount $bot_pid $forkedtime $statcountfix $addressed);
  13 use vars qw($logDate $logold $logcount $logtime $logrepeat $running);
  14 use vars qw(@backlog);
  15 use vars qw(%param %file %cache);
  16
  17 $logtime   = time();
  18 $logcount  = 0;
  19 $logrepeat = 0;
  20 $logold    = '';
  21
  22 $param{VEBOSITY} ||= 1;    # lame fix for preload
  23
  24 my %attributes = (
  25     'clear'      => 0,
  26     'reset'      => 0,
  27     'bold'       => 1,
  28     'underline'  => 4,
  29     'underscore' => 4,
  30     'blink'      => 5,
  31     'reverse'    => 7,
  32     'concealed'  => 8,
  33     'black'      => 30,
  34     'on_black'   => 40,
  35     'red'        => 31,
  36     'on_red'     => 41,
  37     'green'      => 32,
  38     'on_green'   => 42,
  39     'yellow'     => 33,
  40     'on_yellow'  => 43,
  41     'blue'       => 34,
  42     'on_blue'    => 44,
  43     'magenta'    => 35,
  44     'on_magenta' => 45,
  45     'cyan'       => 36,
  46     'on_cyan'    => 46,
  47     'white'      => 37,
  48     'on_white'   => 47
  49 );
  50
  51 use vars qw($b_black $_black $b_red $_red $b_green $_green
  52   $b_yellow $_yellow $b_blue $_blue $b_magenta $_magenta
  53   $b_cyan $_cyan $b_white $_white $_reset $_bold $ob $b);
  54
  55 $b_black   = cl('bold black');
  56 $_black    = cl('black');
  57 $b_red     = cl('bold red');
  58 $_red      = cl('red');
  59 $b_green   = cl('bold green');
  60 $_green    = cl('green');
  61 $b_yellow  = cl('bold yellow');
  62 $_yellow   = cl('yellow');
  63 $b_blue    = cl('bold blue');
  64 $_blue     = cl('blue');
  65 $b_magenta = cl('bold magenta');
  66 $_magenta  = cl('magenta');
  67 $b_cyan    = cl('bold cyan');
  68 $_cyan     = cl('cyan');
  69 $b_white   = cl('bold white');
  70 $_white    = cl('white');
  71 $_reset    = cl('reset');
  72 $_bold     = cl('bold');
  73 $ob        = cl('reset');
  74 $b         = cl('bold');
  75
  76 ############################################################################
  77 # Implementation (attribute string form)
  78 ############################################################################
  79
  80 # Return the escape code for a given set of color attributes.
  81 sub cl {
  82     my @codes = map { split } @_;
  83     my $attribute = '';
  84     foreach (@codes) {
  85         $_ = lc $_;
  86         unless ( defined $attributes{$_} ) { die "Invalid attribute name $_" }
  87         $attribute .= $attributes{$_} . ';';
  88     }
  89     chop $attribute;
  90     ( $attribute ne '' ) ? "\e[${attribute}m" : undef;
  91 }
  92
  93 # logging support.
  94 sub openLog {
  95     binmode( STDOUT, ':encoding(UTF-8)' );
  96     return unless ( &IsParam('logfile') );
  97     $file{log} = $param{'logfile'};
  98
  99     my $error = 0;
 100     my $path  = &getPath( $file{log} );
 101     while ( !-d $path ) {
 102         if ($error) {
 103             &ERROR("openLog: failed opening log to $file{log}; disabling.");
 104             delete $param{'logfile'};
 105             return;
 106         }
 107
 108         &status("openLog: making $path.");
 109         last if ( mkdir $path, 0755 );
 110         $error++;
 111     }
 112
 113     if ( &IsParam('logType') and $param{'logType'} =~ /DAILY/i ) {
 114         my ( $day, $month, $year ) = ( gmtime time() )[ 3, 4, 5 ];
 115         my $logDir = $file{log} . sprintf('%04d', $year + 1900);
 116         unless(-d $logDir) {
 117             &status("openLog: making $logDir.");
 118             mkdir $logDir, 0755 or &status("Cannot mkdir $logDir");;
 119         }
 120         $logDate = sprintf('%04d/%02d%02d', $year + 1900, $month + 1, $day);
 121         $file{log} .= $logDate;
 122     }
 123
 124
 125     if ( open( LOG, ">>$file{log}" ) ) {
 126         binmode( LOG, ':encoding(UTF-8)' );
 127         &status("Opened logfile $file{log}.");
 128         LOG->autoflush(1);
 129     }
 130     else {
 131         &status("Cannot open logfile ($file{log}); not logging: $!");
 132     }
 133 }
 134
 135 sub closeLog {
 136
 137     # lame fix for paramlogfile.
 138     return unless ( &IsParam('logfile') );
 139     return unless ( defined fileno LOG );
 140
 141     close LOG;
 142     &status("Closed logfile ($file{log}).");
 143 }
 144
 145 #####
 146 # Usage: &processLog($file);
 147 sub processLog {
 148     my ($file) = @_;
 149     my @processLog = ( 'scripts/processlog', '/usr/bin/bzip2', '/bin/bzip2', '/bin/gzip' );
 150     my $okay = 0;
 151
 152     if ( !-f $file ) {
 153         &WARN("processLog: file ($file) does not exist.");
 154         return 0;
 155     }
 156
 157     if ( -f "$file.gz" or -f "$file.bz2" ) {
 158         &WARN('processLog: file.(gz|bz2) already exists.');
 159         return 0;
 160     }
 161
 162     foreach (@processLog) {
 163         next unless ( -x $_ );
 164
 165         &status("Processing log '$file' with $_.");
 166         system("$_ $file &");
 167         $okay++;
 168         last;
 169     }
 170
 171     if ( !$okay ) {
 172         &ERROR('no processLog program found.');
 173         return 0;
 174     }
 175
 176     return 1;
 177 }
 178
 179 sub DEBUG {
 180     return unless ( &IsParam('DEBUG') );
 181     my (undef,undef,$line,$subroutine,undef) = caller(1);
 182
 183     &status("${b_green}!DEBUG!$ob ".$subroutine.'['.$line."] $_[0]");
 184 }
 185
 186 sub ERROR {
 187     return unless ( &IsParam('DEBUG') );
 188     my (undef,undef,$line,$subroutine,undef) = caller(1);
 189
 190     &status("${b_red}!ERROR!$ob ".$subroutine.'['.$line."] $_[0]");
 191 }
 192
 193 sub WARN {
 194     return unless ( &IsParam('WARN') );
 195
 196     return if ( $_[0] =~ /^PERL: Subroutine \S+ redefined at/ );
 197
 198     my ($package,$filename,$line,$subroutine,undef) = caller(1);
 199
 200     &status("${b_yellow}!WARN!$ob ".$subroutine.'['.$line."] $_[0]");
 201 }
 202
 203 sub FIXME {
 204     my ($package,$filename,$line,$subroutine,undef) = caller(1);
 205
 206     &status("${b_cyan}!FIXME!$ob ".$subroutine.'['.$line."] $_[0]");
 207 }
 208
 209 sub TODO {
 210     my ($package,$filename,$line,$subroutine,undef) = caller(1);
 211
 212     &status("${b_cyan}!TODO!$ob ".$subroutine.'['.$line."] $_[0]");
 213 }
 214
 215 sub VERB {
 216     if ( !&IsParam('VERBOSITY') ) {
 217
 218         # NOTHING.
 219     }
 220     elsif ( $param{'VERBOSITY'} eq '1' and $_[1] <= 1 ) {
 221         &status( $_[0] );
 222     }
 223     elsif ( $param{'VERBOSITY'} eq '2' and $_[1] <= 2 ) {
 224         &status( $_[0] );
 225     }
 226 }
 227
 228 sub status {
 229     my ($input) = @_;
 230     my $status;
 231
 232     if ( $input =~ /PERL: Use of uninitialized/ ) {
 233         &debug_perl($input);
 234         return;
 235     }
 236
 237     if ( $input eq $logold ) {
 238         $logrepeat++;
 239         return;
 240     }
 241
 242     $logold = $input;
 243
 244     # if only I had followed how sysklogd does it, heh. lame me. -xk
 245     if ( $logrepeat >= 3 ) {
 246         &status("LOG: last message repeated $logrepeat times");
 247         $logrepeat = 0;
 248     }
 249
 250     # if it's not a scalar, attempt to warn and fix.
 251     my $ref = ref $input;
 252     if ( defined $ref and $ref ne '' ) {
 253         &WARN("status: 'input' is not scalar ($ref).");
 254
 255         if ( $ref eq 'ARRAY' ) {
 256             foreach (@$input) {
 257                 &WARN("status: '$_'.");
 258             }
 259         }
 260     }
 261
 262     # Something is using this w/ NULL.
 263     if ( !defined $input or $input =~ /^\s*$/ ) {
 264         $input = 'ERROR: Blank status call? HELP HELP HELP';
 265     }
 266
 267     for ($input) {
 268         s/\n+$//;
 269         s/\002|\037//g;    # bold,video,underline => remove.
 270     }
 271
 272     # does this work?
 273     if ( $input =~ /\n/ ) {
 274         foreach ( split /\n/, $input ) {
 275             &status($_);
 276         }
 277     }
 278
 279     # pump up the stats.
 280     $statcount++;
 281
 282     # fix style of output if process is child.
 283     if ( defined $bot_pid and $$ != $bot_pid and !defined $statcountfix ) {
 284         $statcount    = 1;
 285         $statcountfix = 1;
 286     }
 287
 288     ### LOG THROTTLING.
 289     ### TODO: move this _after_ printing?
 290     my $time  = time();
 291     my $reset = 0;
 292
 293     # hrm... what is this supposed to achieve? nothing I guess.
 294     if ( $logtime == $time ) {
 295         if ( $logcount < 25 ) {    # too high?
 296             $logcount++;
 297         }
 298         else {
 299             sleep 1;
 300             &status('LOG: Throttling.');
 301             $reset++;
 302         }
 303     }
 304     else {                         # $logtime != $time.
 305         $reset++;
 306     }
 307
 308     if ($reset) {
 309         $logtime  = $time;
 310         $logcount = 0;
 311     }
 312
 313     # Log differently for forked/non-forked output.
 314     if ($statcountfix) {
 315         $status = "!$statcount! " . $input;
 316         if ( $statcount > 1000 ) {
 317             print LOG "ERROR: FORKED PROCESS RAN AWAY; KILLING.\n";
 318             print LOG 'VERB: ' . ( &Time2String( $time - $forkedtime ) ) . "\n";
 319             exit 0;
 320         }
 321     }
 322     else {
 323         $status = "[$statcount] " . $input;
 324     }
 325
 326     if ( &IsParam('backlog') ) {
 327         push( @backlog, $status );    # append to end.
 328         shift(@backlog) if ( scalar @backlog > $param{'backlog'} );
 329     }
 330
 331     if ( &IsParam('VERBOSITY') ) {
 332         if ($statcountfix) {
 333             printf $_red. '!%6d!' . $ob . ' ', $statcount;
 334         }
 335         else {
 336             printf $_green. '[%6d]' . $ob . ' ', $statcount;
 337         }
 338
 339         # three uberstabs to Derek Moeller. I don't remember why but he
 340         # deserved it :)
 341         my $printable = $input;
 342
 343         if ( $printable =~ s/^(<\/\S+>) // ) {
 344
 345             # it's me saying something on a channel
 346             my $name = $1;
 347             print "$b_yellow$name $printable$ob\n";
 348         }
 349         elsif ( $printable =~ s/^(<\S+>) // ) {
 350
 351             # public message on channel.
 352             my $name = $1;
 353
 354             if ($addressed) {
 355                 print "$b_red$name $printable$ob\n";
 356             }
 357             else {
 358                 print "$b_cyan$name$ob $printable$ob\n";
 359             }
 360
 361         }
 362         elsif ( $printable =~ s/^\* (\S+)\/(\S+) // ) {
 363
 364             # public action.
 365             print "$b_white*$ob $b_cyan$1$ob/$b_blue$2$ob $printable\n";
 366
 367         }
 368         elsif ( $printable =~ s/^(-\S+-) // ) {
 369
 370             # notice
 371             print "$_green$1 $printable$ob\n";
 372
 373         }
 374         elsif ( $printable =~ s/^(\* )?(\[\S+\]) // ) {
 375
 376             # message/private action from someone
 377             print "$b_white$1$ob" if ( defined $1 );
 378             print "$b_red$2 $printable$ob\n";
 379
 380         }
 381         elsif ( $printable =~ s/^(>\S+<) // ) {
 382
 383             # i'm messaging someone
 384             print "$b_magenta$1 $printable$ob\n";
 385
 386         }
 387         elsif ( $printable =~ s/^(enter:|update:|forget:) // ) {
 388
 389             # something that should be SEEN
 390             print "$b_green$1 $printable$ob\n";
 391
 392         }
 393         else {
 394             print "$printable\n";
 395         }
 396
 397     }
 398     else {
 399
 400         #print "VERBOSITY IS OFF?\n";
 401     }
 402
 403     # log the line into a file.
 404     return unless ( &IsParam('logfile') );
 405     return unless ( defined fileno LOG );
 406
 407     # remove control characters from logging to LOGFILE.
 408     for ($input) {
 409         last if ( &IsParam('logColors') );
 410         s/\e\[[0-9;]+m//g;    # escape codes.
 411         s/[\cA-\c_]//g;       # control chars.
 412     }
 413     $input = "FORK($$) " . $input if ($statcountfix);
 414
 415     my $date;
 416     if ( &IsParam('logType') and $param{'logType'} =~ /DAILY/i ) {
 417         $date = sprintf( '%02d:%02d.%02d', ( gmtime $time )[ 2, 1, 0 ] );
 418
 419         my ( $day, $month, $year ) = ( gmtime $time )[ 3, 4, 5 ];
 420         my $newlogDate =
 421           sprintf( '%04d/%02d%02d', $year + 1900, $month + 1, $day );
 422         if ( defined $logDate and $newlogDate ne $logDate ) {
 423             &closeLog();
 424             &processLog( $file{log} );
 425             &openLog();
 426         }
 427     }
 428     else {
 429         $date = $time;
 430     }
 431
 432     printf LOG "%s %s\n", $date, $input;
 433 }
 434
 435 sub debug_perl {
 436     my ($str) = @_;
 437
 438     return
 439       unless (
 440         $str =~ /^WARN: Use of uninitialized value .* at (\S+) line (\d+)/ );
 441     my ( $file, $line ) = ( $1, $2 );
 442     if ( !open( IN, $file ) ) {
 443         &status("WARN: cannot open $file: $!");
 444         return;
 445     }
 446     binmode( IN, ':encoding(UTF-8)' );
 447
 448     # TODO: better filename.
 449     open( OUT, '>>debug.log' );
 450     binmode( OUT, ':encoding(UTF-8)' );
 451     print OUT "DEBUG: $str\n";
 452
 453     # note: cannot call external functions because SIG{} does not allow us to.
 454     my $i;
 455     while (<IN>) {
 456         chop;
 457         $i++;
 458
 459         # bleh. this tries to duplicate status().
 460         # TODO: statcountfix
 461         # TODO: rename to log_*someshit*
 462         if ( $i == $line ) {
 463             my $msg = "$file: $i:!$_";
 464             printf "%s[%6d]%s %s\n", $_green, $statcount, $ob, $msg;
 465             print OUT "DEBUG: $msg\n";
 466             $statcount++;
 467             next;
 468         }
 469         if ( $i + 3 > $line && $i - 3 < $line ) {
 470             my $msg = "$file: $i: $_";
 471             printf "%s[%6d]%s %s\n", $_green, $statcount, $ob, $msg;
 472             print OUT "DEBUG: $msg\n";
 473             $statcount++;
 474         }
 475     }
 476     close IN;
 477     close OUT;
 478 }
 479
 480 sub openSQLDebug {
 481     if ( !open( SQLDEBUG, ">>$param{'SQLDebug'}" ) ) {
 482         &ERROR("Cannot open ($param{'SQLDebug'}): $!");
 483         delete $param{'SQLDebug'};
 484         return 0;
 485     }
 486     binmode( SQLDEBUG, ':encoding(UTF-8)' );
 487
 488     &status("Opened SQL Debug file: $param{'SQLDebug'}");
 489     return 1;
 490 }
 491
 492 sub closeSQLDebug {
 493     close SQLDEBUG;
 494
 495     &status("Closed SQL Debug file: $param{'SQLDebug'}");
 496 }
 497
 498 sub SQLDebug {
 499     return unless ( &IsParam('SQLDebug') );
 500
 501     return unless ( fileno SQLDEBUG );
 502
 503     print SQLDEBUG $_[0] . "\n";
 504 }
 505
 506 1;
 507
 508 # vim:ts=4:sw=4:expandtab:tw=80