diff options
author | schnetter <schnetter@83718e91-0e4f-0410-abf4-91180603181f> | 2005-10-08 00:58:24 +0000 |
---|---|---|
committer | schnetter <schnetter@83718e91-0e4f-0410-abf4-91180603181f> | 2005-10-08 00:58:24 +0000 |
commit | b188b8cb2619492e4ca36edce57822ff5d4809e5 (patch) | |
tree | 70c541064bb6a90b55eeb99bab024d6862c1758e /src/util/formaline_receptacle.pl | |
parent | 3efaa94935fe6c1641f4951c4c9ed5a4aa7e6506 (diff) |
Add a perl script that may become an XML-RPC server in the future
which receives and stores the announced information off-site.
git-svn-id: http://svn.cactuscode.org/arrangements/CactusUtils/Formaline/trunk@62 83718e91-0e4f-0410-abf4-91180603181f
Diffstat (limited to 'src/util/formaline_receptacle.pl')
-rwxr-xr-x | src/util/formaline_receptacle.pl | 77 |
1 files changed, 77 insertions, 0 deletions
diff --git a/src/util/formaline_receptacle.pl b/src/util/formaline_receptacle.pl new file mode 100755 index 0000000..a591733 --- /dev/null +++ b/src/util/formaline_receptacle.pl @@ -0,0 +1,77 @@ +#!/usr/bin/perl -Tw + +# Taken from http://www.perl.com/doc/FMTEYEWTK/IPC/inet.html +# Adapted 2005-10-07 by Erik Schnetter <schnetter@cct.lsu.edu> + +require 5.002; + +use strict; +BEGIN { $ENV{PATH} = '/usr/ucb:/bin' } +use Socket; +use Carp; + +use File::Temp qw/ :mktemp /; + +sub spawn; # forward declaration +sub logmsg { print "$0 $$: @_ at ", scalar localtime, "\n" } + +my $port = shift || 9296; +my $proto = getprotobyname('tcp'); + +socket(SERVER, PF_INET, SOCK_STREAM, $proto) || die "socket: $!"; +setsockopt(SERVER, SOL_SOCKET, SO_REUSEADDR, 1) || die "setsockopt: $!"; +bind(SERVER, sockaddr_in($port, INADDR_ANY)) || die "bind: $!"; +listen(SERVER,5) || die "listen: $!"; +logmsg "server started on port $port"; + +my $waitedpid = 0; +my $paddr; + +sub REAPER +{ + $SIG{CHLD} = \&REAPER; # loathe sysV + $waitedpid = wait; + logmsg "reaped $waitedpid" . ($? ? " with exit $?" : ''); +} + +$SIG{CHLD} = \&REAPER; +for ($waitedpid = 0; + ($paddr = accept(CLIENT,SERVER)) || $waitedpid; + $waitedpid = 0, close CLIENT) +{ + next if $waitedpid; + my($port,$iaddr) = sockaddr_in($paddr); + my $name = gethostbyaddr($iaddr,AF_INET); + logmsg "connection from $name [", inet_ntoa($iaddr), "] at port $port"; + spawn sub { + my ($fh, $file) = mkstemps ('output-XXXXXXXX', '.txt'); + my $oldline = ''; + while (my $line = <STDIN>) { + print $fh $line; + last if ($oldline eq "\r\n" && $line eq "\r\n"); + $oldline = $line; + } + close $fh; + }; +} + +sub spawn +{ + my $coderef = shift; + unless (@_ == 0 && $coderef && ref($coderef) eq 'CODE') { + confess "usage: spawn CODEREF"; + } + my $pid; + if (!defined($pid = fork)) { + logmsg "cannot fork: $!"; + return; + } elsif ($pid) { + logmsg "forked $pid"; + return; # I'm the parent + } + # else I'm the child -- go spawn + open(STDIN, "<&CLIENT") || die "can't dup client to stdin"; + open(STDOUT, ">&CLIENT") || die "can't dup client to stdout"; + ## open(STDERR, ">&STDOUT") || die "can't dup stdout to stderr"; + exit &$coderef(); +} |