1

#!/usr/bin/perl -w

     2

     3

# Multithreaded Server 

     4

# according to the example from "Programming Perl"

     5

#

     6

# works with read/write on a device-file  

     7

#

     8

# $Revision: 1.1 $

     9

# $Date: 2002/07/09 10:10:59 $

    10

# $RCSfile: msrserv.pl,v $

    11

#

    12

    13

require 5.002;

    14

use strict;

    15

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

    16

use Socket;

    17

use Carp;

    18

use FileHandle;

    19

use Getopt::Std; 

    20

    21

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

    22

    23

use vars qw (

    24

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

    25

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

    26

	     $authfile %authhosts

    27

	     );

    28

    29

    30

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

    31

setlogsock("unix");  

    32

    33

# Prototypes and some little Tools

    34

sub spawn;

    35

sub logmsg { 

    36

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

    37

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

    38

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

    39

}

    40

sub out {

    41

  my $waitpid = wait; 

    42

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

    43

  unlink "$selfbase.pid";

    44

  exit 0;

    45

}

    46

    47

sub help {

    48

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

    49

  exit; 

    50

}

    51

    52

# Process Options

    53

%opts = (

    54

	 "l" => 1,

    55

	 "h" => 0,

    56

	 "p" => 2345,

    57

	 "d" => "/dev/msr"

    58

	 );

    59

    60

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

    61

    62

help if $opts{"h"};

    63

    64

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

    65

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

    66

$log = "$selfbase.log";

    67

$dolog = $opts{"l"};

    68

$port = $opts{"p"};

    69

$dev = $opts{"d"};

    70

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

    71

$authfile = "/opt/kbw/etc/hosts.auth"; 

    72

    73

# Start logging

    74

openlog($self, 'pid');

    75

    76

# Flush Output, dont buffer

    77

$| = 1;

    78

    79

# first fork and run in background

    80

if ($pid = fork) {

    81

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

    82

#  close LOG;

    83

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

    84

  exit 0;

    85

}

    86

    87

# Server tells about startup success

    88

open (PID, ">$selfbase.pid");

    89

print PID "$$\n";

    90

close PID;

    91

    92

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

    93

$SIG{TERM} = \&out;

    94

    95

# We use streams

    96

my $proto = getprotobyname('tcp');

    97

    98

# Open Server socket

    99

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

   100

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

   101

  or die "setsocketopt: $!";

   102

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

   103

  or die "bind: $!";

   104

listen (Server, SOMAXCONN) 

   105

  or die "listen: $!";

   106

   107

%authhosts = ();

   108

# get authorized hosts

   109

open (AUTH, $authfile) 

   110

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

   111

while (<AUTH>) {

   112

    chomp;

   113

    my $host = lc $_;

   114

    logmsg ("notice", "Authorized host: $host");

   115

    $authhosts{$_} = 1 if $host =~ /^[\d\w]/;

   116

}

   117

close (AUTH);

   118

   119

# tell about open server socket

   120

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

   121

   122

my $waitpid = 0;

   123

my $paddr;

   124

   125

# wait for children to return, thus avoiding zombies

   126

sub REAPER {

   127

  $waitpid = wait;

   128

  $SIG{CHLD} = \&REAPER; 

   129

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

   130

}

   131

   132

# also all sub-processes should wait for their children

   133

$SIG{CHLD} = \&REAPER;

   134

   135

# start a new server for every incoming request

   136

for ( ; $paddr = accept(Client, Server); close (Client)) {

   137

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

   138

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

   139

  my $ipaddr = inet_ntoa($iaddr);

   140

  my $n = 0;

   141

   142

# tell about the requesting client

   143

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

   144

   145

  spawn sub {

   146

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

   147

    my ($watchpegel, $shmpegel);

   148

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

   149

    my (@channels);

   150

   151

#   to use stdio on writing to Client

   152

    Client->autoflush();

   153

   154

#   Open Device 

   155

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

   156

   157

#   Bitmask to check for input on stdin

   158

    $rin = "";

   159

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

   160

   161

#   check for authorized hosts

   162

    my $access = 'allow';

   163

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

   164

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

   165

    $len = length $line;

   166

    $offset = 0;

   167

    while ($len) {

   168

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

   169

	$len -= $written;

   170

	$offset += $written;

   171

    }

   172

   173

    while ( 1 ) {

   174

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

   175

#     look for any Input from Client

   176

      if ($in) {

   177

#       exit on EOF

   178

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

   179

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

   180

	$offset = 0;

   181

#       copy request to device

   182

	while ($len) {

   183

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

   184

	  $len -= $written;

   185

	  $offset += $written;

   186

	}

   187

      }

   188

#     look for some output from device

   189

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

   190

	print Client $stream;

   191

      } else {

   192

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

   193

      }

   194

    }

   195

  }

   196

}

   197

   198

sub spawn {

   199

  my $coderef = shift;

   200

   201

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

   202

    confess "usage: spawn CODEREF";

   203

  }

   204

  my $pid; 

   205

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

   206

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

   207

    return;

   208

  } elsif ($pid) {

   209

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

   210

    return; # Parent

   211

  }

   212

   213

# do not use fdup as in the original example

   214

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

   215

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

   216

# STDOUT->autoflush();

   217

  exit &$coderef();

   218

}

   219

   220

   221

   222

   223

   224

   225

   226

   227

   228

   229

   230