view release on metacpan or  search on metacpan

examples/logwatch  view on Meta::CPAN

sub forked (&) {
    my ($thunk) = @_;
    if (my $pid = xfork) {
        $pid
    } else {
        &$thunk();
        exit 0;
    }
}

# /lib

use Scalar::Util qw(weaken);
use Sys::Hostname qw(hostname);
use Chj::xopen;
use Chj::IO::Command;
use Chj::xpipe;
use Chj::singlequote;
use FP::Show;

#use FP::Repl::Trap; # or Chj::Backtrace
#use FP::Repl;

sub safe_for_mail($str) {
    $str =~ /^([^\r\n\t]*)\z/s ? $1 : die "not safe for mail: " . show($str);

    # (should really escape instead, but don't want to make it
    # complex)
}

# to be accessible by code at $configpath (hacky?)
sub report_mailto ($from, $to) {
    my $_from = safe_for_mail($from);
    my $_to   = safe_for_mail($to);
    sub($path) {
        my $sendmail = Chj::IO::Command->new_receiver("sendmail", "-t");
        my $in       = xopen_read($path);
        $sendmail->xprintln("From: $_from");
        $sendmail->xprintln("To: $_to");
        $sendmail->xprintln("Subject: "
                . safe_for_mail($myname) . " "
                . safe_for_mail($configpath));
        $sendmail->xprintln;
        $sendmail->xprintln(
            "$0 on " . hostname() . " found the following log messages:");
        $sendmail->xprintln;
        $sendmail->xflush;
        $in->xsendfile_to($sendmail);
        $in->xclose;
        $sendmail->xxfinish;
        unlink $path;
    }
}

sub require_config($path) {
    my $arg = untainted($path =~ m|^\.{0,2}/| ? $path : "./$path");
    require $arg
}

use Hash::Util 'lock_hash';
my $config = require_config $configpath;

# (btw unlike 'eval' this doesn't give the code in question access to
# lexicals, right?)
lock_hash %$config;

my $REPORTMSG = "REPORT-" . rand();    # XX not enough randomness

my ($r, $w) = xpipe;

use Chj::xtmpfile;

sub xtmpfile_noautoclean () {
    my $t = xtmpfile;
    $t->autoclean(0);
    $t
}

sub processlines_ ($lines, $out, $maybe_reporterpid) {
    weaken $_[0];
    my ($line, $rest) = $lines->first_and_rest;
    warn "line='$line', maybe_reporterpid=" . singlequote($maybe_reporterpid)
        if $verbose;
    if ($line =~ /^$REPORTMSG/) {
        warn "REPORT!" if $verbose;

        # XX is it really guaranteed that lines are never broken
        # apart?
        $out->xclose;
        $$config{report}->($out->path);
        xxwaitpid $maybe_reporterpid;
        tail processlines_($rest, xtmpfile_noautoclean, undef)
    } else {
        if ($$config{match}->($line)) {
            my $t_report = time + $$config{collecttime};
            $out->xprint($line);
            tail processlines_(
                $rest, $out,
                $maybe_reporterpid // forked {
                    $r->xclose;
                    sleep_until $t_report;
                    $w->xprintln($REPORTMSG);
                    $w->xclose;
                    warn "sent $REPORTMSG" if $verbose;
                }
            );
        } else {
            tail processlines_($rest, $out, $maybe_reporterpid)
        }
    }
}

sub processlines($lines) {
    weaken $_[0];
    processlines_($lines, xtmpfile_noautoclean, undef)
}

my $tailpid = forked {
    $r->xclose;
    $w->xdup2(1);
    xexec @tailcmd, "--", $$config{logfile};