#!/usr/bin/perl

eval 'exec /usr/bin/perl  -S $0 ${1+"$@"}'
    if 0; # not running under some shell
####### copyright begin #######
#
#    swatch: The Simple WATCHdog
#    Copyright (C) 1993-2003 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
#
####### copyright end #######
####### pod begin #######

=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 at 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 /var/log/messages exists

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.
These modes are made to work on xterm like windows. 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, except when used with the I<--daemon> 
command line option where it will simply exit.
Swatch will terminate gracefully
when it receives a QUIT, TERM, or INT signal.

=head1 AUTHOR

    E. Todd Atkins
    Todd.Atkins@StanfordAlumni.ORG

=head1 AVAILABILITY

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

=cut

####### pod end #######
####### use_and_variables begin #######
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_time_loc
  $opt_script_dir
  $opt_version
  @Config
  $Done
  $Restart
  $VERSION
  $Now
  $pid
  $tail_cmd_name
  $tail_program_args
  $use_cpan_file_tail
  /;

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 $DEF_INPUT;
if ( -f '/var/log/messages' ) {
    $DEF_INPUT = '/var/log/messages';
} elsif ( -f '/var/log/syslog' ) {
    $DEF_INPUT = '/var/log/syslog';
}

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\@StanfordAlumni.ORG>";
$VERSION = "3.0.8";
my $BUILD_DATE = "4 April 2003";

my $tail_cmd_name = ''; # We'll try to find it in the PATH later
my $tail_program_args = '-n 1 -f';  

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

####### print_version end #######
####### parse_command_line begin #######
sub parse_command_line {

  use Getopt::Long;
  Getopt::Long::config('bundling');
  die "$USAGE" if not GetOptions(
				 "config-file|c=s" => \$opt_config_file,
				 "daemon" => \$opt_daemon,
				 "debug-level=i" => $opt_debug_level,
				 "dump-script:s" => \$opt_dump_script,
				 "examine|f=s" => \$opt_examine,
				 "help|h" => \$opt_help,
				 "input-record-separator|I=s" => \$opt_input_record_separator,
				 "old-style-config|O" => \$opt_old_style_config,
				 "pid-file=s" => \$opt_pid_file,
				 "read-pipe|p=s" => \$opt_read_pipe,
				 "restart-time|r=s" => \$opt_restart_time,
				 "tail-file|t=s" => \$opt_tail_file,
				 "time-loc|time-location=s" => \$opt_time_loc,
				 "script-dir=s" => \$opt_script_dir,
				 "use-cpan-file-tail" => \$use_cpan_file_tail,
				 "version|V" => \$opt_version,
				);

  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; 
}

####### parse_command_line end #######
####### dprint begin #######
###
### 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);
}

####### dprint end #######
####### make_debug_code begin #######
#
# 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;
}

####### make_debug_code end #######
####### default_config begin #######
#
# returns a default array of records 
#
sub default_config {
  my @records;
  my $rec = (); # 

  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);
}

####### default_config end #######
####### is_valid_pattern begin #######
#
# checks validity of a regular expression. returns 1 if valid.
#
sub is_valid_pattern {
  my $pat = shift;
  return eval { "" =~ /$pat/; 1 } || 0;
}

####### is_valid_pattern end #######
####### read_config begin #######
#
# 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;
    return(default_config());
  }

  $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*$/);

    s/\#.*$//; ## strip trailing comments

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

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

      if (not is_valid_pattern($val)) {
	die "$Me: error in pattern \"$val\" on line $. of $filename\n";
      }

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

  ## Sanity Check: If the config file did not contain anything useful then 
  ## we need to return the default configuration.
  if ($#records < 0) {
    warn "$Me: There were no useful entries in the configuration file.\n";
    exit 1 if $opt_daemon;
    return(default_config());
  } else {
    return(@records);
  }
}

####### read_config end #######
####### read_old_config begin #######
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);
}

####### read_old_config end #######
####### make_start_code begin #######
#
# 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 );
  }
  if ($mail_cmd ne '') {
    $mail_cmd .= ' -oi -t'; 
  }
  foreach my $path (split(/:/, $ENV{'PATH'})) {
    $write_cmd = "$path/write" if ( -x "$path/write" );
  }

  $code  = qq[
#
#    swatch: The Simple WATCHdog
#    Copyright (C) 1993-2001 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 FileHandle;
use POSIX ":sys_wait_h";
use vars qw(%Msg_Rec);

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

## Constants
(my \$Me = \$0) =~ s%.*/%%;
my \$BELL   = "\007";
my \$MAILER = "$mail_cmd";
my \$WRITE  = "$write_cmd";
\$/ = "$opt_input_record_separator";

use IO::Handle;
STDOUT->autoflush(1);;

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;
  }
}

#
# 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)) {
    print $fh "$$\n";
    $fh->close;
  } else {
    warn "$Me: cannot write pid file named $name: $!\n";
  }
}
  |;

  if ($opt_daemon) {
    $code .= qq[
		my \$pid = fork;
		exit if \$pid;
		die "Couldn't fork: \$!" unless defined(\$pid);
		# dissociate from the controlling terminal
		POSIX::setsid() or die "Can't start new session: \$!"; 
		# set our named to 'swatch' so that rc scripts can 
		# figure out who we are.
		\$0="swatch";
	       ];
  } else {
    $code .= qq[
		print \"\\n*** ${Me} version ${VERSION} (pid:$$) started at \" . `/bin/date` . \"\\n\";
    ];
  }

  $code .= qq[ write_pid_file("$opt_pid_file"); ] if (defined $opt_pid_file);

  return $code;
}

####### make_start_code end #######
####### make_action_subs begin #######
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'});
  
  if ($MAILER eq '') {
    warn "ERROR: $0 cannot find a mail delivery program\n";
    return;
  }

  (my $to_line = $args{'ADDRESSES'}) =~ s/:/,/g;

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

  print MAIL "To: $to_line\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 ###

####### make_action_subs end #######
####### make_throttle_code begin #######

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

##
## parse_dot -- parse day or time
##
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));
    } else {
      $dot[$range] = 0;
    }
  }
  return @dot;
}

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;  # A string with the date and time stamp
  my $date_loc = shift; # The location of the date in the string indicated
                         # by cut marks or -1 if non-existent
                         # The cut marks are separated by a colon
                         # and go in the order: year, month, day
  my $time_loc = shift;  # The location of the time stamp. The cut marks
                         # are similar to $date_loc and go by the order:
                         # hours, minutes, seconds           
  my ($t_year,$t_month,$t_day) = Today();

  my ($y, $m, $d) = parse_dot($string, $date_loc);
  my ($hrs, $mins, $secs) = parse_dot($string, $time_loc);

  if ($m =~ /[A-Za-z]*/) {
    $m = $months{$m};
  }

  if ($y == 0) { $y = $t_year};
  if ($m == 0) { $m = $t_month };
  if ($d == 0) { $d = $t_day };

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

sub new_msg {
  my $use = shift;
  my $regex = 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 in $delta matching $regex: $msg";
  } 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",
	      USE        => 'message',
	      DATE_LOC   => "-1:0-2:4-5",    
	      TIME_LOC   => "7-8:10-11:13-14",
	      TS_FROM    => 'message',
	      @_
	     );

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

  if ($opts{'TS_FROM'} eq 'message') {
    @ymdhms = YMDHMS($msg, $opts{'DATE_LOC'}, $opts{'TIME_LOC'});
  } else {
    @ymdhms = Today_and_Now();
  }

  foreach my $i (0..$#min_dhms_delta) {
    # strip out unwanted elements
    splice (@min_dhms_delta, $i, 1) if ($min_dhms_delta[$i] =~ /[: ]/);
    $min_dhms_delta[$i] = 0 if (length($min_dhms_delta[$i]) == 0);
  }

  if ($use eq 'regex') {
    $key = $opts{'REGEX'};
  } else {
    my ($begin, $end) = split(/:/, $opts{'CUT_MARKS'});
    $key = substr($msg, 0, $begin);
    $key .= substr($msg, $end);
  }

  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, $opts{'REGEX'}, $opts{'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;
  }
}

&; #
} 

####### make_throttle_code end #######
####### make_start_loop begin #######
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);
    if ($use_cpan_file_tail) {
      $code = qq[
use File::Tail;
my \$Filename = '$filename';
my \$File = File::Tail->new(name=>\$Filename, tail=>1, maxinterval=>0.5, interval=>0.5);
if (not defined \$File) {
    die "$0: cannot read input \\"\$Filename\\": \$!\\n";
}

LOOP: while (defined(\$_=\$File->read)) {
];
    } else {
      if ($tail_cmd_name eq '') {
	foreach my $path (split(/:/,$ENV{'PATH'})) {
	  if (-x "${path}/tail") {
	    $tail_cmd_name = "$path/tail";
	    last;
	  }
	}
	die "$Me: cannot find \"tail\" program in PATH\n" if $tail_cmd_name eq '';
      }
       $code = qq/
my \$filename = '$filename';
if (not open(TAIL, \"$tail_cmd_name $tail_program_args \$filename|\")) {
    die "$0: cannot read run \\"$tail_cmd_name $tail_program_args \$filename\\": \$!\\n";
}

LOOP: while (<TAIL>) {
/;
    }
  }

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

!;
}

####### make_start_loop end #######
####### make_end_code begin #######
sub make_end_code {
    my $code;
    $code = q[
}
];
    return $code;
} 

####### make_end_code end #######
####### action_def_to_subroutine_call begin #######
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 %options;
  my $have_opts = 0;

  foreach my $v (split(/,/, $optstr)) {
    if ($v =~ /(\w+)\s*=\s*"?(\S+[^"]*)/) {
      $options{uc $1} = $2;
    } else {
      my $opt = $v;
      $opt =~ s/@/\\@/g;
      $opt =~ s/^['" ]*//;
      $opt =~ s/['" ]*$//;
      if ($actinfo->{$key}{'def_arg'} eq 'MODES') {
	push(@{$options{$actinfo->{$key}{'def_arg'}}}, $opt);
      } else {
	$options{$actinfo->{$key}{'def_arg'}} = $opt;
      }
    }
  }

  if ($key =~ /(exec|pipe)/) {
    if ($key =~ /pipe/) {
      $options{'MESSAGE'} = '$_';
    }
    $options{'COMMAND'} = convert_command('S_', $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});
      }
    }
  }

  my $sub_name = (exists $actinfo->{$key}{'sub_name'}) 
  ? $actinfo->{$key}{'sub_name'} : $key;

  if ($key eq 'throttle') {
    return "$sub_name('REGEX' => '$pattern', $opts)";
  } else {
    return "$sub_name($opts)";
  }
}

####### action_def_to_subroutine_call end #######
####### convert_command begin #######
#
# 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);;
}

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

####### make_ignore_block end #######
####### make_watchfor_block begin #######
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 (exists $ref->{"throttle"}) {
    $code .= "      }\n";
  }
  
  if ($do_quit) {
    $code .= "      exit;\n";
  } elsif (not $do_continue) {
    $code .= "      next;\n";
  }
  
  return $code;
}

####### make_watchfor_block end #######
####### make_script begin #######
#
# 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;
}

####### make_script end #######
####### terminate begin #######
#
# 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;
}

####### terminate end #######
####### restart begin #######
#
# 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;
}

####### restart end #######
####### set_restart_time begin #######
## 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);
}

####### set_restart_time end #######
####### set_alarm begin #######
## 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);
  }

}

####### set_alarm end #######
####### doit begin #######
##
## 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);
	  if (defined $opt_daemon) {
	    exit(0);
	  }
	} elsif (defined $pid) {
	  exec("$^X $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);
    }
  }
}

####### doit end #######
####### main begin #######
###
### MAIN
###

$Done = 0;
$Restart = 0;

while (!$Done) {
  parse_command_line;
  main::doit();
}

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