ljr/wcmtools/spud/bin/wrapper

163 lines
4.3 KiB
Perl
Executable File

#!/usr/bin/perl
#
# Danga's Statistics Wrapper
# This little program simply runs a command and pipes the output to a
# statistics server so that you can see the output of the command. Data
# will be stored in $KEY.output and $KEY.status, so you can determine
# exactly how long a run took.
#
# Command line options:
#
# -s STRING server to connect to
# -p INT port statistics server is running on
# -k STRING key to put data in ($KEY.status, $KEY.output)
# -e STRING command to execute
# -c STRING file to load config data from
#
# Configuration file format:
#
# server = STRING location of server
# port = INT port of server
#
# Copyright 2004, Danga Interactive
#
# Authors:
# Mark Smith <marksmith@danga.com>
#
# License:
# undecided.
#
# uses
use strict;
use IO::Socket;
use IPC::Open3;
use Getopt::Long;
use Carp;
use POSIX;
# Command-line options will override
my ($daemonize, $conf_file, $key, $host, $port, $cmd);
Getopt::Long::Configure( "bundling" );
Getopt::Long::GetOptions(
'D|daemon' => \$daemonize,
'c|config=s' => \$conf_file,
'k|key=s' => \$key,
'p|port=i' => \$port,
's|server=s' => \$host,
'e|exec=s' => \$cmd,
);
# if we don't have all the data we need, parse a config file
die "No key (-k KEY) specified.\n" unless $key;
unless ($port && $host) {
die "You must at least specify --config=FILENAME for me to work.\n" unless $conf_file;
die "File '$conf_file' doesn't exist for configuration.\n" unless -e $conf_file;
# parse the config file
open FILE, "<$conf_file"
or die "Unable to open config file: $!\n";
while (my $line = <FILE>) {
if ($line =~ /^\s*([^#].*)\s*=\s*(.*)\s*/) {
my ($l, $r) = (trim($1), trim($2));
if ($l eq 'server') { $host = $r; }
elsif ($l eq 'port') { $port = $r+0; }
}
}
close FILE;
}
# if cmd was specified, use that
@ARGV = split /\s+/, $cmd if $cmd;
# error checking
die "No server to connect to.\n" unless $port && $host;
die "No arguments to run.\n" unless @ARGV;
die "File to run ($ARGV[0]) doesn't seem to exist.\n" unless -e $ARGV[0];
# daemonize?
daemonize() if $daemonize;
# connect to stats server we're replicating TO
my $socket = IO::Socket::INET->new(Proto => 'tcp',
PeerAddr => $host,
PeerPort => $port,)
or die "Unable to connect to local stats server ($host:$port): $!\n";
$socket->autoflush(1);
# now setup our open3 socket
my ($reader, $writer);
my $procpid = open3($writer, $reader, $reader, @ARGV);
# parent pid
my $ppid = $$;
# now fork
my $kidpid;
die "Unable to fork: $!\n" unless defined($kidpid = fork());
# basic parts that handle reading/writing from the two sides
if ($kidpid) {
# parent
while (defined (my $line = <$socket>)) {
# we do this to flush the read buffer, but we don't need to
# echo this information to anybody, as all of this is going
# to be in the form of "OK" and such saying that data got set
}
kill("TERM" => $kidpid); # death to the children
waitpid $kidpid, 0;
} else {
# child
print $socket "QSET $key.status started\n";
while (defined (my $line = <$reader>)) {
# take the output and set it
$line = trim($line);
print $socket "QSET $key.output $line\n";
}
print $socket "QSET $key.status finished\n";
$socket->close;
# now kill off our parent
kill("TERM" => $ppid);
}
# daemonizer routine
sub daemonize {
my($pid, $sess_id, $i);
## Fork and exit parent
if ($pid = fork) { exit 0; }
## Detach ourselves from the terminal
croak "Cannot detach from controlling terminal"
unless $sess_id = POSIX::setsid();
## Prevent possibility of acquiring a controling terminal
$SIG{'HUP'} = 'IGNORE';
if ($pid = fork) { exit 0; }
## Change working directory
chdir "/";
## Clear file creation mask
umask 0;
## Close open file descriptors
close(STDIN);
close(STDOUT);
close(STDERR);
## Reopen stderr, stdout, stdin to /dev/null
open(STDIN, "+>/dev/null");
open(STDOUT, "+>&STDIN");
open(STDERR, "+>&STDIN");
}
# little trimming sub
sub trim {
my $res = shift;
$res =~ s/^\s+//;
$res =~ s/[\r\n\s]+$//;
return $res;
}