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