#!PERL_BIN_DIR/perl
#
# swatch -- system watcher
#
# usage: swatch [ -c config_file ] [ -r restart_time ]
#   [ [ -f file_to_examine ] || [ -p program_to_pipe_from ]
#   || [ -t file_to_tail ] ]
#   [ -P pattern_separator ] [ -A action_separator ]
#   [ -I input_record_separator ]
#
# default: swatch -c ~/.swatchrc -t /var/log/syslog
#
# Created on Thu Mar 19 10:10:19 PST 1992 by Todd.Atkins@CAST.Stanford.EDU
#
# Copyright (1995) The Board of Trustees of the Leland Stanford Junior
# Univeristy.  Except for commercial resale, lease, license or other commercial
# transactions, permission is hereby given to use, copy, modify, and distribute
# this software -- by exercising this permission you agree that this Notice
# shall accompany this software at all times. 
# 
# STANFORD MAKES NO REPRESENTATIONS OR WARRANTIES OF ANY KIND CONCERNING
# THIS SOFTWARE.
#
# $Log: Copyright.pl,v $#
# Revision 2.0  1994/03/25  16:59:35  atkins
# initial revision of 2.0
#
#
eval 'PERL_BIN_DIR/perl -S $0 ${1+"$@"}'
    if 0;
#
$ENV{'PATH'} = '/usr/ucb:/usr/bin:/bin:PERL_BIN_DIR';
$ENV{'IFS'} = '' if $ENV{'IFS'} ne '';
$0 = rindex($0, "/") > -1 ? substr($0, rindex($0, "/")+1) : $0;

$VERSION = '2.2';

# The location of our supporting cast
$SWATCH_PERL_LIB = 'SWATCH_LIB_DIR';
unshift(@INC, $SWATCH_PERL_LIB);

require 'ctime.pl';
require 'getopts.pl';

# Some defaults
$PERL                   = 'PERL_BIN_DIR/perl';
$TAIL			= '/usr/ucb/tail -f';
$DEF_INPUT		= "$TAIL /var/log/syslog";
$Pipe			= 1;
$ConfigFile		= "$ENV{'HOME'}/.swatchrc";
$PatternSeparator	= ',';
$ActionSeparator	= ',';
#
$Done			= 0;	### Done watching
$Restart		= 0;	### Restart watcher

####################################################################
# Get the command line arguments and set the appropriate variables.
####################################################################

&Getopts("c:r:A:P:I:df:p:t:") || die &usage;

if ($opt_c) { $ConfigFile = $opt_c }
if ($opt_d) { $DumpScript = $opt_d }
if ($opt_r) {
    $RestartTime = $opt_r;
    &set_alarm($RestartTime);
}
if ($opt_A) { $ActionSeparator = $opt_A }
if ($opt_P) { $PatternSeparator = $opt_P }
if ($opt_I) { $/ = $opt_I }

if ($opt_f)	{
    $Input = $opt_f;
    $Pipe = 0;
} elsif ($opt_p) {
    $Input = "$opt_p";
} elsif ($opt_t) {
    $Input = "$TAIL $opt_t";
} else {
    $Input = $DEF_INPUT;
}

sub usage {
    print STDERR "usage: $0 [-c config_file] [-r time_to_restart]\\\n";
    print STDERR "\t[-A action_separator] [-P pattern_separator]\\\n";
    print STDERR "\t[-f file_to_examine] [-p program_to_pipe_from]\\\n";
    print STDERR "\t[-t file_to_tail]\n";
}
####################
# Main section
####################

do {
    ############################
    # Set up signal handlers
    ############################

    # catch these signals so that we can clean up before dying
    $SIG{'INT'} = $SIG{'QUIT'} = $SIG{'TERM'} = 'quit';
    # catch these signals so that we can restart swatch more easily
    $SIG{'ALRM'} = $SIG{'HUP'} = 'restart';

    $Restart = 0;
    &doit();
} until $Done;

&quit();

sub doit {
    #
    # create the perl script 
    #
    $swatchScript = '';
 
    &put_header(*swatchScript);
    &sw_cf2pl($ConfigFile, *swatchScript);
    &put_footer(*swatchScript);

    #
    # Run the perl script unless we are debugging
    #
    if (! $DumpScript ) { 
        undef $pid;
        FORK: {
          if ($pid = fork) {
              waitpid($pid, 0);
          } elsif (defined $pid) {
	      local($scriptPid) = open(SW_SCRIPT, "| $PERL -") 
		|| die "$0: cannot open pipe into \"$PERL -\": $!\n";
	      print SW_SCRIPT "$swatchScript";
	      close(SW_SCRIPT);
	      kill('TERM', $scriptPid);
 	      exit(0);
          } elsif ($! =~ /No more processes/) {
              # EAGAIN, supposedly recoverable fork error
              sleep 5;
              redo FORK;
          } else {
              die "Can't fork: $!\n";
          }
        }
	$Done = 1 if !$Restart;
    } else {
        print $swatchScript;
        sleep(1);
	$Done = 1;
    }
}

#########################
# End of Main section
#########################


#########################################
#
# makescript.pl -- Swatcher script creation subroutines
#
#########################################

#
# put_header -- print out the start of our swatch generated perl script
#
# usage: &put_header($newScript);
#
sub put_header {
    local(*Script) = @_;

    # get the perl version information
    local($junk, $junk, $junk, $Revision, $junk, $Date, $junk, $junk, $junk, $junk, $PatchLevel) = split(/[ \t\n]+/,$]);

    $Script .= "unshift(\@INC, '$SWATCH_PERL_LIB');\n";
    $Script .= "require 'sw_actions.pl';\n";
    $Script .= "require 'sw_history.pl';\n";
    $Script .= "\$/ = \"$/\";\n"; 
    $Script .= "\$Input = '$Input';\n";
    $Script .= "\$SIG{'TERM'} = 'goodbye';\n";
    $Script .= "select((select(STDOUT), \$| = 1)[0]); # unbuffer pipe\n";
    $Script .= "\n";
    $Script .= "print \"\\n*** ${0}-${VERSION} (pid:$$) started at \" . `/bin/date` . \"\\n\";\n";
    $Script .= "\n";
    if ($Pipe) {
        $Script .= "require 'open2.pl';\n";
        $Script .= "\$childPid = &open2('read_fh', 'write_fh', \$Input);\n";
    } else {
        $Script .= "open(read_fh, \$Input) || die \"$0: cannot open \$Input: \$!\\n\";\n";
    }
    $Script .= "select((select(read_fh), \$| = 1)[0]); # unbuffer pipe\n";
    $Script .= "LINE: while (<read_fh>) {\n";
}


#
# sw_cf2pl -- convert the configuration file to perl
#
# usage: sw_cf2pl($InputFile, $Script)
#

sub sw_cf2pl {
    local($InputFile, *Script) = @_;
    local($UserName)		= $ENV{'USER'};
    local($BoldPrint)		=  "\033[1m";
    local($BlinkPrint)		=  "\033[5m";
    local($InversePrint)	=  "\033[7m";
    local($NormalPrint)		=  "\033[0m";
    local($UnderscorePrint)	=  "\033[4m";
    local($LineNum)		= 0;

    open(INPUT, $InputFile) || die "$0: cannot open $InputFile: $!\n";

    $FirstLine = 1;

    INPUTLOOP: while (<INPUT>) {
	$LineNum++;
	chop;

	next INPUTLOOP if substr($_, 0, 1) eq '#' || !length($_);

	local($PatternList, $ActionList, $Interval, $TimeStampLoc)
	 = split(/[\t]+/, $_, 4);

        ## Check for "fuzzy" matching (not fully implemented). ###
	if ($PatternList =~ /^~/) {
	    $ExactMatch = 0;
	    $PatternList =~ s/^~//;
	} else {
	    $ExactMatch = 1;
	}

	@Patterns = split($PatternSeparator, $PatternList);
	@Actions = split($ActionSeparator, $ActionList);

	### Insert the pattern list ###

	if ($FirstLine) {
	    $Script .= "  if (";
	    $FirstLine = 0;
	} else {
	    $Script .= "  } elsif (";
	}

	$FirstPattern = 1;
	foreach $Pattern (@Patterns) {
	    if ($FirstPattern) {
		$Script .= " $Pattern";
		$Patterns .= "$Pattern";
	        $FirstPattern = 0;
	    } else {
		$Script .= " || $Pattern";
		$Patterns .= " || $Pattern";
	    }
        }
	$Script .= " ) {\n";
	
	### Insert history list check if necessary ###
	if (defined $Interval) {
	    $Interval = &hms2s($Interval);
  
            if ($ExactMatch) {
                $Script .= "    if (! &skip_message(&strip_message(\$_, \"$TimeStampLoc\"), $Interval)) {\n";
            } else {
                $Script .= "    \$pattern = '$Patterns';\n";
                $Script .= "    if (! &skip_message(\$pattern, $Interval)) {\n";
            }
	}

	### Insert the actions ###
	foreach $Action (@Actions) {
	    ($Action, $Value) = split("=", $Action, 2);
	    $Action =~ tr/A-Z/a-z/;

	    if ("bell" eq $Action) {
		$Script .= sprintf("\t\&do_bell(%d);\n", $Value ? $Value : 1);
	    } elsif ("echo" eq $Action) {
		undef $PrintMode;
		$Value =~ tr/A-Z/a-z/;
		$Value =~ s/ //g;
		$PrintMode .= $BoldPrint if index($Value, "bold") != -1;
		$PrintMode .= $BlinkPrint if index($Value, "blink") != -1;
		$PrintMode .= $InversePrint if index($Value, "inverse") != -1;
		$PrintMode .= $NormalPrint if index($Value, "normal") != -1;
		$PrintMode .= $UnderscorePrint if index($Value, "underscore") != -1;
                if ( defined $Interval ) {
	            $Script .= "\t\$echo_message = &format_message(\$_, \"$TimeStampLoc\", $ExactMatch);\n";
                } else {
		    $Script .= "\t\$echo_message = \$_;\n";
		}
		$Script .= sprintf("\tprint \"%s\$echo_message%s\";\n",
		       $PrintMode,
		       $PrintMode ? $NormalPrint : "");
            } elsif ("exec" eq $Action || "system" eq $Action) {
                die "$0: 'exec' action requires a value (line $LineNum)\n" if !$Value;
		$Script .= "\t\$orig_input = \$_;\n";
                $Script .= "\t\$[ = 1;\n";
		$Script .= "\tchop;\n";
		$Script .= "\t\$_ =~ s/[;&\\(\\)\\|\\^><\\\$`'\\\\]/\\\\\$+/g;\n";
                $Script .= "\tsplit;\n";
                if ("exec" eq $Action) {
                    $Script .= sprintf("\t&exec_it(%s);\n", &convert_command($Value));
                } else {
                    $Script .= sprintf("\tsystem(%s);\n", &convert_command($Value));
                }
                $Script .= "\t\$[ = 0;\n";
		$Script .= "\t\$_ = \$orig_input;\n";
	    } elsif ("ignore" eq $Action) {
		$Script .= "\n";
	    } elsif ("mail" eq $Action) {
		$Script .= sprintf("\t&mail_it('%s', \$_);\n",
		       $Value ? $Value : $UserName); 
	    } elsif ("pipe" eq $Action) {
                die "$0: 'pipe' action requires a value (line $LineNum)\n" if !$Value;
		### Look to see if value is quoted ###
		local($first_char) = substr($Value, 0, 1);
		if ($first_char eq '"' || $first_char eq "'") {
		    $Script .= sprintf("\t&pipe_it(%s, \$_);\n", $Value);
		} else {
		    $Script .= sprintf("\t&pipe_it(\"%s\", \$_);\n", $Value);
		}
	    } elsif ("write" eq $Action) {
		$Script .= sprintf("\t&write_it('%s', \$_);\n",
		                   $Value ? $Value : $UserName);
	    } else {
		die "$0: unrecognized action (line $LineNum): $Action\n";
	    }
        }  

        ### Insert the end block character for history check if statement ###
	if (defined $Interval) {
	    $Script .= "    }\n";
        }

	$Script .= "\tnext LINE;\n";
    }
    $Script .= "  }\n";
    close(INPUT);
}


#
# convert_command -- convert wildcards for fields in command from
#	awk type to perl type.  Also, single quote wildcards
#	for better security.
#
# usage: &convert_command($Command);
#
sub convert_command {
    local($Command) = @_;

    $Command =~ s/\$[0*]/\$_/g;
    $Command =~ s/\$([1-9])/\$_[\1]/g;

    return $Command;
}


#
# put_footer -- finish our swatch generated perl script.
#
# usage: &put_footer($newScript);
#
sub put_footer {
    local(*script) = @_;
    $script .= "}\n";
    $script .= "&goodbye();\n";
    $script .= "\n";
    $script .= "sub goodbye {\n";
    $script .= "  \$| = 0;\n";
    if ($Pipe) {
        $script .= "  kill('KILL', \$childPid);\n";
    } else {
        $script .= "  close(INPUT);\n";
    }
    $script .= "  \&close_pipe_if_open();\n";
    $script .= "  exit(0);\n";
    $script .= "}\n";
}

# hms2s -- Take a string which may be in the form hours:minutes:seconds,
#	convert it to just seconds, and return the number of seconds
#	
sub hms2s {
    local($hms) = @_;
    local($hours, $minutes, $seconds);
    if ($hms =~ /[0-9]+:[0-9]+:[0-9]+/) {
        ($hours, $minutes, $seconds) = split(":", $hms);
    } elsif ($hms =~ /[0-9]+:[0-9]+/) {
        ($minutes, $seconds) = split(":", $hms);
    } else {
        $seconds = $hms;
    }

    return ($hours * 60 * 60) + ($minutes * 60) + $seconds;
}

####################
#
# sighandlers.pl -- Signal handlers for Swatch
#
####################


#
# set_alarm -- set alarm to go off
#
# usage: &set_alarm($When);
#
sub set_alarm {
    local($When) = @_;
    local($Specific) = 1;
    local($AM) = 1;
    local($Hour) = 0;
    local($Minute) = 0;
    local($Seconds) = 0;
    local($CurTime) = 0;
    local($CurHour, $CurMin, $CurSec);
    local($H, $M, $S);

    $When =~ tr/A-Z/a-z/;

    if (($When =~ /[ap]m/) && ($When =~ /\+/)) {
	die "$0: restart time cannot contain a '+' and \"am\" or \"pm\"\n";
    }

    if ($When =~ /am/) {
        $When = substr($When, $[, rindex($When, "am"));
    } elsif ($When =~ /pm/) {
	$When = substr($When, $[, rindex($When, "pm"));
	$AM = 0;
    } elsif ($When =~ /[a-z]/) {
        die "$0: restart time must be in \"hour:minute\" format\n";
    }

    if ($When =~ /^\+/) {
        $Specific = 0;
	$When =~ s/^\+//;
    }
    if ($When =~ /:/) {
	($Hour, $Minute) = split(":", $When);
	$Hour += 12 if (!$AM && $Hour < 12);
    } else {
	die "$0: restart time must be in \"hour:minute\" format\n" if $Specific;
	$Minute = $When;
    }

    $CurTime = `/bin/date +%H:%M:%S`;
    if ($Specific) {
        ($CurHour, $CurMin, $CurSec) = split(/[:\n]/, $CurTime);
        $S = 60 - $CurSec;
        $M = $Minute - $CurMin > 0 ? $Minute - $CurMin
                                   : 60 + $Minute - $CurMin;
        $H = $Hour - $CurHour > 0 ? $Hour - $CurHour : 24 + $Hour - $CurHour;
        $H = $Minute - $CurMin > 0 ? $H : $H - 1;
        $Seconds = ((($H * 60) + $M) * 60) + $S;
    } else {
        $Seconds = (($Hour * 60) + $Minute) * 60;
    }
    alarm($Seconds);
}



#
# quit -- terminate gracefully
#
# usage: &quit($SIGNAL);
#
sub quit {
    local($Sig) = @_;
    return if $pid == 0;

    if ($Sig) { print STDERR "Caught a SIG$Sig -- shutting down\n" }
    kill('TERM', $pid) unless $DumpScript;
    exit(0);
}


#
# restart -- kill the child, delete the script, and start over.
#
# usage: &restart();
#
sub restart {
    local($Sig) = @_;
    print STDERR "Caught a SIG$Sig -- restarting\n";
    kill('TERM', $pid);
    waitpid($pid, 0);
    $Restart = 1;
    &set_alarm($RestartTime) if ($RestartTime && $Sig eq 'ALRM');
}
