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