1

#!/usr/bin/perl -w

     2

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

     3

#

     4

# (C) Copyright

     5

#     Ingenieurgemeinschaft IgH

     6

#     Heinz-Baecker-Strasse 34

     7

#     D-45356 Essen

     8

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

     9

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

    10

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

    11

#     Email: msr@igh-essen.com

    12

#

    13

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

    14

#

    15

# Multithreaded Server

    16

# according to the example from "Programming Perl"

    17

# this code is improved according to the example from

    18

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

    19

# (see note (*))

    20

#

    21

# works with read/write on a device-file

    22

#

    23

# $Revision: 1.1 $

    24

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

    25

# $RCSfile: msrserv.pl,v $

    26

#

    27

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

    28

    29

require 5.002;

    30

use strict;

    31

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

    32

use Socket;

    33

use Carp;

    34

use FileHandle;

    35

use Getopt::Std;

    36

    37

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

    38

    39

use vars qw (

    40

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

    41

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

    42

	     $instdir

    43

	     $authfile %authhosts

    44

	     );

    45

    46

    47

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

    48

setlogsock("unix");

    49

    50

# Prototypes and some little Tools

    51

sub spawn;

    52

sub logmsg {

    53

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

    54

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

    55

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

    56

}

    57

sub out {

    58

  my $waitpid = wait;

    59

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

    60

  unlink "$selfbase.pid";

    61

  exit 0;

    62

}

    63

    64

sub help {

    65

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

    66

  exit;

    67

}

    68

    69

# Process Options

    70

%opts = (

    71

	 "l" => 1,

    72

	 "h" => 0,

    73

	 "p" => 2345,

    74

	 "d" => "/dev/msr"

    75

	 );

    76

    77

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

    78

    79

help if $opts{"h"};

    80

    81

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

    82

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

    83

$log = "$selfbase.log";

    84

$dolog = $opts{"l"};

    85

$port = $opts{"p"};

    86

$dev = $opts{"d"};

    87

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

    88

$instdir = "/opt/msr";

    89

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

    90

    91

# Start logging

    92

openlog($self, 'pid');

    93

    94

# Flush Output, dont buffer

    95

$| = 1;

    96

    97

# first fork and run in background

    98

if ($pid = fork) {

    99

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

   100

#  close LOG;

   101

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

   102

  exit 0;

   103

}

   104

   105

# Server tells about startup success

   106

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

   107

print PID "$$\n";

   108

close PID;

   109

   110

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

   111

$SIG{TERM} = \&out;

   112

   113

# We use streams

   114

my $proto = getprotobyname('tcp');

   115

   116

# Open Server socket

   117

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

   118

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

   119

  or die "setsocketopt: $!";

   120

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

   121

  or die "bind: $!";

   122

listen (Server, SOMAXCONN)

   123

  or die "listen: $!";

   124

   125

%authhosts = ();

   126

# get authorized hosts

   127

open (AUTH, $authfile)

   128

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

   129

while (<AUTH>) {

   130

    chomp;

   131

    my $host = lc $_;

   132

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

   133

	 $authhosts{$_} = 1;

   134

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

   135

     }

   136

}

   137

close (AUTH);

   138

   139

# tell about open server socket

   140

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

   141

   142

my $waitedpid = 0;

   143

my $paddr;

   144

   145

# wait for children to return, thus avoiding zombies

   146

# improvement (*)

   147

use POSIX ":sys_wait_h";

   148

sub REAPER {

   149

  my $child;

   150

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

   151

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

   152

  }

   153

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

   154

}

   155

   156

# also all sub-processes should wait for their children

   157

$SIG{CHLD} = \&REAPER;

   158

   159

# start a new server for every incoming request

   160

# improvement (*) -- loop forever

   161

   162

while ( 1 ) {

   163

  for ( $waitedpid = 0;

   164

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

   165

	$waitedpid = 0, close Client ) {

   166

    next if $waitedpid and not $paddr;

   167

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

   168

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

   169

    my $ipaddr = inet_ntoa($iaddr);

   170

    my $n = 0;

   171

   172

# tell about the requesting client

   173

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

   174

   175

    spawn sub {

   176

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

   177

      my ($watchpegel, $shmpegel);

   178

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

   179

      my (@channels);

   180

   181

#   to use stdio on writing to Client

   182

      Client->autoflush();

   183

   184

#   Open Device

   185

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

   186

   187

#   Bitmask to check for input on stdin

   188

      $rin = "";

   189

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

   190

   191

#   check for authorized hosts

   192

      my $access = 'deny';

   193

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

   194

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

   195

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

   196

      $len = length $line;

   197

      $offset = 0;

   198

      while ($len) {

   199

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

   200

	$len -= $written;

   201

	$offset += $written;

   202

      }

   203

   204

      while ( 1 ) {

   205

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

   206

#     look for any Input from Client

   207

	if ($in) {

   208

#       exit on EOF

   209

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

   210

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

   211

	  $offset = 0;

   212

#       copy request to device

   213

	  while ($len) {

   214

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

   215

	    $len -= $written;

   216

	    $offset += $written;

   217

	  }

   218

	}

   219

#     look for some output from device

   220

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

   221

	  print Client $stream;

   222

	} else {

   223

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

   224

	}

   225

      }

   226

    };

   227

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

   228

  }

   229

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

   230

}

   231

   232

sub spawn {

   233

  my $coderef = shift;

   234

   235

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

   236

    confess "usage: spawn CODEREF";

   237

  }

   238

  my $pid;

   239

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

   240

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

   241

    return;

   242

  } elsif ($pid) {

   243

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

   244

    return; # Parent

   245

  }

   246

   247

# do not use fdup as in the original example

   248

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

   249

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

   250

# STDOUT->autoflush();

   251

  exit &$coderef();

   252

}