268 lines
7.2 KiB
Perl
Executable File
268 lines
7.2 KiB
Perl
Executable File
#!/usr/bin/perl -w
|
|
|
|
#------------------------------------------------------------------------------
|
|
#
|
|
# Copyright (C) 2006 Ingenieurgemeinschaft IgH
|
|
#
|
|
# This file is part of the IgH EtherCAT Master.
|
|
#
|
|
# The IgH EtherCAT Master is free software; you can redistribute it
|
|
# and/or modify it under the terms of the GNU General Public License
|
|
# as published by the Free Software Foundation; either version 2 of the
|
|
# License, or (at your option) any later version.
|
|
#
|
|
# The IgH EtherCAT Master is distributed in the hope that it will be
|
|
# useful, but WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
|
# GNU General Public License for more details.
|
|
#
|
|
# You should have received a copy of the GNU General Public License
|
|
# along with the IgH EtherCAT Master; if not, write to the Free Software
|
|
# Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA
|
|
#
|
|
# The right to use EtherCAT Technology is granted and comes free of
|
|
# charge under condition of compatibility of product made by
|
|
# Licensee. People intending to distribute/sell products based on the
|
|
# code, have to sign an agreement to guarantee that products using
|
|
# software based on IgH EtherCAT master stay compatible with the actual
|
|
# EtherCAT specification (which are released themselves as an open
|
|
# standard) as the (only) precondition to have the right to use EtherCAT
|
|
# Technology, IP and trade marks.
|
|
#
|
|
#------------------------------------------------------------------------------
|
|
#
|
|
# Multithreaded Server
|
|
# according to the example from "Programming Perl"
|
|
# this code is improved according to the example from
|
|
# perldoc perlipc, so now safely being usable under Perl 5.8
|
|
# (see note (*))
|
|
#
|
|
# works with read/write on a device-file
|
|
#
|
|
#------------------------------------------------------------------------------
|
|
|
|
require 5.002;
|
|
use strict;
|
|
BEGIN { $ENV{PATH} = '/opt/msr/bin:/usr/bin:/bin' }
|
|
use Socket;
|
|
use Carp;
|
|
use FileHandle;
|
|
use Getopt::Std;
|
|
|
|
use Sys::Syslog qw(:DEFAULT setlogsock);
|
|
|
|
use vars qw (
|
|
$self $pid $dolog $port $dev %opts $selfbase
|
|
$len $offset $stream $written $read $log $blksize
|
|
$instdir
|
|
$authfile %authhosts
|
|
);
|
|
|
|
|
|
# Do logging to local syslogd by unix-domain socket instead of inetd
|
|
setlogsock("unix");
|
|
|
|
# Prototypes and some little Tools
|
|
sub spawn;
|
|
sub logmsg {
|
|
my ($level, $debug, @text) = @_;
|
|
syslog("daemon|$level", @text) if $debug > $dolog;
|
|
# print STDERR "daemon|$level", @text, "\n" if $dolog;
|
|
}
|
|
sub out {
|
|
my $waitpid = wait;
|
|
logmsg("notice", 2, "$waitpid exited");
|
|
unlink "$selfbase.pid";
|
|
exit 0;
|
|
}
|
|
|
|
sub help {
|
|
print "\n usage: $0 [-l og] [-h elp] [-p port] [-d device]\n";
|
|
exit;
|
|
}
|
|
|
|
# Process Options
|
|
%opts = (
|
|
"l" => 1,
|
|
"h" => 0,
|
|
"p" => 2345,
|
|
"d" => "/dev/msr"
|
|
);
|
|
|
|
getopts("lhp:d:", \%opts);
|
|
|
|
help if $opts{"h"};
|
|
|
|
( $self = $0 ) =~ s+.*/++ ;
|
|
( $selfbase = $self ) =~ s/\..*//;
|
|
$log = "$selfbase.log";
|
|
$dolog = $opts{"l"};
|
|
$port = $opts{"p"};
|
|
$dev = $opts{"d"};
|
|
$blksize = 1024; # try to write as much bytes
|
|
$instdir = "/opt/msr";
|
|
$authfile = "$instdir/etc/hosts.auth";
|
|
|
|
# Start logging
|
|
openlog($self, 'pid');
|
|
|
|
# Flush Output, dont buffer
|
|
$| = 1;
|
|
|
|
# first fork and run in background
|
|
if ($pid = fork) {
|
|
# open LOG, ">$log" if $dolog;
|
|
# close LOG;
|
|
logmsg("notice", 2, "forked process: $pid\n");
|
|
exit 0;
|
|
}
|
|
|
|
# Server tells about startup success
|
|
open (PID, ">/$instdir/var/run/$selfbase.pid");
|
|
print PID "$$\n";
|
|
close PID;
|
|
|
|
# Cleanup on exit (due to kill -TERM signal)
|
|
$SIG{TERM} = \&out;
|
|
|
|
# We use streams
|
|
my $proto = getprotobyname('tcp');
|
|
|
|
# Open Server socket
|
|
socket(Server, PF_INET, SOCK_STREAM, $proto) or die "socket: $!";
|
|
setsockopt(Server, SOL_SOCKET, SO_REUSEADDR, pack("l", 1))
|
|
or die "setsocketopt: $!";
|
|
bind (Server, sockaddr_in($port, INADDR_ANY))
|
|
or die "bind: $!";
|
|
listen (Server, SOMAXCONN)
|
|
or die "listen: $!";
|
|
|
|
%authhosts = ();
|
|
# get authorized hosts
|
|
open (AUTH, $authfile)
|
|
or logmsg ("notice", 2, "Could not read allowed hosts file: $authfile");
|
|
while (<AUTH>) {
|
|
chomp;
|
|
my $host = lc $_;
|
|
if ($host =~ /^[\d\w]/) {
|
|
$authhosts{$_} = 1;
|
|
logmsg ("notice", 2, "Authorized host: >$host<");
|
|
}
|
|
}
|
|
close (AUTH);
|
|
|
|
# tell about open server socket
|
|
logmsg ("notice", 2, "Server started at port $port");
|
|
|
|
my $waitedpid = 0;
|
|
my $paddr;
|
|
|
|
# wait for children to return, thus avoiding zombies
|
|
# improvement (*)
|
|
use POSIX ":sys_wait_h";
|
|
sub REAPER {
|
|
my $child;
|
|
while (($waitedpid = waitpid(-1,WNOHANG)) > 0) {
|
|
logmsg ("notice", 2, "reaped $waitedpid", ($? ? " with exit $?" : ""));
|
|
}
|
|
$SIG{CHLD} = \&REAPER; # loathe sysV
|
|
}
|
|
|
|
# also all sub-processes should wait for their children
|
|
$SIG{CHLD} = \&REAPER;
|
|
|
|
# start a new server for every incoming request
|
|
# improvement (*) -- loop forever
|
|
|
|
while ( 1 ) {
|
|
for ( $waitedpid = 0;
|
|
($paddr = accept(Client,Server)) || $waitedpid;
|
|
$waitedpid = 0, close Client ) {
|
|
next if $waitedpid and not $paddr;
|
|
my ($port, $iaddr) = sockaddr_in($paddr);
|
|
my $name = lc gethostbyaddr($iaddr, AF_INET);
|
|
my $ipaddr = inet_ntoa($iaddr);
|
|
my $n = 0;
|
|
|
|
# tell about the requesting client
|
|
logmsg ("info", 2, "Connection from >$ipaddr< ($name) at port $port");
|
|
|
|
spawn sub {
|
|
my ($head, $hlen, $pos, $pegel, $typ, $siz, $nch, $nrec, $dat, $i, $j, $n, $llen);
|
|
my ($watchpegel, $shmpegel);
|
|
my ($rin, $rout, $in, $line, $data_requested, $oversample);
|
|
my (@channels);
|
|
|
|
# to use stdio on writing to Client
|
|
Client->autoflush();
|
|
|
|
# Open Device
|
|
sysopen (DEV, "$dev", O_RDWR | O_NONBLOCK, 0666) or die("can't open $dev");
|
|
|
|
# Bitmask to check for input on stdin
|
|
$rin = "";
|
|
vec($rin, fileno(Client), 1) = 1;
|
|
|
|
# check for authorized hosts
|
|
my $access = 'deny';
|
|
$access = 'allow' if $authhosts{$ipaddr};
|
|
$line = "<remote_host host=\"$ipaddr\" access=\"$access\">\n";
|
|
logmsg ("info", 2, $line);
|
|
$len = length $line;
|
|
$offset = 0;
|
|
while ($len) {
|
|
$written = syswrite (DEV, $line, $len, $offset);
|
|
$len -= $written;
|
|
$offset += $written;
|
|
}
|
|
|
|
while ( 1 ) {
|
|
$in = select ($rout=$rin, undef, undef, 0.0); # poll client
|
|
# look for any Input from Client
|
|
if ($in) {
|
|
# exit on EOF
|
|
$len = sysread (Client, $line, $blksize) or exit;
|
|
logmsg("info", 0, "got $len bytes: \"$line\"");
|
|
$offset = 0;
|
|
# copy request to device
|
|
while ($len) {
|
|
$written = syswrite (DEV, $line, $len, $offset);
|
|
$len -= $written;
|
|
$offset += $written;
|
|
}
|
|
}
|
|
# look for some output from device
|
|
if ($len = sysread DEV, $stream, $blksize) {
|
|
print Client $stream;
|
|
} else {
|
|
select undef, undef, undef, 0.1; # calm down if nothing on device
|
|
}
|
|
}
|
|
};
|
|
logmsg("info", 2, "spawned\n");
|
|
}
|
|
logmsg("info", 2, "server loop\n");
|
|
}
|
|
|
|
sub spawn {
|
|
my $coderef = shift;
|
|
|
|
unless (@_ == 0 && $coderef && ref($coderef) eq 'CODE') {
|
|
confess "usage: spawn CODEREF";
|
|
}
|
|
my $pid;
|
|
if (!defined($pid = fork)) {
|
|
logmsg ("notice", 2, "fork failed: $!");
|
|
return;
|
|
} elsif ($pid) {
|
|
logmsg ("notice", 2, "Request $pid");
|
|
return; # Parent
|
|
}
|
|
|
|
# do not use fdup as in the original example
|
|
# open (STDIN, "<&Client") or die "Can't dup client to stdin";
|
|
# open (STDOUT, ">&Client") or die "Can't dup client to stdout";
|
|
# STDOUT->autoflush();
|
|
exit &$coderef();
|
|
}
|