#!/usr/bin/perl -w
# -*- perl -*-
# WOTS - Copyright Tony Curtis <Tony.Curtis@vcpc.univie.ac.at> 1997, 1998
#
# There are no restrictions on what you can do with this code.
# If you want to use it in something that makes money, no problem.
# The only thing is that I require you to include the copyright line above
# in its entirety in any code fragments, libraries, or other forms of
# software which are derived from all or part of the code belonging to
# WOTS.
#
require 5.0;

use strict;
no strict qw(refs);

use Getopt::Long;				  # option handler
use POSIX;					  # useful functions
use FileHandle;					  # stream flushing

# comment out the next 2 lines if you don't have/want fancy echo or mail.
use Term::ANSIColor;
use Mail::Send;

# ----------------------------------------------------------------------------

autoflush STDOUT 1;

# auto-reset highlighting after each output line
$Term::ANSIColor::EACHLINE = "\n";

use File::Basename;
my $prog = basename($0);

my %options;

my $def_poll = 5;
my $def_count = (-1);
my $def_cfg  = ".${prog}rc";
my $def_pid  = "./${prog}.pid";

GetOptions("config=s"  => \$options{config},
           "pidfile=s" => \$options{pidfile},
	   "debug:s"   => \$options{debug},
	   "count=i"   => \$options{count},
           "help"      => \$options{help},
           "version"   => \$options{version},
	   "daemon:s"  => \$options{daemon}
           ) ||
    usage();

debug_canonify();

usage() if $options{help};
die "1.22\n" if $options{version};

# ----------------------------------------------------------------------------

# state
my %patterns;
my %actions;
my %fromtypes;
my %exec_counter;
my %handles;
my %last_sizes;
my %formats;
my @SOURCES;
my %children;
my %global_formats;

my ($username, $homedir);

# set things up initially
init_runtime();

# ----------------------------------------------------------------------------

# TODO: check for lock
# save pid for later signalling
if ($options{count} != 1) {
    my $now = POSIX::strftime("%Y-%m-%d %T", POSIX::localtime(time));
    print "$prog: $now Version 1.22 ready (pid $$)\n";
    if (open(P, "> $options{pidfile}")) {
        print P "$$\n";
        close P;
    } else {
	warn "$prog: can't save pid (can't write to \`$options{pidfile}')\n";
    }
}

# --------------------------------------------------------------------------

poller();
clean_exit();

# --------------------------------------------------------------------------

sub poller {
    my $pass = 0;
    while ($options{count} != 0) {
	tracer("pass", ++$pass);

	map {check_a_source($_)} @SOURCES;

	tracer("sleep", $options{poll});
	sleep $options{poll};

	--$options{count} unless $options{count} < 0;
    }
}

# --------------------------------------------------------------------------

sub check_a_source {
    my ($from) = @_;
    my $in;

    tracer("poll", $from);

    if ($fromtypes{$from} eq 'file') {
	# this appears to be a bug on FreeBSD
	# return if eof $handles{$from};

	# my $old_size = $last_sizes{$from};		  # debugging
	while ($in = $handles{$from}->getline) {
	    chomp $in;
	    check_a_line($from, $in);
	}
	my $new_size = tell $handles{$from};	  # if we want to look at it
	$last_sizes{$from} = $new_size;
    } elsif ($fromtypes{$from} eq "cmd" || $fromtypes{$from} eq "once") {
        ++$exec_counter{$from};

        if ($fromtypes{$from} eq "once" && $exec_counter{$from} < 2) {
            if (open(P, "$from |")) {
                while (defined($in = <P>)) {
                    chomp $in;
                    check_a_line($from, $in);
                }
                close P;
            } else {
                warn "$prog: couldn't run command \`$from'\n";
            }
        } else {
            tracer("won't rerun \`once' command \`$from'");
        }
    }
}

sub check_a_line {
    my ($from, $line) = @_;
    my $i;

    foreach my $p (@{$actions{$from}{patorder}}) {
	tracer("match /$p/ ?");
	next if $line !~ /$p/;
        # save the numbered matches
        my %match;
        foreach my $i (1 .. 10) {
            eval "\$match{\$i} = \$$i";
        }
        # look for matches
	foreach $a (@{$actions{$from}{$p}}) { # a match!
	    my $action; my $retten;
	    ($retten = $a) =~ s/\\,/\%2C/g;
	    my @actions = split(/,/, $retten);
	    foreach $action (@actions) {
		my ($ax, $rest) = split(/=/, $action);
		$action = $ax if defined $rest;
		my $handler = "handle_$action";
		# protect arguments from weird quoting
		if (defined &$handler) {
                    $rest = "" if ! defined $rest;
		    $rest =~ s/\%2C/,/g;
		    tracer("handle", $action);
                    $rest =~ s/\$(\d+)/$match{$1}/g;
		    &$handler(qq[$from], qq[$line], qq[$rest]);
		} else {
		    tracer("unknown", $action);
		}
	    }
	}
	last;					  # one pattern match only
    }
}
# ----------------------------------------------------------------------------
#
# handlers for actions
#

# well, that was difficult
sub handle_ignore {
    tracer("ignore");
}

sub handle_exec {
    my ($L, $M, $cmd) = @_;
    my $bg = 0;
    # background command?
    if ($cmd =~ /\&$/) {
	$cmd =~ s/\s*\&$//;			  # chop off &
	$bg = 1;
    }
    $cmd = format_unescape($L, $M, "exec", $cmd);
    tracer("$cmd");
    my $pid = fork();
    if (! defined $pid) {			  # error
	warn "$prog: fork() failed: $!\n";
    } elsif ($pid == 0) {			  # child becomes command
	exec $cmd;
    } else {					  # parent
	if ($bg) {
	    $children{$pid} = $pid;		  # just record it
	} else {
	    wait;                                 # TODO: !
	}
    }
}

sub handle_echo {
    my ($L, $M, $style) = @_;
    tracer($style);
    $style = join(" ", split(/;/, $style));       # make ANSI ctrl
    my $msg = format_unescape($L, $M, "echo");
    if ($style) {
        print colored($msg, $style);
    } else {
        print $msg;
    }
    print "\n";
}

# replace logfile/message formatting info
sub format_unescape {
    my ($L, $M, $type, $msg) = @_;

    if (! defined $msg || $msg eq "") {
        $msg = $formats{$type}{$L} || $global_formats{$type};
    }
    my @now = POSIX::localtime(time);
    $msg = POSIX::strftime($msg, @now);
    $msg =~ s/\\(.)/ctrlify($1)/ge;
    $msg =~ s/~L/$L/g;
    $msg =~ s/~M/$M/g;
    $msg;
}
sub ctrlify {
    my ($c) = @_;
    return "\n" if $c eq 'n';
    return "\r" if $c eq 'r';
    return "\b" if $c eq 'b';
    $c;
}

sub handle_mail {
    my ($L, $M, $to) = @_;

    $to ||= $username;

    tracer("to $to");

    my $m = new Mail::Send
        Subject => "LOG EVENT in $L",
        To => $to;
    my $body = $m->open;                          # TODO: open unchecked!!
    my $msg = format_unescape($L, $M, "mail");
    print $body "$msg\n";
    $body->close;                                 # send it
}

# should this be an echo style?
sub handle_bell {
    my ($L, $M) = @_;
    print "\007";				  # no bell in ANSIColor?
}

# ----------------------------------------------------------------------------
#
# set all to 0 if just scanning once so we read the whole file
#
sub set_handle_sizes {
    %last_sizes = ();
    my $n;
    my ($s, $h);

    while (($s,$h) = each %handles) {
	if ($options{count} == 1) {
	    $n = 0;
	} else {
	    seek($h, 0, 2);
	    $n = tell $h;
	}
	$last_sizes{$s} = $n;
	tracer("size $s => $n");
    }
}

# ----------------------------------------------------------------------------

sub init_signals {
    $SIG{HUP}  = 'reread_config';
    $SIG{INT}  = 'ctrl_c_exit';
    $SIG{TERM} = 'ctrl_c_exit';
    $SIG{CHLD} = sub { wait };
    tracer("signal handlers");
}

sub daemonise {
    my $pid = fork();
    if (! defined $pid) {			  # error
	tracer("fork() error");
	die "$prog: fatal identity crisis (uid $<)\n";
    }

    exit 0 if $pid > 0;				  # parent exit
    tracer("child", "fork() -> $$");			  # child reports self
}

sub reread_config {
    my $sig = shift;
    warn "\n$prog: signal SIG$sig, rereading config...\n";
    init_runtime();
}

sub ctrl_c_exit {
    my $sig = shift;
    warn "\n$prog: signal SIG$sig, exit...\n";
    clean_exit();
}

sub clean_exit {
    reap_children();
    unlink $options{pidfile};
    tracer("tidy up pidfile");
    exit 0;
}

sub reap_children {
    for (keys %children) {
	kill TERM => $_;
	tracer("reap $_");
    }
}

# ----------------------------------------------------------------------------

# init parser state
sub init_state {
    %patterns     = ();
    %actions      = ();
    %handles      = ();
    @SOURCES      = ();
    %children     = ();
    %exec_counter = ();
}

# ----------------------------------------------------------------------------

sub init_runtime {
    tracer("version 1.22 initialising runtime");
    reap_children();
    init_state();
    init_user();
    read_config();
    sanitise_options();
    set_handle_sizes();
    init_signals();
    daemonise() if $options{daemon} eq "on";
}

# ----------------------------------------------------------------------------

sub init_user {
    # set up environment
    ($username, $homedir) = getuserinfo($<);
    die "$prog: fatal identity crisis (uid $<)\n" if ! $username;
}

# ----------------------------------------------------------------------------

sub sanitise_options {
    tracer("settings");
    # do we nice ourselves?
    POSIX::nice($options{nice}) if $options{nice};
    # sanitise option settings
    $options{poll} ||= $def_poll;
    $options{poll} = 1 if $options{poll} < 1;
    $options{pidfile} ||= $def_pid;
    $options{count} ||= $def_count;
    # these feel clumsy, something to think about
    debug_canonify();
    debug_daemonise();
    # how to echo output (override in config file)
    $global_formats{echo} = "~L:~M";
    $global_formats{'exec'} = "~L:~M";
    $global_formats{mail} = "~M";
}

sub debug_canonify {
    # canon debug
    if (defined $options{debug}) {
	$options{debug} = "on" if $options{debug} eq "";
	if ($options{debug} ne "on" &&
	    $options{debug} ne "off") {
	    usage();
	    # NOT REACHED
	}
    } else {
	$options{debug} = "off";
    }
}
sub debug_daemonise {
    # canon daemon (is that a pun?)
    if (defined $options{daemon}) {
	$options{daemon} = "on" if $options{daemon} eq "";
	if ($options{daemon} ne "on" &&
	    $options{daemon} ne "off") {
	    usage();
	    # NOT REACHED
	}
    } else {
	$options{daemon} = "off";
    }
}

# ----------------------------------------------------------------------------

sub read_config {

    # config files from command line, or home dir
    my $wots_cfg = $options{config} || "$homedir/$def_cfg";

    if (! open(C, "< $wots_cfg")) {
	die "$prog: can't open configuration file \`$wots_cfg'\n";
    }

    tracer("read", $wots_cfg);

    my $line = 0;
    my $outside_from = 1;			  # initially global scope
    my $skip_to_next_from = 0;
    my $source;

    while (<C>) {
	++$line;
	chomp;
	s/\#.*//; s/^\s+//; s/\s+$//;		  # tidy input
	next if $_ eq "";

        if (m%^(config|set)\s+(\S+)\s+(.+)%) {
            $options{$2} = $3;
            tracer("$2 = $3");
            next;
        }

	if (m%^from\s+(.+)%i) {			  # new source
	    $outside_from = 0;
	    $source = $1;
	    if ($source =~ /^(!|pipe|once)/) {    # command to run
                my $style = $1;
		$source =~ s/^$style\s+//;
                # see if we run it again and again...
		$fromtypes{$source} = ($style eq "once") ? "once" : "cmd";
		push(@SOURCES, "$source");	  # keeps them in order
		next;
	    } else {				  # file to watch
		$fromtypes{$source} = 'file';
		my $fh = new FileHandle "< $source";
		if (defined $fh) {
		    push(@SOURCES, "$source");	  # keeps them in order
		    $handles{$source} = $fh;
		    $skip_to_next_from = 0;
		} else {
		    parse_warning($wots_cfg, $line, $_,
				  "can't read \`$source', skipping any patterns");
		    $outside_from = 1;
		    $skip_to_next_from = 1;
		}
		next;
	    }
	}
	if ($outside_from) {
	    if (m%^(echo|exec|mail)format\s+(.+)%i) {  # global format to echo|mail
		my ($t, $f) = ($1, $2);
		$global_formats{$t} = $f;
		$global_formats{$t} =~ s/^([\"\'])(.*)\1$/$2/;
		next;
	    }
	} else {
	    if (m%^(echo|exec|mail)format\s+(.+)%i) {  # local format to echo|mail
		my ($t, $f) = ($1, $2);
		$formats{$t}{$source} = $f;
		$formats{$t}{$source} =~ s/^([\"\'])(.*)\1$/$2/;
		next;
	    }
	    
	    if (m%^/([^/]+)/\s+(.+)%) {		  # pattern + action
                my ($pat, $act) = ($1, $2);
                # test it
                my $trap = eval qq( "dummy" =~ /$pat/ );
                if (! defined $trap) {
                    parse_warning($wots_cfg, $line, $_,
                                  "broken regexp, ignoring...");
                    next;
                }
		# save each pattern/action and the order
		push(@{$actions{$source}{patorder}}, $pat);
		push(@{$actions{$source}{$pat}}, $act);
		next;
	    }
	}
        next if $skip_to_next_from;
        parse_warning($wots_cfg, $line, $_,
                      "unknown syntax, ignoring...");
    }
    close C;
}
sub parse_warning {
    my ($I, $L, $T, $M) = @_;
    warn "$I:$L:$T\n";
    warn "$I:$L:  $M\n";
}

# ----------------------------------------------------------------------------

sub getuserinfo {
    my ($user) = @_;
    if ($user =~ /\D/) {
	getuserbyname($user);
    } else {
	getuserbyuid($user);
    }
}
sub getuserbyname {                               # private
    my ($user) = @_;
    my @pw = getpwnam($user);
    return undef if $#pw < 0;
    getuserinternal(@pw);
}
sub getuserbyuid {                                # private
    my ($user) = @_;
    my @pw = getpwuid($user);
    return undef if $#pw < 0;
    getuserinternal(@pw);
}
sub getuserinternal {
    tracer("user $_[0] homedir $_[7]");
    ($_[0], $_[7]);
}

# ----------------------------------------------------------------------------
    
sub tracer {
    return if $options{debug} ne "on";
    my @info = caller(1);
    my $subr = $info[3];
    warn "$prog:$subr: @_\n";
}

# ----------------------------------------------------------------------------

sub usage {
    die "Usage: $prog [options]
    ($prog uses the GNU extended POSIX option format)

    --config=FILE     read actions from FILE          (default: ~/$def_cfg)
    --pidfile=FILE    write my PID here               (default: $def_pid)
    --count=N         scan files N times              (default: forever)
    --debug[=on|off]  show copious debugging info     (default: off)
    --daemon[=on|off] put self into background        (default: off)
    --help            this option summary
    --version         show current version and exit

    This is $prog version 1.22

";

}
