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