diff -r ef1266652c4d -r 088a61306930 examples/msr/msrserv.pl --- a/examples/msr/msrserv.pl Wed Jul 02 11:26:51 2008 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,267 +0,0 @@ -#!/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 () { - 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 = "\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(); -}