fp@0: #!/usr/bin/perl -w
fp@0: 
fp@0: # Multithreaded Server 
fp@0: # according to the example from "Programming Perl"
fp@0: #
fp@0: # works with read/write on a device-file  
fp@0: #
fp@0: # $Revision: 1.1 $
fp@0: # $Date: 2002/07/09 10:10:59 $
fp@0: # $RCSfile: msrserv.pl,v $
fp@0: #
fp@0: 
fp@0: require 5.002;
fp@0: use strict;
fp@0: BEGIN { $ENV{PATH} = '/usr/bin:/bin' }
fp@0: use Socket;
fp@0: use Carp;
fp@0: use FileHandle;
fp@0: use Getopt::Std; 
fp@0: 
fp@0: use Sys::Syslog qw(:DEFAULT setlogsock); 
fp@0: 
fp@0: use vars qw (
fp@0: 	     $self $pid $dolog $port $dev %opts $selfbase
fp@0: 	     $len $offset $stream $written $read $log $blksize
fp@0: 	     $authfile %authhosts
fp@0: 	     );
fp@0: 
fp@0: 
fp@0: # Do logging to local syslogd by unix-domain socket instead of inetd
fp@0: setlogsock("unix");  
fp@0: 
fp@0: # Prototypes and some little Tools
fp@0: sub spawn;
fp@0: sub logmsg { 
fp@0:   my ($level, @text) = @_;
fp@0:   syslog("daemon|$level", @text) if $dolog;
fp@0: #  print STDERR "daemon|$level", @text, "\n" if $dolog;
fp@0: }
fp@0: sub out {
fp@0:   my $waitpid = wait; 
fp@0:   logmsg("notice", "$waitpid exited");
fp@0:   unlink "$selfbase.pid";
fp@0:   exit 0;
fp@0: }
fp@0: 
fp@0: sub help {
fp@0:   print "\n  usage: $0 [-l og] [-h elp] [-p port] [-d device]\n"; 
fp@0:   exit; 
fp@0: }
fp@0: 
fp@0: # Process Options
fp@0: %opts = (
fp@0: 	 "l" => 1,
fp@0: 	 "h" => 0,
fp@0: 	 "p" => 2345,
fp@0: 	 "d" => "/dev/msr"
fp@0: 	 );
fp@0:   
fp@0: getopts("lhp:d:", \%opts);
fp@0: 
fp@0: help if $opts{"h"};
fp@0: 
fp@0: ( $self =  $0 ) =~ s+.*/++ ;
fp@0: ( $selfbase = $self ) =~ s/\..*//;
fp@0: $log = "$selfbase.log";
fp@0: $dolog = $opts{"l"};
fp@0: $port = $opts{"p"};
fp@0: $dev = $opts{"d"};
fp@0: $blksize = 1024; # try to write as much bytes
fp@0: $authfile = "/opt/kbw/etc/hosts.auth"; 
fp@0: 
fp@0: # Start logging
fp@0: openlog($self, 'pid');
fp@0: 
fp@0: # Flush Output, dont buffer
fp@0: $| = 1;
fp@0: 
fp@0: # first fork and run in background
fp@0: if ($pid = fork) {
fp@0: #  open LOG, ">$log" if $dolog;
fp@0: #  close LOG;
fp@0:   logmsg("notice", "forked process: $pid\n");
fp@0:   exit 0;
fp@0: }
fp@0: 
fp@0: # Server tells about startup success
fp@0: open (PID, ">$selfbase.pid");
fp@0: print PID "$$\n";
fp@0: close PID;
fp@0: 
fp@0: # Cleanup on exit (due to kill -TERM signal)
fp@0: $SIG{TERM} = \&out;
fp@0: 
fp@0: # We use streams
fp@0: my $proto = getprotobyname('tcp');
fp@0: 
fp@0: # Open Server socket
fp@0: socket(Server, PF_INET, SOCK_STREAM, $proto) or die "socket: $!";
fp@0: setsockopt(Server, SOL_SOCKET, SO_REUSEADDR, pack("l", 1))
fp@0:   or die "setsocketopt: $!";
fp@0: bind (Server, sockaddr_in($port, INADDR_ANY))
fp@0:   or die "bind: $!";
fp@0: listen (Server, SOMAXCONN) 
fp@0:   or die "listen: $!";
fp@0: 
fp@0: %authhosts = ();
fp@0: # get authorized hosts
fp@0: open (AUTH, $authfile) 
fp@0:   or logmsg ("notice", "Could not read allowed hosts file: $authfile");
fp@0: while (<AUTH>) {
fp@0:     chomp;
fp@0:     my $host = lc $_;
fp@0:     logmsg ("notice", "Authorized host: $host");
fp@0:     $authhosts{$_} = 1 if $host =~ /^[\d\w]/;
fp@0: }
fp@0: close (AUTH);
fp@0: 
fp@0: # tell about open server socket
fp@0: logmsg ("notice", "Server started at port $port");
fp@0: 
fp@0: my $waitpid = 0;
fp@0: my $paddr;
fp@0: 
fp@0: # wait for children to return, thus avoiding zombies
fp@0: sub REAPER {
fp@0:   $waitpid = wait;
fp@0:   $SIG{CHLD} = \&REAPER; 
fp@0:   logmsg ("notice", "reaped $waitpid", ($? ? " with exit $?" : ""));
fp@0: }
fp@0: 
fp@0: # also all sub-processes should wait for their children
fp@0: $SIG{CHLD} = \&REAPER;
fp@0: 
fp@0: # start a new server for every incoming request
fp@0: for ( ; $paddr = accept(Client, Server); close (Client)) {
fp@0:   my ($port, $iaddr) = sockaddr_in($paddr);
fp@0:   my $name = lc gethostbyaddr($iaddr, AF_INET);
fp@0:   my $ipaddr = inet_ntoa($iaddr);
fp@0:   my $n = 0;
fp@0: 
fp@0: # tell about the requesting client
fp@0:   logmsg ("info", "Connection from $ipaddr ($name) at port $port");
fp@0: 
fp@0:   spawn sub {
fp@0:     my ($head, $hlen, $pos, $pegel, $typ, $siz, $nch, $nrec, $dat, $i, $j, $n, $llen); 
fp@0:     my ($watchpegel, $shmpegel);
fp@0:     my ($rin, $rout, $in, $line, $data_requested, $oversample);
fp@0:     my (@channels);
fp@0:     
fp@0: #   to use stdio on writing to Client
fp@0:     Client->autoflush();
fp@0: 
fp@0: #   Open Device 
fp@0:     sysopen (DEV, "$dev", O_RDWR | O_NONBLOCK, 0666) or die("can't open $dev");
fp@0: 
fp@0: #   Bitmask to check for input on stdin
fp@0:     $rin = "";
fp@0:     vec($rin, fileno(Client), 1) = 1; 
fp@0: 
fp@0: #   check for authorized hosts
fp@0:     my $access = 'allow';
fp@0:     $access = 'allow' if $authhosts{$ipaddr};
fp@0:     $line = "<remote_host host=\"$ipaddr\" access=\"$access\">\n";
fp@0:     $len = length $line;
fp@0:     $offset = 0;
fp@0:     while ($len) {
fp@0: 	$written = syswrite (DEV, $line, $len, $offset);
fp@0: 	$len -= $written;
fp@0: 	$offset += $written;
fp@0:     }
fp@0: 
fp@0:     while ( 1 ) {
fp@0:       $in = select ($rout=$rin, undef, undef, 0.0); # poll client
fp@0: #     look for any Input from Client
fp@0:       if ($in) {
fp@0: #       exit on EOF
fp@0: 	$len = sysread (Client, $line, $blksize) or exit;
fp@0: 	logmsg("info", "got $len bytes: \"$line\""); 
fp@0: 	$offset = 0;
fp@0: #       copy request to device
fp@0: 	while ($len) {
fp@0: 	  $written = syswrite (DEV, $line, $len, $offset);
fp@0: 	  $len -= $written;
fp@0: 	  $offset += $written;
fp@0: 	}
fp@0:       }
fp@0: #     look for some output from device
fp@0:       if ($len = sysread DEV, $stream, $blksize) {
fp@0: 	print Client $stream;
fp@0:       } else {
fp@0: 	select undef, undef, undef, 0.1; # calm down if nothing on device
fp@0:       }
fp@0:     }
fp@0:   }
fp@0: }
fp@0: 
fp@0: sub spawn {
fp@0:   my $coderef = shift;
fp@0: 
fp@0:   unless (@_ == 0 && $coderef && ref($coderef) eq 'CODE') {
fp@0:     confess "usage: spawn CODEREF";
fp@0:   }
fp@0:   my $pid; 
fp@0:   if (!defined($pid = fork)) {
fp@0:     logmsg ("notice", "fork failed: $!");
fp@0:     return;
fp@0:   } elsif ($pid) {
fp@0:     logmsg ("notice", "Request $pid");
fp@0:     return; # Parent
fp@0:   }
fp@0: 
fp@0: # do not use fdup as in the original example
fp@0: # open (STDIN, "<&Client") or die "Can't dup client to stdin";
fp@0: # open (STDOUT, ">&Client") or die "Can't dup client to stdout";
fp@0: # STDOUT->autoflush();
fp@0:   exit &$coderef();
fp@0: }
fp@0: 
fp@0: 
fp@0: 
fp@0: 
fp@0: 
fp@0: 
fp@0: 
fp@0: 
fp@0: 
fp@0: 
fp@0: 
fp@0: