1

#!/usr/bin/perl -w

     2

     3

#------------------------------------------------------------------------------

     4

#

     5

#  Copyright (C) 2006  Ingenieurgemeinschaft IgH

     6

#

     7

#  This file is part of the IgH EtherCAT Master.

     8

#

     9

#  The IgH EtherCAT Master is free software; you can redistribute it

    10

#  and/or modify it under the terms of the GNU General Public License

    11

#  as published by the Free Software Foundation; either version 2 of the

    12

#  License, or (at your option) any later version.

    13

#

    14

#  The IgH EtherCAT Master is distributed in the hope that it will be

    15

#  useful, but WITHOUT ANY WARRANTY; without even the implied warranty of

    16

#  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the

    17

#  GNU General Public License for more details.

    18

#

    19

#  You should have received a copy of the GNU General Public License

    20

#  along with the IgH EtherCAT Master; if not, write to the Free Software

    21

#  Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301  USA

    22

#

    23

#  The right to use EtherCAT Technology is granted and comes free of

    24

#  charge under condition of compatibility of product made by

    25

#  Licensee. People intending to distribute/sell products based on the

    26

#  code, have to sign an agreement to guarantee that products using

    27

#  software based on IgH EtherCAT master stay compatible with the actual

    28

#  EtherCAT specification (which are released themselves as an open

    29

#  standard) as the (only) precondition to have the right to use EtherCAT

    30

#  Technology, IP and trade marks.

    31

#

    32

#------------------------------------------------------------------------------

    33

#

    34

#  Multithreaded Server

    35

#  according to the example from "Programming Perl"

    36

#  this code is improved according to the example from

    37

#  perldoc perlipc, so now safely being usable under Perl 5.8

    38

#  (see note (*))

    39

#

    40

#  works with read/write on a device-file

    41

#

    42

#------------------------------------------------------------------------------

    43

    44

require 5.002;

    45

use strict;

    46

BEGIN { $ENV{PATH} = '/opt/msr/bin:/usr/bin:/bin' }

    47

use Socket;

    48

use Carp;

    49

use FileHandle;

    50

use Getopt::Std;

    51

    52

use Sys::Syslog qw(:DEFAULT setlogsock);

    53

    54

use vars qw (

    55

	     $self $pid $dolog $port $dev %opts $selfbase

    56

	     $len $offset $stream $written $read $log $blksize

    57

	     $instdir

    58

	     $authfile %authhosts

    59

	     );

    60

    61

    62

# Do logging to local syslogd by unix-domain socket instead of inetd

    63

setlogsock("unix");

    64

    65

# Prototypes and some little Tools

    66

sub spawn;

    67

sub logmsg {

    68

  my ($level, $debug, @text) = @_;

    69

  syslog("daemon|$level", @text) if $debug > $dolog;

    70

#  print STDERR "daemon|$level", @text, "\n" if $dolog;

    71

}

    72

sub out {

    73

  my $waitpid = wait;

    74

  logmsg("notice", 2, "$waitpid exited");

    75

  unlink "$selfbase.pid";

    76

  exit 0;

    77

}

    78

    79

sub help {

    80

  print "\n  usage: $0 [-l og] [-h elp] [-p port] [-d device]\n";

    81

  exit;

    82

}

    83

    84

# Process Options

    85

%opts = (

    86

	 "l" => 1,

    87

	 "h" => 0,

    88

	 "p" => 2345,

    89

	 "d" => "/dev/msr"

    90

	 );

    91

    92

getopts("lhp:d:", \%opts);

    93

    94

help if $opts{"h"};

    95

    96

( $self =  $0 ) =~ s+.*/++ ;

    97

( $selfbase = $self ) =~ s/\..*//;

    98

$log = "$selfbase.log";

    99

$dolog = $opts{"l"};

   100

$port = $opts{"p"};

   101

$dev = $opts{"d"};

   102

$blksize = 1024; # try to write as much bytes

   103

$instdir = "/opt/msr";

   104

$authfile = "$instdir/etc/hosts.auth";

   105

   106

# Start logging

   107

openlog($self, 'pid');

   108

   109

# Flush Output, dont buffer

   110

$| = 1;

   111

   112

# first fork and run in background

   113

if ($pid = fork) {

   114

#  open LOG, ">$log" if $dolog;

   115

#  close LOG;

   116

  logmsg("notice", 2, "forked process: $pid\n");

   117

  exit 0;

   118

}

   119

   120

# Server tells about startup success

   121

open (PID, ">/$instdir/var/run/$selfbase.pid");

   122

print PID "$$\n";

   123

close PID;

   124

   125

# Cleanup on exit (due to kill -TERM signal)

   126

$SIG{TERM} = \&out;

   127

   128

# We use streams

   129

my $proto = getprotobyname('tcp');

   130

   131

# Open Server socket

   132

socket(Server, PF_INET, SOCK_STREAM, $proto) or die "socket: $!";

   133

setsockopt(Server, SOL_SOCKET, SO_REUSEADDR, pack("l", 1))

   134

  or die "setsocketopt: $!";

   135

bind (Server, sockaddr_in($port, INADDR_ANY))

   136

  or die "bind: $!";

   137

listen (Server, SOMAXCONN)

   138

  or die "listen: $!";

   139

   140

%authhosts = ();

   141

# get authorized hosts

   142

open (AUTH, $authfile)

   143

  or logmsg ("notice", 2, "Could not read allowed hosts file: $authfile");

   144

while (<AUTH>) {

   145

    chomp;

   146

    my $host = lc $_;

   147

     if ($host =~ /^[\d\w]/) {

   148

	 $authhosts{$_} = 1;

   149

	 logmsg ("notice", 2, "Authorized host: >$host<");

   150

     }

   151

}

   152

close (AUTH);

   153

   154

# tell about open server socket

   155

logmsg ("notice", 2, "Server started at port $port");

   156

   157

my $waitedpid = 0;

   158

my $paddr;

   159

   160

# wait for children to return, thus avoiding zombies

   161

# improvement (*)

   162

use POSIX ":sys_wait_h";

   163

sub REAPER {

   164

  my $child;

   165

  while (($waitedpid = waitpid(-1,WNOHANG)) > 0) {

   166

    logmsg ("notice", 2, "reaped $waitedpid", ($? ? " with exit $?" : ""));

   167

  }

   168

  $SIG{CHLD} = \&REAPER;  # loathe sysV

   169

}

   170

   171

# also all sub-processes should wait for their children

   172

$SIG{CHLD} = \&REAPER;

   173

   174

# start a new server for every incoming request

   175

# improvement (*) -- loop forever

   176

   177

while ( 1 ) {

   178

  for ( $waitedpid = 0;

   179

	($paddr = accept(Client,Server)) || $waitedpid;

   180

	$waitedpid = 0, close Client ) {

   181

    next if $waitedpid and not $paddr;

   182

    my ($port, $iaddr) = sockaddr_in($paddr);

   183

    my $name = lc gethostbyaddr($iaddr, AF_INET);

   184

    my $ipaddr = inet_ntoa($iaddr);

   185

    my $n = 0;

   186

   187

# tell about the requesting client

   188

    logmsg ("info", 2, "Connection from >$ipaddr< ($name) at port $port");

   189

   190

    spawn sub {

   191

      my ($head, $hlen, $pos, $pegel, $typ, $siz, $nch, $nrec, $dat, $i, $j, $n, $llen); 

   192

      my ($watchpegel, $shmpegel);

   193

      my ($rin, $rout, $in, $line, $data_requested, $oversample);

   194

      my (@channels);

   195

   196

#   to use stdio on writing to Client

   197

      Client->autoflush();

   198

   199

#   Open Device

   200

      sysopen (DEV, "$dev", O_RDWR | O_NONBLOCK, 0666) or die("can't open $dev");

   201

   202

#   Bitmask to check for input on stdin

   203

      $rin = "";

   204

      vec($rin, fileno(Client), 1) = 1;

   205

   206

#   check for authorized hosts

   207

      my $access = 'deny';

   208

      $access = 'allow' if $authhosts{$ipaddr};

   209

      $line = "<remote_host host=\"$ipaddr\" access=\"$access\">\n";

   210

      logmsg ("info", 2, $line);

   211

      $len = length $line;

   212

      $offset = 0;

   213

      while ($len) {

   214

	$written = syswrite (DEV, $line, $len, $offset);

   215

	$len -= $written;

   216

	$offset += $written;

   217

      }

   218

   219

      while ( 1 ) {

   220

	$in = select ($rout=$rin, undef, undef, 0.0); # poll client

   221

#     look for any Input from Client

   222

	if ($in) {

   223

#       exit on EOF

   224

	  $len = sysread (Client, $line, $blksize) or exit;

   225

	  logmsg("info", 0, "got $len bytes: \"$line\"");

   226

	  $offset = 0;

   227

#       copy request to device

   228

	  while ($len) {

   229

	    $written = syswrite (DEV, $line, $len, $offset);

   230

	    $len -= $written;

   231

	    $offset += $written;

   232

	  }

   233

	}

   234

#     look for some output from device

   235

	if ($len = sysread DEV, $stream, $blksize) {

   236

	  print Client $stream;

   237

	} else {

   238

	  select undef, undef, undef, 0.1; # calm down if nothing on device

   239

	}

   240

      }

   241

    };

   242

    logmsg("info", 2, "spawned\n");

   243

  }

   244

  logmsg("info", 2, "server loop\n");

   245

}

   246

   247

sub spawn {

   248

  my $coderef = shift;

   249

   250

  unless (@_ == 0 && $coderef && ref($coderef) eq 'CODE') {

   251

    confess "usage: spawn CODEREF";

   252

  }

   253

  my $pid;

   254

  if (!defined($pid = fork)) {

   255

    logmsg ("notice", 2, "fork failed: $!");

   256

    return;

   257

  } elsif ($pid) {

   258

    logmsg ("notice", 2, "Request $pid");

   259

    return; # Parent

   260

  }

   261

   262

# do not use fdup as in the original example

   263

# open (STDIN, "<&Client") or die "Can't dup client to stdin";

   264

# open (STDOUT, ">&Client") or die "Can't dup client to stdout";

   265

# STDOUT->autoflush();

   266

  exit &$coderef();

   267

}