CoE state machines raising error, if the slave does not support CoE.
#!/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();
}