presence detection (Synology)

#! /usr/bin/perl
use warnings;
use strict;
use Getopt::Std;
use POSIX qw (setsid strftime);
use File::Path qw (mkpath);
use Net::Ping;
$ENV{PATH} = "/bin:/usr/bin";

# makes END() block called by signals
# ref: http://perldoc.perl.org/perlfaq8.html#How-can-I-do-an-atexit()-or-setjmp()%2flongjmp()%3f-(Exception-handling)
use sigtrap qw(die normal-signals);

my @devices;

chdir "/tmp";

sub daemonize {
   POSIX::setsid or die "setsid: $!";
   my $pid = fork ();
   if ($pid < 0) {
      die "fork: $!";
   } elsif ($pid) {
      exit 0;
   }
   open (STDIN, "</dev/null");
   open (STDOUT, ">/dev/null");
   open (STDERR, ">&STDOUT");
}

#
# c: ping count (default=2)
# w: ping timeout seconds(default=2)
# i: ping interval seconds (default=60)
# D
my $optswitches = "";
my %opts = (
    v => undef,                 # verbose
    d => undef,                 # daemonize
    w => 2,
    c => 2,
    i => 60,                    # ping interval
    D => "/var/run/presence.d",
    H => "/var/log/presence-%Y-%m.tsv",
    C =>  "/etc/presence.conf",
    W => undef,                 # wipe (erase history)
    );


map {
    $optswitches .= $_;
    $optswitches .= ":" if defined($opts{$_});
} keys %opts ;
getopts($optswitches, \%opts) or die "invalid option(s)\n";  # options as above. Values in %opts

my $verbose = $opts{v};
my $STATEDIR = $opts{D};
my $HISTFILE = $opts{H};
my $CONF = $opts{C};
my $PIDFILE = "/var/run/presence.pid";
mkpath $STATEDIR;

#+
#   Parse config file
#-
open my $conf, "<", $CONF or die "$! opening $CONF\n";
while (<$conf>) {
    s/#.*$//;
    next unless /^\s*(\S+)\s+(.*)\s*$/;
    push @devices, {
        IP => $1,
        name => $2,
        state => "unknown",
    };
};

daemonize if $opts{d};
open my $pidfile_h, ">", $PIDFILE or die "$! creating $PIDFILE\n";
$pidfile_h->print("$$\n");
$pidfile_h->close();

#+
#   check device  background, returns pid
#-
sub check {
    my $pid = fork ();
    if ($pid < 0) {
        die "fork: $!";
    };
    return $pid if $pid;

    #+
    #   Forked
    #-
    $PIDFILE = undef;   # prevent removing of PID file by background processes
    my $device = shift;
    my $IP = $device->{IP};
    my $count = $opts{c};
    my $timeout = $opts{w};
    my $p = Net::Ping->new("icmp");
    while ($count) {
        exit 0 if $p->ping($IP, $timeout);
        $count--;
    }
    exit 1;
}

#+
#   variable history file name using strftime
#-
sub histfile_name {
        return  POSIX::strftime($HISTFILE, localtime);
}

my $histfile_h;

# wipe history?
if ($opts{W}) {
    my $name = histfile_name;
    open $histfile_h, ">", $name or die "$! opening $name\n";
    close $histfile_h;
};

#+
#    Main Loop
#-
for (;;) {
    my %deviceforpid;

    #+
    #   fork pings threads in background
    #-
    foreach my $device (@devices) {
        my $pid = check  $device;
        $deviceforpid{$pid} = $device;
    }

    #+
    #   waits for results and update state files
    #-
    my $histfile_name = histfile_name;
    open my $histfile_h, ">>", $histfile_name or die "$! opening $histfile_name\n";
    while (my $pid = wait()) {
        last if $pid < 0;
        my $status=$?;

        my $device = $deviceforpid{$pid};
        my $state  = $status == 0 ? "on" : "off";
        print STDERR "$device->{IP} ($device->{name}), status=$status, state=$state\n" if $verbose;
        next if ($device->{state} eq $state); # not changed since last pass
        $device->{state}  = $state;

        #+
        #   update per device state file
        #-
        my $statefile = $STATEDIR . "/" . $device->{name} . ".state";
        open my $statefile_h, ">", "$statefile" or die "$! while opening $statefile\n";
        $statefile_h->print("$state\n");

        #+
        #   update history file
        #-
        my $timestamp=POSIX::strftime("%F %T", localtime);
        $histfile_h->print(join("\t", $timestamp, $device->{name}, $state));
        $histfile_h->print("\n");

    }
    close($histfile_h);
    print STDERR "sleeping...\n" if $verbose;
    sleep $opts{i};
}


1;

END {
    unlink $PIDFILE if defined $PIDFILE;
};

# Local Variables:
# mode: perl
# End: