2 # logger.pl: logger functions!
4 # Version: v0.4 (20000923)
6 # NOTE: Based on code by Kevin Lenzo & Patrick Cole (c) 1997
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);
22 $param{VEBOSITY} ||= 1; # lame fix for preload
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);
55 $b_black = cl('bold black');
56 $_black = cl('black');
57 $b_red = cl('bold 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');
65 $b_magenta = cl('bold magenta');
66 $_magenta = cl('magenta');
67 $b_cyan = cl('bold cyan');
69 $b_white = cl('bold white');
70 $_white = cl('white');
71 $_reset = cl('reset');
76 ############################################################################
77 # Implementation (attribute string form)
78 ############################################################################
80 # Return the escape code for a given set of color attributes.
82 my @codes = map { split } @_;
86 unless ( defined $attributes{$_} ) { die "Invalid attribute name $_" }
87 $attribute .= $attributes{$_} . ';';
90 ( $attribute ne '' ) ? "\e[${attribute}m" : undef;
95 binmode( STDOUT, ':encoding(UTF-8)' );
96 return unless ( &IsParam('logfile') );
97 $file{log} = $param{'logfile'};
100 my $path = &getPath( $file{log} );
101 while ( !-d $path ) {
103 &ERROR("openLog: failed opening log to $file{log}; disabling.");
104 delete $param{'logfile'};
108 &status("openLog: making $path.");
109 last if ( mkdir $path, 0755 );
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);
117 &status("openLog: making $logDir.");
118 mkdir $logDir, 0755 or &status("Cannot mkdir $logDir");;
120 $logDate = sprintf('%04d/%02d%02d', $year + 1900, $month + 1, $day);
121 $file{log} .= $logDate;
125 if ( open( LOG, ">>$file{log}" ) ) {
126 binmode( LOG, ':encoding(UTF-8)' );
127 &status("Opened logfile $file{log}.");
131 &status("Cannot open logfile ($file{log}); not logging: $!");
137 # lame fix for paramlogfile.
138 return unless ( &IsParam('logfile') );
139 return unless ( defined fileno LOG );
142 &status("Closed logfile ($file{log}).");
146 # Usage: &processLog($file);
149 my @processLog = ( 'scripts/processlog', '/usr/bin/bzip2', '/bin/bzip2', '/bin/gzip' );
153 &WARN("processLog: file ($file) does not exist.");
157 if ( -f "$file.gz" or -f "$file.bz2" ) {
158 &WARN('processLog: file.(gz|bz2) already exists.');
162 foreach (@processLog) {
163 next unless ( -x $_ );
165 &status("Processing log '$file' with $_.");
166 system("$_ $file &");
172 &ERROR('no processLog program found.');
180 return unless ( &IsParam('DEBUG') );
181 my (undef,undef,$line,$subroutine,undef) = caller(1);
183 &status("${b_green}!DEBUG!$ob ".$subroutine.'['.$line."] $_[0]");
187 return unless ( &IsParam('DEBUG') );
188 my (undef,undef,$line,$subroutine,undef) = caller(1);
190 &status("${b_red}!ERROR!$ob ".$subroutine.'['.$line."] $_[0]");
194 return unless ( &IsParam('WARN') );
196 return if ( $_[0] =~ /^PERL: Subroutine \S+ redefined at/ );
198 my ($package,$filename,$line,$subroutine,undef) = caller(1);
200 &status("${b_yellow}!WARN!$ob ".$subroutine.'['.$line."] $_[0]");
204 my ($package,$filename,$line,$subroutine,undef) = caller(1);
206 &status("${b_cyan}!FIXME!$ob ".$subroutine.'['.$line."] $_[0]");
210 my ($package,$filename,$line,$subroutine,undef) = caller(1);
212 &status("${b_cyan}!TODO!$ob ".$subroutine.'['.$line."] $_[0]");
216 if ( !&IsParam('VERBOSITY') ) {
220 elsif ( $param{'VERBOSITY'} eq '1' and $_[1] <= 1 ) {
223 elsif ( $param{'VERBOSITY'} eq '2' and $_[1] <= 2 ) {
232 if ( $input =~ /PERL: Use of uninitialized/ ) {
237 if ( $input eq $logold ) {
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");
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).");
255 if ( $ref eq 'ARRAY' ) {
257 &WARN("status: '$_'.");
262 # Something is using this w/ NULL.
263 if ( !defined $input or $input =~ /^\s*$/ ) {
264 $input = 'ERROR: Blank status call? HELP HELP HELP';
269 s/\002|\037//g; # bold,video,underline => remove.
273 if ( $input =~ /\n/ ) {
274 foreach ( split /\n/, $input ) {
282 # fix style of output if process is child.
283 if ( defined $bot_pid and $$ != $bot_pid and !defined $statcountfix ) {
289 ### TODO: move this _after_ printing?
293 # hrm... what is this supposed to achieve? nothing I guess.
294 if ( $logtime == $time ) {
295 if ( $logcount < 25 ) { # too high?
300 &status('LOG: Throttling.');
304 else { # $logtime != $time.
313 # Log differently for forked/non-forked output.
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";
323 $status = "[$statcount] " . $input;
326 if ( &IsParam('backlog') ) {
327 push( @backlog, $status ); # append to end.
328 shift(@backlog) if ( scalar @backlog > $param{'backlog'} );
331 if ( &IsParam('VERBOSITY') ) {
333 printf $_red. '!%6d!' . $ob . ' ', $statcount;
336 printf $_green. '[%6d]' . $ob . ' ', $statcount;
339 # three uberstabs to Derek Moeller. I don't remember why but he
341 my $printable = $input;
343 if ( $printable =~ s/^(<\/\S+>) // ) {
345 # it's me saying something on a channel
347 print "$b_yellow$name $printable$ob\n";
349 elsif ( $printable =~ s/^(<\S+>) // ) {
351 # public message on channel.
355 print "$b_red$name $printable$ob\n";
358 print "$b_cyan$name$ob $printable$ob\n";
362 elsif ( $printable =~ s/^\* (\S+)\/(\S+) // ) {
365 print "$b_white*$ob $b_cyan$1$ob/$b_blue$2$ob $printable\n";
368 elsif ( $printable =~ s/^(-\S+-) // ) {
371 print "$_green$1 $printable$ob\n";
374 elsif ( $printable =~ s/^(\* )?(\[\S+\]) // ) {
376 # message/private action from someone
377 print "$b_white$1$ob" if ( defined $1 );
378 print "$b_red$2 $printable$ob\n";
381 elsif ( $printable =~ s/^(>\S+<) // ) {
383 # i'm messaging someone
384 print "$b_magenta$1 $printable$ob\n";
387 elsif ( $printable =~ s/^(enter:|update:|forget:) // ) {
389 # something that should be SEEN
390 print "$b_green$1 $printable$ob\n";
394 print "$printable\n";
400 #print "VERBOSITY IS OFF?\n";
403 # log the line into a file.
404 return unless ( &IsParam('logfile') );
405 return unless ( defined fileno LOG );
407 # remove control characters from logging to LOGFILE.
409 last if ( &IsParam('logColors') );
410 s/\e\[[0-9;]+m//g; # escape codes.
411 s/[\cA-\c_]//g; # control chars.
413 $input = "FORK($$) " . $input if ($statcountfix);
416 if ( &IsParam('logType') and $param{'logType'} =~ /DAILY/i ) {
417 $date = sprintf( '%02d:%02d.%02d', ( gmtime $time )[ 2, 1, 0 ] );
419 my ( $day, $month, $year ) = ( gmtime $time )[ 3, 4, 5 ];
421 sprintf( '%04d/%02d%02d', $year + 1900, $month + 1, $day );
422 if ( defined $logDate and $newlogDate ne $logDate ) {
424 &processLog( $file{log} );
432 printf LOG "%s %s\n", $date, $input;
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: $!");
446 binmode( IN, ':encoding(UTF-8)' );
448 # TODO: better filename.
449 open( OUT, '>>debug.log' );
450 binmode( OUT, ':encoding(UTF-8)' );
451 print OUT "DEBUG: $str\n";
453 # note: cannot call external functions because SIG{} does not allow us to.
459 # bleh. this tries to duplicate status().
461 # TODO: rename to log_*someshit*
463 my $msg = "$file: $i:!$_";
464 printf "%s[%6d]%s %s\n", $_green, $statcount, $ob, $msg;
465 print OUT "DEBUG: $msg\n";
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";
481 if ( !open( SQLDEBUG, ">>$param{'SQLDebug'}" ) ) {
482 &ERROR("Cannot open ($param{'SQLDebug'}): $!");
483 delete $param{'SQLDebug'};
486 binmode( SQLDEBUG, ':encoding(UTF-8)' );
488 &status("Opened SQL Debug file: $param{'SQLDebug'}");
495 &status("Closed SQL Debug file: $param{'SQLDebug'}");
499 return unless ( &IsParam('SQLDebug') );
501 return unless ( fileno SQLDEBUG );
503 print SQLDEBUG $_[0] . "\n";
508 # vim:ts=4:sw=4:expandtab:tw=80