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