1

#!/usr/bin/perl -w

     2

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

     3

#

     4

# (C) Copyright

     5

#     Diese Software ist geistiges Eigentum der 

     6

#     Ingenieurgemeinschaft IgH. Sie darf von 

     7

#     Toyota Motorsport GmbH

     8

#     beliebig kopiert und veraendert werden. 

     9

#     Die Weitergabe an Dritte ist untersagt.

    10

#     Dieser Urhebrrechtshinweis muss erhalten

    11

#     bleiben.

    12

#

    13

#     Ingenieurgemeinschaft IgH

    14

#     Heinz-Baecker-Strasse 34

    15

#     D-45356 Essen

    16

#     Tel.:  +49-201/61 99 31

    17

#     Fax.:  +49-201/61 98 36

    18

#     WWW:   http://www.igh-essen.com

    19

#     Email: msr@igh-essen.com

    20

#

    21

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

    22

#

    23

# Multithreaded Server 

    24

# according to the example from "Programming Perl"

    25

# this code is improved according to the example from 

    26

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

    27

# (see note (*))

    28

#

    29

# works with read/write on a device-file  

    30

#

    31

# $Revision: 1.1 $

    32

# $Date: 2004/10/01 16:00:42 $

    33

# $RCSfile: msrserv.pl,v $

    34

#

    35

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

    36

    37

require 5.002;

    38

use strict;

    39

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

    40

use Socket;

    41

use Carp;

    42

use FileHandle;

    43

use Getopt::Std; 

    44

    45

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

    46

    47

use vars qw (

    48

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

    49

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

    50

	     $instdir

    51

	     $authfile %authhosts

    52

	     );

    53

    54

    55

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

    56

setlogsock("unix");  

    57

    58

# Prototypes and some little Tools

    59

sub spawn;

    60

sub logmsg { 

    61

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

    62

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

    63

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

    64

}

    65

sub out {

    66

  my $waitpid = wait; 

    67

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

    68

  unlink "$selfbase.pid";

    69

  exit 0;

    70

}

    71

    72

sub help {

    73

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

    74

  exit; 

    75

}

    76

    77

# Process Options

    78

%opts = (

    79

	 "l" => 1,

    80

	 "h" => 0,

    81

	 "p" => 2345,

    82

	 "d" => "/dev/msr"

    83

	 );

    84

    85

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

    86

    87

help if $opts{"h"};

    88

    89

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

    90

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

    91

$log = "$selfbase.log";

    92

$dolog = $opts{"l"};

    93

$port = $opts{"p"};

    94

$dev = $opts{"d"};

    95

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

    96

$instdir = "/opt/msr";

    97

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

    98

    99

# Start logging

   100

openlog($self, 'pid');

   101

   102

# Flush Output, dont buffer

   103

$| = 1;

   104

   105

# first fork and run in background

   106

if ($pid = fork) {

   107

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

   108

#  close LOG;

   109

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

   110

  exit 0;

   111

}

   112

   113

# Server tells about startup success

   114

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

   115

print PID "$$\n";

   116

close PID;

   117

   118

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

   119

$SIG{TERM} = \&out;

   120

   121

# We use streams

   122

my $proto = getprotobyname('tcp');

   123

   124

# Open Server socket

   125

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

   126

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

   127

  or die "setsocketopt: $!";

   128

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

   129

  or die "bind: $!";

   130

listen (Server, SOMAXCONN) 

   131

  or die "listen: $!";

   132

   133

%authhosts = ();

   134

# get authorized hosts

   135

open (AUTH, $authfile) 

   136

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

   137

while (<AUTH>) {

   138

    chomp;

   139

    my $host = lc $_;

   140

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

   141

	 $authhosts{$_} = 1;

   142

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

   143

     }

   144

}

   145

close (AUTH);

   146

   147

# tell about open server socket

   148

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

   149

   150

my $waitedpid = 0;

   151

my $paddr;

   152

   153

# wait for children to return, thus avoiding zombies

   154

# improvement (*)

   155

use POSIX ":sys_wait_h";

   156

sub REAPER {

   157

  my $child;

   158

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

   159

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

   160

  }

   161

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

   162

}

   163

   164

# also all sub-processes should wait for their children

   165

$SIG{CHLD} = \&REAPER;

   166

   167

# start a new server for every incoming request

   168

# improvement (*) -- loop forever

   169

   170

while ( 1 ) {

   171

  for ( $waitedpid = 0;

   172

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

   173

	$waitedpid = 0, close Client ) {

   174

    next if $waitedpid and not $paddr;

   175

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

   176

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

   177

    my $ipaddr = inet_ntoa($iaddr);

   178

    my $n = 0;

   179

   180

# tell about the requesting client

   181

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

   182

   183

    spawn sub {

   184

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

   185

      my ($watchpegel, $shmpegel);

   186

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

   187

      my (@channels);

   188

   189

#   to use stdio on writing to Client

   190

      Client->autoflush();

   191

   192

#   Open Device 

   193

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

   194

   195

#   Bitmask to check for input on stdin

   196

      $rin = "";

   197

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

   198

   199

#   check for authorized hosts

   200

      my $access = 'deny';

   201

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

   202

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

   203

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

   204

      $len = length $line;

   205

      $offset = 0;

   206

      while ($len) {

   207

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

   208

	$len -= $written;

   209

	$offset += $written;

   210

      }

   211

   212

      while ( 1 ) {

   213

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

   214

#     look for any Input from Client

   215

	if ($in) {

   216

#       exit on EOF

   217

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

   218

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

   219

	  $offset = 0;

   220

#       copy request to device

   221

	  while ($len) {

   222

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

   223

	    $len -= $written;

   224

	    $offset += $written;

   225

	  }

   226

	}

   227

#     look for some output from device

   228

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

   229

	  print Client $stream;

   230

	} else {

   231

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

   232

	}

   233

      }

   234

    };

   235

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

   236

  }

   237

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

   238

}

   239

   240

sub spawn {

   241

  my $coderef = shift;

   242

   243

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

   244

    confess "usage: spawn CODEREF";

   245

  }

   246

  my $pid; 

   247

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

   248

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

   249

    return;

   250

  } elsif ($pid) {

   251

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

   252

    return; # Parent

   253

  }

   254

   255

# do not use fdup as in the original example

   256

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

   257

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

   258

# STDOUT->autoflush();

   259

  exit &$coderef();

   260

}

   261

   262

   263

   264

   265

   266

   267

   268

   269

   270

   271

   272