#!/usr/bin/perl -w

eval 'exec /usr/bin/perl -w -S $0 ${1+"$@"}'
    if 0; # not running under some shell
#
#    swatch: The Simple WATCHdog
#    Copyright (C) 1993-2000 E. Todd Atkins
#
#    This program is free software; you can redistribute it and/or modify
#    it under the terms of the GNU General Public License as published by
#    the Free Software Foundation; either version 2 of the License, or
#    any later version.
#
#    This program is distributed in the hope that it will be useful,
#    but WITHOUT ANY WARRANTY; without even the implied warranty of
#    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
#    GNU General Public License for more details.
#
#    You should have received a copy of the GNU General Public License
#    along with this program; if not, write to the Free Software
#    Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
#

=head1  NAME

swatch - simple watcher

=head1  SYNOPSIS

B<swatch> 
[ B<--config-file> I<file> ] 
[ B<--restart-time> I<time> ] 
[ B<--input-record-separator> I<regex> ] 
[ [ B<--examine> I<file_to_examine> ] 
| [ B<--read-pipe> I<program_to_pipe_from> ] 
| [ B<--tail> I<file_to_tail> ] ]
[ B<--daemon> ] 

=head1  DESCRIPTION

B<Swatch> is designed to monitor system activity.
In order for B<Swatch> to be useful, it requires a configuration file
which contains I<pattern(s)> to look for and I<action(s)>
to perform when each pattern is found.

=head1 COMMAND LINE OPTIONS

=over 4

=item B<--config-file>=I<filename> or B<-c> I<filename>

Tells B<swatch> where to find its configuration file. The default
is I<${HOME}/.swatchrc>.

=item B<--help>

Prints usage informatiion and exits.

=item B<--input-record-separator>=I<regular_expression>

Tells B<swatch> to use I<regular_expression> to delineate
the boundary of each input record. The default is a carriage return. 

=item B<--restart-time>=I<[+]hh:mm[am|pm]> or B<-r> I<[+]hh:mm[am|pm]>

Restart after the specified time where I<hh> is hours and I<mm> is minutes. 
If the am/pm indicator is omitted, then a 24-hour clock is assumed. 
If the time is preceeded by the "+" character, then the restart time 
will be set to the current time plus the specified time and the am/pm
indicator will be ignored.

=item B<--script-dir>=I</path/to/directory>

This switch causes the temporary watcher script to be written to a file
in the specified directory rather than the user's home directory. It is
highly advised that you do B<NOT> use directories that are writable by others
such as /tmp.

=item B<--version> or B<-V>

Prints version information and exits.

=back

You may specify only one of the following options:

=over 4

=item B<--tail-file>=I<filename> or B<-t> I<filename>

Examine lines of text as they are added to filename. 

=item B<--read-pipe>=I<command> or B<-p> I<command>

Examine input piped in from the I<command>. 

=item B<--examine>=I<filename> or B<-f> I<filename>

Use I<filename> as the file to examine. 
B<Swatch> will do a single pass through the named file. 

=back

The following options are purely for debugging purposes, but are
documented here for completeness:

=over 4

=item B<--dump-script>[=I<filename>]

Instead of running the watcher script after it is generated, 
it is written to I<filename> or to STDOUT.

=back 

If swatch is called with no options, it is the same as typing the 
command line

=over 5

=item

C<swatch --config-file=~/.swatchrc --tail-file=/var/log/syslog>

or (if Linux)

C<swatch --config-file=~/.swatchrc --tail-file=/var/log/messages>


=back

If the configuration file doesn't exist then the following configuration
is used:

	watchfor  /.*/
	    echo modes=random


=head1 THE CONFIGURATION FILE 

The configuration file is used by the B<swatch(8)>
program to determine what types of expression patterns to look for
and what type of action(s) should be taken when a pattern is matched.

Each line should contain a keyword and a, sometimes optional,
value for that keyword. The keyword and value are separated by 
space or an equal (=) sign.

watchfor regex

ignore regex

=over 4

=item B<echo [modes]>

Echo the matched line. The text mode may be I<normal>,
I<bold>, I<underscore>, I<blink>, I<inverse>, 
I<black>, I<red>, I<green>, I<yellow>, I<blue>, I<magenta>, I<cyan>, I<white>,
I<black_h>, I<red_h>, I<green_h>, I<yellow_h>, I<blue_h>, 
I<magenta_h>, I<cyan_h>, and/or I<white_h>. The I<_h> colors specify 
a highlighting color. The other colors are assigned to the letters.
Some modes may not work on some terminals. B<Normal>
is the default.

=item B<bell [N]>

Echo the matched line, and send a bell I<N> times (default = 1).

=item B<exec command>

Execute I<command>. The I<command> may contain variables which are 
substituted with fields from the matched line. A I<$N> will be replaced
by the I<Nth> field in the line. A I<$0> or I<$*> will be replaced by the
 entire line.

=item B<mail [addresses=address:address:...][,subject=your_text_here]>

Send I<mail> to I<address(es)> containing the matched lines as
they appear (default address is the user who is running the program).

=item B<pipe command[,keep_open]>

Pipe matched lines into I<command>. Use the B<keep_open> option to 
force the pipe to stay open until a different pipe action is run or 
until swatch exits.

=item B<write [user:user:...]>

Use B<write(1)> to send matched lines to I<user(s)>.

=item B<throttle hours:minutes:seconds,[use=message|regex]>

Use this action to limit the number of times that the matched pattern 
has actions performed on it. 

The B<use=regex> option will cause throttling to be based on the regular
expression instead of the message (B<use=message> is the default).

=item B<continue>

Use this action to cause B<swatch> to continue to try to match other
pattern/action groups after it is done with the current pattern/action
block.

=item B<quit>

Use this action to cause B<swatch> to clean up and quit immediately.

=back

=head1 SPECIAL OPTION

The following may be used as an option for any of the above actions

=over 4

=item B<when=>I<day_of_week:hour_of_day>

Use this option to specify windows of time and days when the action can 
be performed. 
For example:

=over 8

=item mail=sysad-pager@somehost.somedomain,when=1-6:8-17

=back

=back

=head1 CONFIGURATION EXAMPLE

watchfor /file system full/
    echo
    bell
    throttle 01:00


This example a line which contains the string "file system full" will
be echoed and the screen bell will sound.  Also, multiple instances of
the message will not be echoed if they appear within a minute of the 
first one.  Instead the following message will be acted upon after 
the time interval has expired.  This is what may appear if a the message
appeared 20 times.

=over 4

=item

C<** 20 in 00:01:00 ==> host.domain: /var: file system full>

=back

=head1 SEE ALSO

B<signal(3)>, B<perl(1)>, B<perlre(1)>

=head1 NOTES

Upon receiving a ALRM or HUP signal swatch will re-read the
configuration file and restart.
Swatch will terminate gracefully
when it receives a QUIT, TERM, or INT signal.

=head1 AUTHOR

    E. Todd Atkins
    eta@engr.ucsb.edu
    Engineering Computing Infrastructure
    School of Engineering
    University of California, Santa Barbara

=head1 AVAILABILITY

The official FTP location is B<ftp://ftp.stanford.edu/general/security-tools/swatch>
Latest release is available at B<http://www.engr.ucsb.edu/~eta/swatch/latest.tar>
Swatch's homepage is B<http://www.engr.ucsb.edu/~eta/swatch> or B<http://www.stanford.edu/~atkins/swatch>

=cut

use strict;
use FileHandle;
use Getopt::Long;
use IO::Handle;
use POSIX ":sys_wait_h";
use Date::Parse;
use Date::Format;

use vars qw($opt_config_file
	    $opt_daemon
	    $opt_debug_level
	    $opt_dump_script
	    $opt_examine
	    $opt_help
	    $opt_input_record_separator
	    $opt_old_style_config
	    $opt_pid_file
	    $opt_style_config
	    $opt_read_pipe
	    $opt_restart_time
	    $opt_tail_file
	    $opt_script_dir
	    $opt_version
	    @Config
	    $Done
	    $Restart
	    $VERSION
	    $Now
	    $pid
	   );

my @Swatch_ARGV = join(' ', $0, @ARGV); # Save just in case we need to restart 
my $Me = $0; $Me =~ s%.*/%%;	      # Strip the path off of the program name

$SIG{'CHLD'} = 'IGNORE';

my $DEF_CONFIG_FILE = "$ENV{'HOME'}/.swatchrc";
my $PERL            = '/usr/bin/perl';
my $DEF_INPUT       = "/var/log/messages";
my $Config_File     = '';
my $Now = 0;  # The current time in Unix seconds. Gets set when set_restart_time is called

my $USAGE = qq/
Usage:
    $Me [<options>]
Options:
    --config-file=FILENAME               Use FILENAME for configuration.
    --old-style-config                   Parse a pre-version 3 configuration.
    --restart-time=[+]HH:MM[AM|PM]       Send a HUP signal to swatch at the specified time.
    --input-record-separator=REGEX       Specify an what should be used to separate "lines."
    --help                               Display this message.
    --version                            Display author and version information.
    --tail-file=FILENAME                 Watch a tail of FILENAME.
    --read-pipe=COMMAND                  Watch a pipe from COMMAND
    --examine=FILENAME                   Perform a single pass through FILENAME

/;

my $AUTHOR = "E. Todd Atkins <Todd.Atkins\@Stanford.EDU>";
$VERSION = "3.0.1";
my $BUILD_DATE = "03/28/2000";

sub print_version {
  print "This is $Me version $VERSION\n";
  print "Built on $BUILD_DATE\n";
  print "Built by $AUTHOR\n";
  exit 0;
}

sub parse_command_line {

  use Getopt::Long;
  Getopt::Long::config('bundling');
  die "$USAGE" if not GetOptions(
				 "config-file|c=s",
				 "daemon",
				 "debug-level=i",
				 "dump-script:s",
				 "examine|f=s",
				 "help|h",
				 "input-record-separator|I=s",
				 "old-style-config|O",
				 "pid-file=s",
				 "read-pipe|p=s",
				 "restart-time|r=s",
				 "tail-file|t=s",
				 "script-dir=s",
				 "version|V",
				);

  die "$USAGE" if $opt_help;

  if ($opt_version) {
    print_version;
    exit(0);
  }
  
  $opt_input_record_separator = (defined $opt_input_record_separator) ? $opt_input_record_separator : $/;

  # This is slightly bogus -- we call the set_restart_time function now
  # because if the args aren't properly formatted,  we want to die before the fork
  set_restart_time($opt_restart_time) if defined $opt_restart_time; 
}
###
### Routines to help with debugging
###

sub dprint {
    my $msg_lev = shift;
    my $msg = shift;
    print STDERR "DEBUG($msg_lev): $msg\n" if ($msg_lev && $opt_debug_level);
}

#
# make_debug_code() - creates the debug code for the watcher script
#
sub make_debug_code {
    my $code = '';

    $code = sprintf("my \$Debug_Mode = %d;\n", defined $opt_debug_level ? $opt_debug_level : 0);
    $code .= q|

sub dprint {
    my $msg_lev = shift;
    my $msg = shift;
    print STDERR "DEBUG($msg_lev): $msg\n" if ($msg_lev & $Debug_Mode);
}

|;
    return $code;
}

sub dlog {
  my $msg = shift;
  my $time = localtime(time);

  if (open(DLOG, ">>/tmp/swatchlog")) {
    print DLOG "$time ";
    print DLOG $msg . "\n";
    close DLOG;
  }
}

#
# Build a configuration record structure
# 
sub read_config {
  my $filename = shift;
  my $rec = ();
  my $i = -1;
  my $keyword;
  my $pattern;
  my $option;
  my $value;
  my $fh;
  my @records;

  if ( not -r $filename ) {
    warn "$Me: cannot read $filename\n";
    exit 1 if $opt_daemon;
    warn "$Me: using default configuration of:\n";
    warn "\n\twatchfor = /.*/\n\t\techo = random\n\n";
    sleep 5;
    $rec = ();
    $rec->{pattern} = '/.*/';
    $rec->{keyword} = 'watchfor';
    push(@{$rec->{actions}}, { action => 'echo', value => 'random' });
    push(@records, $rec);
    return(@records);
  }

  $fh = new FileHandle "$filename", "r";
  if (not defined $fh) {
    warn "$Me: cannot open $filename: $!\n";
    exit 1;
  }

  while (<$fh>) {
    my($key, $val);
    chomp;
    s/^\s+//; ## strip off leading blank space
    s/\s+$//; ## strip off trailing blank space
    ### Skip comments blank lines ###
    next if (/^\#/ or /^\s*$/);

    if (/\s*[= ]\s*/) {
      $key = (split(/\s*[= ]\s*/))[0];
      $key =~ s/^\s+//;;
      $key =~ s/\#.*//;
      ($val = substr($_, length($key))) =~ s/^\s*[= ]\s*//;
    } else {
      $key = (split())[0];
      $key =~ s/^\s+//;;
      $key =~ s/\#.*//;
      ($val = substr($_, length($key))) =~ s/^\s+//;
    }
    $val =~ s/\#.*//;

    if ($key =~ /(watchfor|waitfor|ignore)/) {
      $i++;
      if (defined $rec->{pattern}) {
	push @records, $rec;
	$rec = ();
      }

      $rec->{keyword} = $key;
      if (length($val)) {
	$rec->{pattern} = $val;
      }
    } elsif ($i < 0) {
      warn "$Me: error in $filename at line ${.}: option listed before keyword. Skipping.\n";
    } elsif ($key eq 'throttle') {
      $rec->{throttle}{value} = $val;
    } else {
      push(@{$rec->{actions}}, { action => $key, value => $val });
    }
  }
  undef $fh;
  if (defined $rec->{pattern}) {
    push @records, $rec;
    $rec = ();
  }
  return(@records);
}

sub read_old_config {
  my $filename = shift;
  my $fh = new FileHandle $filename, "r";
  my @records = ();

  if (not defined $fh) {
    die "$Me: cannot read $filename: $!\n";
  }

  while (<$fh>) {
    my $rec = ();
    chomp;
    @_ = split(/\t+/);

    if (/^\s*$/ or /^\s*\#/) {
      next;
    } elsif (/ignore/) {
      $rec->{keyword} = 'ignore';
      $rec->{pattern} = $_[0];
    } else {
      $rec->{keyword} = 'watchfor';
      $rec->{pattern} = $_[0];
      if (defined $_[2] and $_[2] =~ /^[0-9]/) {
	$rec->{'throttle'}->{value} = $_[2];
      }
      foreach my $action (split(/,/, $_[1])) {
	my ($key,$val) = split(/\s*=\s*/, $action);
	push(@{$rec->{actions}}, { action => $key, value => $val });
      }
    }
    push(@records, $rec);
  }
  return (@records);
}
#
# make_start_code -- return the start of our swatch generated perl script
#
# usage: $script .= make_start_code;
#
sub make_start_code {
  my $code = '';
  my $mail_cmd = '';
  my $write_cmd = '';

  foreach my $mailer (qw(/usr/lib/sendmail /usr/sbin/sendmail)) {
    $mail_cmd = $mailer if ( -x $mailer );
  }
  foreach my $path (split(/:/, $ENV{'PATH'})) {
    $write_cmd = "$path/write" if ( -x "$path/write" );
  }

  $code  = qq[
#
#    swatch: The Simple WATCHdog
#    Copyright (C) 1993-2000 E. Todd Atkins
#
#    This program is free software; you can redistribute it and/or modify
#    it under the terms of the GNU General Public License as published by
#    the Free Software Foundation; either version 2 of the License, or
#    any later version.
#
#    This program is distributed in the hope that it will be useful,
#    but WITHOUT ANY WARRANTY; without even the implied warranty of
#    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
#    GNU General Public License for more details.
#
#    You should have received a copy of the GNU General Public License
#    along with this program; if not, write to the Free Software
#    Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
#

#use strict;
use POSIX ":sys_wait_h";
use vars qw(%Msg_Rec);

\$SIG{'TERM'} = \$SIG{'HUP'} = 'goodbye';
\$SIG{'CHLD'} = 'IGNORE';

## Constants
my \$BELL   = "\007";
my \$MAILER = "$mail_cmd";
my \$WRITE  = "$write_cmd";
\$/ = "$opt_input_record_separator";

autoflush STDOUT;

sub goodbye {
  \$| = 0;
];

  if ($opt_read_pipe) {
    $code .= "  close(SW_PIPE);\n";
  } elsif ($opt_examine) {
    $code .= "  \$Fh->close;\n";
  }

  $code .= q|
  close_pipe_if_open();
  exit(0);
}

#
# in_range($range, $number) 
# returns 1 if $number is inside $range, 0 if not
#
sub in_range {
  my $range = shift;
  my $num = shift;

  foreach my $f (split(/,/, $range)) {
    if ($f =~ /-/) {
      my ($low,$high) = split(/-/, $f);
      return 1 if ($low <= $num and $num <= $high);
    } elsif ($f == $num) {
      return 1;
    }
  }
  return 0;
}

# 
# inside_time_window($days,$hours)
# returns 1 if inside window, 0 if outside window
#
sub inside_time_window {
  my $range = shift;
  my($days, $hours) = split(/:/, $range);

  my ($hr, $wday) = (localtime(time))[2,6];

  if (($days eq '*' or in_range($days, $wday))
      and ($hours eq '*' or in_range($hours, $hr))) {
    return 1;
  } else {
    return 0;
  }
}

  |;

  $code .= qq[
print \"\\n*** ${Me}-${VERSION} (pid:$$) started at \" . `/bin/date` . \"\\n\";

  ] unless $opt_daemon;

  return $code;
}

sub make_action_subs {
  my $code;
  $code = q|
##
## ACTION SUBROUTINES
##

my %text_modes = (
  "black"	=> "\033[30;1m",
  "red"		=> "\033[31;1m",
  "green"	=> "\033[32;1m",
  "yellow"	=> "\033[33;1m",
  "blue"	=> "\033[34;1m",
  "magenta"	=> "\033[35;1m",
  "cyan"	=> "\033[36;1m",
  "white"	=> "\033[37;1m",
  "black_h"	=> "\033[40;1m",
  "red_h"	=> "\033[41;1m",
  "green_h"	=> "\033[42;1m",
  "yellow_h"	=> "\033[43;1m",
  "blue_h"	=> "\033[44;1m",
  "magenta_h"	=> "\033[45;1m",
  "cyan_h"	=> "\033[46;1m",
  "white_h"	=> "\033[47;1m",
  "bold"	=> "\033[1m",
  "blink"	=> "\033[5m",
  "inverse"	=> "\033[7m",
  "normal"	=> "\033[0m",
  "underscore"	=> "\033[4m",
);
  |;

  $code .= q[
sub echo {
  my %args = (
	      'MODES' => [ 'normal' ],
	      @_
	     );

  return if (exists($args{'WHEN'}) and not inside_time_window($args{'WHEN'}));
  
  if ($args{'MODES'}[0] eq 'random') {
    my @mode_names = keys %text_modes;
    print $text_modes{$mode_names[rand $#mode_names]};
  } else {
    foreach my $mode (@{$args{'MODES'}}) {
      print $text_modes{$mode};
    }
  }
  print $args{'MESSAGE'};
  print $text_modes{'normal'};
  print "\n";
}

#
# ring_bell(args) -- send x number of control-G characters to the output.
#
sub ring_bell {
  my %args = (
	      'RINGS' => 1,
	      @_
	     );
  return if exists($args{'WHEN'}) and not inside_time_window($args{'WHEN'});
  
  my $bells = $args{'RINGS'};
  for ( ; $bells > 0 ; $bells-- ) {
    print $BELL;
  }
}

#
# exec_command(args) -- fork and execute a command
#
sub exec_command {
  my %args = (@_);
  my $exec_pid;
  my $command;

  if (exists $args{'COMMAND'}) {
    $command = $args{'COMMAND'};
  } else {
    warn "$0: No command was specified in exec action.\n";
    return;
  }

  return if exists($args{'WHEN'}) and not inside_time_window($args{'WHEN'});

 EXECFORK: {
    if ($exec_pid = fork) {
      waitpid(-1, WNOHANG);
      return;
    } elsif (defined $exec_pid) {
      exec($command);
      } elsif ($! =~ /No more processes/) {
        # EAGAIN, supposedly recoverable fork error
        sleep 5;
        redo EXECFORK;
      } else {
        warn "$0: Can't fork to exec $command: $!\n";
      }
  }
  return;
}


{
  my $pipe_is_open;
  my $current_command_name;
  #
  # send_message_to_pipe -- send text to a pipe.
  #
  # usage: &send_message_to_pipe($program_to_pipe_to_including_the_vertical_bar_symbol,
  #		  $message_to_send_to_the_pipe);
  # 
  
  sub send_message_to_pipe {
    my %args = (@_);
    my $command;

    if (exists $args{'COMMAND'}) {
      $command = $args{'COMMAND'};
    } else {
      warn "$0: No command was specified in pipe action.\n";
      return;
    }

    return if exists($args{'WHEN'}) and not inside_time_window($args{'WHEN'});

    # open a new pipe if necessary
    if ( !$pipe_is_open or $current_command_name ne $command ) {
      # first close an open pipe
      close(PIPE) if $pipe_is_open;
      $pipe_is_open = 0;
      open(PIPE, "| $command") 
	or warn "$0: cannot open pipe to $command: $!\n" && return;
      PIPE->autoflush(1);
      $pipe_is_open = 1;
      $current_command_name = $command;
    }
    # send the text
    print PIPE "$args{'MESSAGE'}";

    if (not exists $args{'KEEP_OPEN'}) {
      close(PIPE) if $pipe_is_open;
      $pipe_is_open = 0;
    }
  }

  #
  # close_pipe_if_open -- used at the end of a script to close a pipe
  #	opened by &pipe_it().
  #
  # usage: &close_pipe_if_open();
  #
  sub close_pipe_if_open {
    if ($pipe_is_open) {
      close(PIPE);
    }
  }
}


#
# send_email -- send some mail using $MAILER.
#
# usage: &send_email($addresses_to_mail_to);
#
sub send_email {
  my $login = (getpwuid($<))[0];
  my %args = (
	      'ADDRESSES' => $login,
	      'SUBJECT' => 'Message from Swatch',
	      @_
	     );

  return if exists($args{'WHEN'}) and not inside_time_window($args{'WHEN'});

  my $addresses = $args{'ADDRESSES'};
  $addresses =~ s/:/,/g;

  if ($MAILER eq '') {
    warn "ERROR: $0 cannot find a mail delivery program\n";
    return;
  }

  open(MAIL, "| $MAILER $addresses")
    or warn "$0: cannot open pipe to $MAILER: $!\n" && return;

  print MAIL "To: $addresses\n";
  print MAIL "Subject: $args{SUBJECT}\n\n";
  print MAIL "$args{'MESSAGE'}\n";
  close(MAIL);
}


#
# write_message -- use $WRITE to send a message logged on users.
#
sub write_message {
  my %args = (@_);

  return if exists($args{'WHEN'}) and not inside_time_window($args{'WHEN'});

  if ($WRITE eq '') {
    warn "ERROR: $0 cannot find the write(1) program\n";
    return;
  }

  if (exists($args{'USERS'})) {
    foreach my $user (split(/:/, $args{'USERS'})) {
      send_message_to_pipe(COMMAND => "$WRITE $user 2>/dev/null", 
		           MESSAGE => "$args{'MESSAGE'}\n");
    }
  }
}
];
return $code;
} ### end of make_action_subs ###

sub make_throttle_code {
  return q&
use Date::Calc qw(:all);

sub parse_dot {
  my $message = shift;
  my $dot_loc = shift;
  my @dot = ();
  my @ranges = split(/:/, $dot_loc);

  foreach my $range (0..$#ranges) {
    if ($ranges[$range] != -1) {
      my ($begin, $end) = split(/-/, $ranges[$range]);
      $dot[$range] = substr($message, $begin, ($end - $begin + 1));
    }
  }

  return @dot;
}

my ($date_loc, $time_loc) = ("-1:0-2:4-5", "7-8:10-11:13-14");
my %months = (
	      Jan => 1,
	      Feb => 2,
	      Mar => 3,
	      Apr => 4,
	      May => 5,
	      Jun => 6,
	      Jul => 7,
	      Aug => 8,
	      Sep => 9,
	      Oct => 10,
	      Nov => 11,
	      Dec => 12
	     );

# Returns an array of year, month, day, hours, minutes, and seconds.
#
sub YMDHMS {
  my $string = shift;
  my $year_today = (Today())[0];

  my ($y, $m, $d) = parse_dot($string, $date_loc);
  my ($hrs, $mins, $secs) = parse_dot($string, $time_loc);
  if (length($y) eq 0) { $y = (Today())[0] };

  return ($y, $months{$m}, $d, $hrs, $mins, $secs);
}

sub new_msg {
  my $use = shift;
  my $msg = shift;
  my $count = shift;
  my @delta = @_;
  my $delta;
  if ($delta[0] == 0) {
    $delta = sprintf("%d:%.2d:%.2d", $delta[1], $delta[2], $delta[3]);
  } else {
    $delta = sprintf("$delta[0] day%s %d:%.2d:%.2d", $delta[0] > 1 ? 's' : '',
		    $delta[1], $delta[2], $delta[3]);
  }
  if ($use eq 'regex') {
    return "$count $msg regular expressions in $delta";
  } else {
    return "$count in $delta: $msg";
  }
}

#
# Stores message information in 
#    $Msg_Rec = (
#      {<truncated message>|<pattern>} => {
#        dhms => [ array ], # days,hours,minutes,seconds
#        count => integer,

sub throttle {
  my %opts = (
	      KEY       => $_,
	      CUT_MARKS => [ "0:16" ], # not used yet
	      USE       => 'message',
	      @_
	     );

  my $msg = $opts{'KEY'};
  my $use = $opts{'USE'};
  my @ymdhms = YMDHMS($msg);
  my $key;
  my @min_dhms_delta = split(/(\s+|:)/, $opts{'MIN_DELTA'});

  foreach my $i (0..$#min_dhms_delta) {
    # strip out unwanted element
    splice (@min_dhms_delta, $i, 1) if ($min_dhms_delta[$i] eq ":");
  }

  if ($use eq 'regex') {
    $key = $opts{'REGEX'};
  } else {
    $key = substr($msg, 16);
    $key =~ s/\[\d+\]/[PID]/;
  }

  while ($#min_dhms_delta < 3) {
    unshift(@min_dhms_delta, 0); # make sure that the dhms array is full
  }

  if (exists $Msg_Rec{$key} and defined $Msg_Rec{$key}->{ymdhms}) {
    my $passed = 1;
    $Msg_Rec{$key}->{count}++;
    if ($ymdhms[1] > $Msg_Rec{$key}->{ymdhms}[1]) { $ymdhms[0]--; }

    my @delta_dhms = Delta_DHMS(@{$Msg_Rec{$key}->{ymdhms}}, @ymdhms);
    foreach my $i (0..$#min_dhms_delta) {
      $passed = 0 if ($delta_dhms[$i] < $min_dhms_delta[$i]);
      last unless ($delta_dhms[$i] == $min_dhms_delta[$i]);
    }    
    if ($passed) {
      my $new = '';
      $new = new_msg($use, $key, $Msg_Rec{$key}->{count}, @delta_dhms);
      $Msg_Rec{$key}->{ymdhms} = [ @ymdhms ];
      $Msg_Rec{$key}->{count} = 1;
      return $new;
    } else {
      return '';
    }
  } else {
    my $rec;
    $rec->{ymdhms} = [ @ymdhms ];
    $Msg_Rec{$key} = $rec;
    return $msg;
  }
}

&; #
} 
sub make_start_loop {
  my $filename = $DEF_INPUT;
  my $code = '';

  if (defined $opt_examine) {
    $filename = $opt_examine;
    $code = qq[
use FileHandle;
my \$Filename = '$filename';
my \$Fh = new FileHandle \"\$Filename\", 'r';
if (not defined \$Fh) {
    die "$0: cannot read input \\"\$Filename\\": \$!\\n";
}

LOOP: while (<\$Fh>) {
];

  } elsif (defined $opt_read_pipe) {
    $filename = $opt_read_pipe;
    $code = qq[
use FileHandle;
my \$Filename = '$filename';

if (not open(SW_PIPE, \"$filename|\")) {
    die "$0: cannot read from pipe to program \\"\$Filename\\": \$!\\n";
}

LOOP: while (<SW_PIPE>) {
];

  } else {
    $filename = $opt_tail_file if (defined $opt_tail_file);
    $code = qq[
use File::Tail;
my \$Filename = '$filename';
my \$File = File::Tail->new(name=>\$Filename,interval=>1,maxinterval=>5,adjustafter=>20);
if (not defined \$File) {
    die "$0: cannot read input \\"\$Filename\\": \$!\\n";
}

LOOP: while (defined(\$_=\$File->read)) {
];
  }

  $code .= q!
    chomp;
    my $sanitized_ = $_;
    @_ = split;
    
    # quote all special shell chars
    $sanitized_ =~ s/([;&\(\)\|\^><\$`'\\\\])/\\\\$1/g;
    my @sanitized_ = split(/\s+/, $sanitized_);
!;
}

sub make_end_code {
    my $code;
    $code = q[
}
];
    return $code;
} 


sub action_def_to_subroutine_call {
  my $key = shift;  # converts to subroutine name
  my $optstr = shift; # comma separated option string
  my $pattern = shift;
  my $actinfo = { # action subroutine info
                 "continue" => { 'sub_name' => "continue" },
		 "bell" => { 'sub_name' => "ring_bell", 'def_arg' => 'RINGS' },
		 "echo" => { 'sub_name' => "echo", 'def_arg' => 'MODES' },
		 "exec" => { 'sub_name' => "exec_command", 'def_arg' => 'COMMAND' },
		 "pipe" => { 'sub_name' => "send_message_to_pipe", 'def_arg' => 'COMMAND' },
		 "mail" => { 'sub_name' => "send_email", 'def_arg' => 'ADDRESSES' },
		 "quit" => { 'sub_name' => "exit" },
		 "throttle" => { 'sub_name' => 'throttle', 'def_arg' => 'MIN_DELTA' },
		 "write" => { 'sub_name' => "write_message", 'def_arg' => 'USERS' },
		};

  my $arg_string = "$actinfo->{$key}{'sub_name'}(";  	
  my %options;
  my $have_opts = 0;

  foreach my $v (split(/,/, $optstr)) {
    if ($v =~ /=/) {
      my ($opt, $val) = split(/=/, $v);
      $options{uc $opt} = $val;
    } else {
      if ($actinfo->{$key}{'def_arg'} eq 'MODES') {
	push(@{$options{$actinfo->{$key}{'def_arg'}}}, $v);
      } else {
	$v =~ s/@/\\@/g;
	$options{$actinfo->{$key}{'def_arg'}} = $v;
      }
    }
  }

  if ($key =~ /(exec|pipe)/) {
#    $options{'MESSAGE'} = '$sanitized_';
    $options{'COMMAND'} = convert_command('sanitized_', $options{'COMMAND'});
  } elsif ($key =~ /(mail|write|echo)/) {
    $options{'MESSAGE'} = '$_';
  }

  my $opts = '';
  if (scalar %options) {
    foreach my $k (keys %options) {
      if ($k eq 'MODES') {
	$opts .= "\'$k\' => [ ";
	foreach my $v (@{$options{$k}}) {
	  $opts .= "\"$v\",";
	}
	$opts .= " ], ";
      } else {
	$opts .= "\'$k\' => \"$options{$k}\", "; # if (defined $options{$k});
      }
    }
  }
  if ($key eq 'throttle') {
    return "$actinfo->{$key}{'sub_name'}('REGEX' => '$pattern', $opts)";
  } else {
    return "$actinfo->{$key}{'sub_name'}($opts)";
  }
}

#
# 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 {
  my $varname = shift;
  my $command = shift;
  my @new_cmd = ();

  $command =~ s/\$[0*]/\$$varname/g;

  foreach my $i (split(/\s+/, $command)) {
    if ($i =~ /\$([0-9]+)/) {
      my $n = substr($i, 1);
      $n--;
      push(@new_cmd, "\$$varname\[$n\]");
    } else {
      push(@new_cmd, $i);
    }
  }
#  $command =~ s/\$([0-9]+)/\$_[$1]/g;

  return join(' ', @new_cmd);;
}

## Subroutines supporting the make_script subroutine

sub make_ignore_block {
  my $ref = shift;
  dprint(4, "ignoring $ref->{pattern}");
  return "\tnext;\n";
}

sub make_watchfor_block {
  my $pattern = shift;
  my $ref = shift;
  my $code = "";
  my $do_quit = 0;
  my $do_continue = 0;

  if (exists $ref->{"throttle"}) {
    $code = "      if ((\$_ = ";
    $code .=  action_def_to_subroutine_call('throttle', $ref->{'throttle'}{value}, $pattern);
    $code .=  ") ne '') {\n";
  }
  dprint(4,"watching $ref->{pattern}");

  foreach my $a_ref (@{$ref->{actions}}) {
    my $act = $a_ref->{action};
    if ($act eq 'continue') {
      $do_continue = 1;
    } elsif ($act eq 'quit') {
      $do_quit = 1
    } else {
      $code .= "\t";
      $code .= action_def_to_subroutine_call($act, $a_ref->{value});
      $code .= ";\n";
    }
  }

  if ($do_quit) {
    $code .= "\texit;\n";
  } elsif (not $do_continue) {
    $code .= "\tnext;\n";
  }
  
  if (exists $ref->{"throttle"}) {
    $code .= "      }\n";
  }
  
  return $code;
}

# $key_to_script_func = {
#     ignore => \&make_ignore_block,
# };

#
# make_script() - The workhorse for creating the script that will do the
# message processing.
#
# returns a string which contains the full script.
#
sub make_script {
  my $key;
  my $i = 0;
  my $script = make_start_code();
  $script .= make_throttle_code;
  $script .= make_action_subs();
  $script .= make_start_loop();

  for my $rec (0..$#Config) {
    my $pattern = $Config[$rec]->{pattern};
    my $config = $Config[$rec];
    if ($i) {
      $script .= "    }\n\n";
    }
    $script .= "    if ($pattern) {\n";
    $i++;

    $key = $config->{keyword};
    if ($key =~ /^ignore$/) { 
      $script .= make_ignore_block($config);
    } elsif ($key =~ /^watchfor$/) {
      $script .= make_watchfor_block($pattern, $config);
    }
  }
  $script .= "    }\n";

  $script .= make_end_code;
  return $script;
}

#
# terminate
#
# usage: terminate($SIGNAL);
#
sub terminate {
    my($Sig) = shift;
    dprint(16, "terminate($Sig)");
    return if $pid == 0;

    if ($Sig) { 
      print STDERR "Caught a SIG$Sig -- sending a TERM signal to $pid\n" 
    }
    kill('TERM', $pid) unless $opt_dump_script;
    $Restart = 0;
}


#
# restart -- kill the child, delete the script, and start over.
#
# usage: &restart($Sig);
#
sub restart {
    my($Sig) = shift;
    dprint(16, "restart($Sig)");
    print STDERR "Caught a SIG$Sig -- sending a TERM signal to $pid\n";
    kill('TERM', $pid);
    $Restart = 1;
}
## Courtesy of "Shoshana Abrass" <shoshana@anim.dreamworks.com> ...
##
## USAGE: set_restart_time(timestring)
## WHICH: converts the user-given timestring into the time (in unix 
##        seconds) when the program should next restart
## WHERE: "timestring" is one of the supported command-line arguments, 
##        for example:
##
##       00:01       restart every day at 12:01 AM
##      +24:00       restart every 24 hours
##       +1:00       restart every hour
##
##   There is currently no way to say "restart at the next HH:00 and every
##   hour after that", but it might be a nice feature.
##
## RETURNS: seconds since Jan 1 1970  of the next restart time.
##
sub set_restart_time{
  my ($timestring)=(@_);
  my ($DeltaHrs, $DeltaMins, $RestartTime);
  
  my ($OneMinute, $OneHour, $OneDay) = (60, 3600, 86400); # In seconds
  my ($EndOfTime) = (2147483647);                         # Mon Jan 18 19:14:07 2038

  $Now = time();

  if ( $timestring =~ m/^\+/ ) {
    if ( $timestring =~ m/^\+(\d+):(\d+)$/  ) {
      #
      #
      $DeltaHrs = $1 * $OneHour;
      $DeltaMins = $2 * $OneMinute;

      $RestartTime = $Now + $DeltaHrs + $DeltaMins;
      if ( $RestartTime >= $EndOfTime ) {
	print "ERROR: Restart time delta would put us past the end of\n";
	print "       unix time, ", ctime ($EndOfTime);
	die "       Unacceptable time delta\n";
      }
    }
    else {
      die "Unrecognized delta time format \"$timestring\"\n";
    }
  }
  else {
    if ( ! ($RestartTime = str2time("$timestring")) ) {
      die "Unrecognized time format \"$timestring\"\n";
    }
    while ( $RestartTime < $Now  ) {
      # if the time of day has already passed, then   
      # the user must mean that time tomorrow
      dprint(32, "set_restart_time(): adding a day to RestartTime $RestartTime (unix seconds)");
      $RestartTime += $OneDay;
    }
  }
  
  return ($RestartTime);
}
## Courtesy of "Shoshana Abrass" <shoshana@anim.dreamworks.com> ...
##
## USAGE: set_alarm (seconds)
##
## WHICH: Takes an absolute time value in unix seconds, and sets the alarm 
##        to go off at that time by subtracting $Now seconds.  We want to use 
##        the same value of $Now that was used above in set_restart_time, 
##        because
##            (1) we presume these functions are being called sequentially;
##            (2) to calculate against one $Now and set against another 
##                doesn't make sense.
##
sub set_alarm{
  my ($RestartTime) = @_;

  # carp "Called set_alarm";

  if ( $Now == 0 ) { $Now = time();}  # This should never happen

  if ( $RestartTime <= $Now ) {

    # This should never happen, because the intention is that
    # set_restart_time should be called before set_alarm. 
    # But just in case....
    print "WARNING: setting restart alarm to zero\n";
    alarm(0);
  }
  else {
    alarm ($RestartTime - $Now);
  }

}

#
# write_pid_file(file_name) - writes a one line file that contains
# the current process id.
#
sub write_pid_file {
  my $name = shift;
  my $fh = new FileHandle "$name", "w";

  if (defined($fh)) {
    $fh->write("$$\n");
    undef $fh;
  } else {
    warn "$Me: cannot write pid file named $name: $!\n";
  }
}
##
## doit()
##
sub doit {
  $SIG{'INT'} = $SIG{'QUIT'} = $SIG{'TERM'} = $SIG{'ALRM'} = $SIG{'HUP'} = 'default';

  $Config_File = (defined $opt_config_file) ? $opt_config_file : $DEF_CONFIG_FILE;
  
  ## Read in the configuration file ##
  if ($opt_old_style_config) {
    @Config = read_old_config($Config_File);
  } else {
    @Config = read_config($Config_File);
  }

  ## Create a script based on the configuration file and command line options
  my $Watcher_Script = make_script;
  

  if (defined $opt_dump_script) {## Just write the script to STDOUT and exit
    print "### Watcher Script BEGIN ###\n";
    print $Watcher_Script;
    print "### Watcher Script END ###\n";
    $Done = 1;
  } else { ## Write the script to a file and run it ##

    ## Write the script file ##
    my $script_file = defined($opt_script_dir) ? $opt_script_dir : $ENV{'HOME'};
    $script_file .= "/.swatch_script.$$";
    my $swatch_fh = new FileHandle $script_file, "w";
    if (defined $swatch_fh) {
      $swatch_fh->print($Watcher_Script);
      $swatch_fh->close;

    ## Now fork and start monitoring ##
    FORK: {
	if ($pid = fork) {
	  dprint(8, "doit(): pid = $pid");
	  foreach my $k (sort keys %SIG) {
	    dprint(8, "doit(): a: $k => $SIG{$k}") if defined $SIG{$k};
	  }
	  $SIG{'INT'} = $SIG{'QUIT'} = $SIG{'TERM'} = 'terminate';
	  $SIG{'ALRM'} = $SIG{'HUP'} = 'restart';
	  foreach my $k (sort keys %SIG) {
	    dprint(8, "doit(): b: $k => $SIG{$k}") if defined $SIG{$k};
	  }
	  if ( defined $opt_restart_time ) {
	    my $RestartTime = set_restart_time($opt_restart_time);
	    print "Will restart at ", ctime($RestartTime);
	    set_alarm ($RestartTime);
	  }
	  waitpid($pid, 0);
	  alarm(0);
	} elsif (defined $pid) {
	  exec("$PERL $script_file");
	} elsif ($! =~ /No more processes/) {
	  # EAGAIN, supposedly recoverable fork error
	  sleep 5;
	  redo FORK;
	} else {
	  die "$Me: Can't fork: $!\n";
	}
      }
      $Done = 1 if (not $Restart); # Restart set to 1 by restart() #
      unlink($script_file);
    }
  }
}

###
### MAIN
###

$Done = 0;
$Restart = 0;

#write_pid_file($opt_pid_file) if defined $opt_pid_file);
while (!$Done) {
  parse_command_line;

  main::doit();
}

###
### End of main block
###
