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; version 2 of the License.

    12

#

    13

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

    14

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

    15

#  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the

    16

#  GNU General Public License for more details.

    17

#

    18

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

    19

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

    20

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

    21

#

    22

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

    23

#

    24

#  Multithreaded Server

    25

#  according to the example from "Programming Perl"

    26

#  this code is improved according to the example from

    27

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

    28

#  (see note (*))

    29

#

    30

#  works with read/write on a device-file

    31

#

    32

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

    33

    34

require 5.002;

    35

use strict;

    36

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

    37

use Socket;

    38

use Carp;

    39

use FileHandle;

    40

use Getopt::Std;

    41

    42

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

    43

    44

use vars qw (

    45

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

    46

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

    47

	     $instdir

    48

	     $authfile %authhosts

    49

	     );

    50

    51

    52

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

    53

setlogsock("unix");

    54

    55

# Prototypes and some little Tools

    56

sub spawn;

    57

sub logmsg {

    58

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

    59

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

    60

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

    61

}

    62

sub out {

    63

  my $waitpid = wait;

    64

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

    65

  unlink "$selfbase.pid";

    66

  exit 0;

    67

}

    68

    69

sub help {

    70

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

    71

  exit;

    72

}

    73

    74

# Process Options

    75

%opts = (

    76

	 "l" => 1,

    77

	 "h" => 0,

    78

	 "p" => 2345,

    79

	 "d" => "/dev/msr"

    80

	 );

    81

    82

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

    83

    84

help if $opts{"h"};

    85

    86

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

    87

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

    88

$log = "$selfbase.log";

    89

$dolog = $opts{"l"};

    90

$port = $opts{"p"};

    91

$dev = $opts{"d"};

    92

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

    93

$instdir = "/opt/msr";

    94

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

    95

    96

# Start logging

    97

openlog($self, 'pid');

    98

    99

# Flush Output, dont buffer

   100

$| = 1;

   101

   102

# first fork and run in background

   103

if ($pid = fork) {

   104

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

   105

#  close LOG;

   106

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

   107

  exit 0;

   108

}

   109

   110

# Server tells about startup success

   111

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

   112

print PID "$$\n";

   113

close PID;

   114

   115

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

   116

$SIG{TERM} = \&out;

   117

   118

# We use streams

   119

my $proto = getprotobyname('tcp');

   120

   121

# Open Server socket

   122

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

   123

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

   124

  or die "setsocketopt: $!";

   125

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

   126

  or die "bind: $!";

   127

listen (Server, SOMAXCONN)

   128

  or die "listen: $!";

   129

   130

%authhosts = ();

   131

# get authorized hosts

   132

open (AUTH, $authfile)

   133

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

   134

while (<AUTH>) {

   135

    chomp;

   136

    my $host = lc $_;

   137

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

   138

	 $authhosts{$_} = 1;

   139

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

   140

     }

   141

}

   142

close (AUTH);

   143

   144

# tell about open server socket

   145

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

   146

   147

my $waitedpid = 0;

   148

my $paddr;

   149

   150

# wait for children to return, thus avoiding zombies

   151

# improvement (*)

   152

use POSIX ":sys_wait_h";

   153

sub REAPER {

   154

  my $child;

   155

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

   156

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

   157

  }

   158

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

   159

}

   160

   161

# also all sub-processes should wait for their children

   162

$SIG{CHLD} = \&REAPER;

   163

   164

# start a new server for every incoming request

   165

# improvement (*) -- loop forever

   166

   167

while ( 1 ) {

   168

  for ( $waitedpid = 0;

   169

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

   170

	$waitedpid = 0, close Client ) {

   171

    next if $waitedpid and not $paddr;

   172

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

   173

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

   174

    my $ipaddr = inet_ntoa($iaddr);

   175

    my $n = 0;

   176

   177

# tell about the requesting client

   178

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

   179

   180

    spawn sub {

   181

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

   182

      my ($watchpegel, $shmpegel);

   183

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

   184

      my (@channels);

   185

   186

#   to use stdio on writing to Client

   187

      Client->autoflush();

   188

   189

#   Open Device

   190

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

   191

   192

#   Bitmask to check for input on stdin

   193

      $rin = "";

   194

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

   195

   196

#   check for authorized hosts

   197

      my $access = 'deny';

   198

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

   199

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

   200

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

   201

      $len = length $line;

   202

      $offset = 0;

   203

      while ($len) {

   204

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

   205

	$len -= $written;

   206

	$offset += $written;

   207

      }

   208

   209

      while ( 1 ) {

   210

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

   211

#     look for any Input from Client

   212

	if ($in) {

   213

#       exit on EOF

   214

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

   215

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

   216

	  $offset = 0;

   217

#       copy request to device

   218

	  while ($len) {

   219

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

   220

	    $len -= $written;

   221

	    $offset += $written;

   222

	  }

   223

	}

   224

#     look for some output from device

   225

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

   226

	  print Client $stream;

   227

	} else {

   228

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

   229

	}

   230

      }

   231

    };

   232

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

   233

  }

   234

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

   235

}

   236

   237

sub spawn {

   238

  my $coderef = shift;

   239

   240

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

   241

    confess "usage: spawn CODEREF";

   242

  }

   243

  my $pid;

   244

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

   245

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

   246

    return;

   247

  } elsif ($pid) {

   248

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

   249

    return; # Parent

   250

  }

   251

   252

# do not use fdup as in the original example

   253

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

   254

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

   255

# STDOUT->autoflush();

   256

  exit &$coderef();

   257

}