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