1 #!/usr/bin/perl -w

     2 

     3 #------------------------------------------------------------------------------

     4 #

     5 #  Copyright (C) 2006  Ingenieurgemeinschaft IgH

     6 #

     7 #  This file is part of the IgH EtherCAT Master.

     8 #

     9 #  The IgH EtherCAT Master is free software; you can redistribute it

    10 #  and/or modify it under the terms of the GNU General Public License

    11 #  as published by the Free Software Foundation; either version 2 of the

    12 #  License, or (at your option) any later version.

    13 #

    14 #  The IgH EtherCAT Master is distributed in the hope that it will be

    15 #  useful, but WITHOUT ANY WARRANTY; without even the implied warranty of

    16 #  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the

    17 #  GNU General Public License for more details.

    18 #

    19 #  You should have received a copy of the GNU General Public License

    20 #  along with the IgH EtherCAT Master; if not, write to the Free Software

    21 #  Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301  USA

    22 #

    23 #  The right to use EtherCAT Technology is granted and comes free of

    24 #  charge under condition of compatibility of product made by

    25 #  Licensee. People intending to distribute/sell products based on the

    26 #  code, have to sign an agreement to guarantee that products using

    27 #  software based on IgH EtherCAT master stay compatible with the actual

    28 #  EtherCAT specification (which are released themselves as an open

    29 #  standard) as the (only) precondition to have the right to use EtherCAT

    30 #  Technology, IP and trade marks.

    31 #

    32 #------------------------------------------------------------------------------

    33 #

    34 #  Multithreaded Server

    35 #  according to the example from "Programming Perl"

    36 #  this code is improved according to the example from

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

    38 #  (see note (*))

    39 #

    40 #  works with read/write on a device-file

    41 #

    42 #------------------------------------------------------------------------------

    43 

    44 require 5.002;

    45 use strict;

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

    47 use Socket;

    48 use Carp;

    49 use FileHandle;

    50 use Getopt::Std;

    51 

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

    53 

    54 use vars qw (

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

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

    57 	     $instdir

    58 	     $authfile %authhosts

    59 	     );

    60 

    61 

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

    63 setlogsock("unix");

    64 

    65 # Prototypes and some little Tools

    66 sub spawn;

    67 sub logmsg {

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

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

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

    71 }

    72 sub out {

    73   my $waitpid = wait;

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

    75   unlink "$selfbase.pid";

    76   exit 0;

    77 }

    78 

    79 sub help {

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

    81   exit;

    82 }

    83 

    84 # Process Options

    85 %opts = (

    86 	 "l" => 1,

    87 	 "h" => 0,

    88 	 "p" => 2345,

    89 	 "d" => "/dev/msr"

    90 	 );

    91 

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

    93 

    94 help if $opts{"h"};

    95 

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

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

    98 $log = "$selfbase.log";

    99 $dolog = $opts{"l"};

   100 $port = $opts{"p"};

   101 $dev = $opts{"d"};

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

   103 $instdir = "/opt/msr";

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

   105 

   106 # Start logging

   107 openlog($self, 'pid');

   108 

   109 # Flush Output, dont buffer

   110 $| = 1;

   111 

   112 # first fork and run in background

   113 if ($pid = fork) {

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

   115 #  close LOG;

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

   117   exit 0;

   118 }

   119 

   120 # Server tells about startup success

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

   122 print PID "$$\n";

   123 close PID;

   124 

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

   126 $SIG{TERM} = \&out;

   127 

   128 # We use streams

   129 my $proto = getprotobyname('tcp');

   130 

   131 # Open Server socket

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

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

   134   or die "setsocketopt: $!";

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

   136   or die "bind: $!";

   137 listen (Server, SOMAXCONN)

   138   or die "listen: $!";

   139 

   140 %authhosts = ();

   141 # get authorized hosts

   142 open (AUTH, $authfile)

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

   144 while (<AUTH>) {

   145     chomp;

   146     my $host = lc $_;

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

   148 	 $authhosts{$_} = 1;

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

   150      }

   151 }

   152 close (AUTH);

   153 

   154 # tell about open server socket

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

   156 

   157 my $waitedpid = 0;

   158 my $paddr;

   159 

   160 # wait for children to return, thus avoiding zombies

   161 # improvement (*)

   162 use POSIX ":sys_wait_h";

   163 sub REAPER {

   164   my $child;

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

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

   167   }

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

   169 }

   170 

   171 # also all sub-processes should wait for their children

   172 $SIG{CHLD} = \&REAPER;

   173 

   174 # start a new server for every incoming request

   175 # improvement (*) -- loop forever

   176 

   177 while ( 1 ) {

   178   for ( $waitedpid = 0;

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

   180 	$waitedpid = 0, close Client ) {

   181     next if $waitedpid and not $paddr;

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

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

   184     my $ipaddr = inet_ntoa($iaddr);

   185     my $n = 0;

   186 

   187 # tell about the requesting client

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

   189 

   190     spawn sub {

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

   192       my ($watchpegel, $shmpegel);

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

   194       my (@channels);

   195 

   196 #   to use stdio on writing to Client

   197       Client->autoflush();

   198 

   199 #   Open Device

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

   201 

   202 #   Bitmask to check for input on stdin

   203       $rin = "";

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

   205 

   206 #   check for authorized hosts

   207       my $access = 'deny';

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

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

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

   211       $len = length $line;

   212       $offset = 0;

   213       while ($len) {

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

   215 	$len -= $written;

   216 	$offset += $written;

   217       }

   218 

   219       while ( 1 ) {

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

   221 #     look for any Input from Client

   222 	if ($in) {

   223 #       exit on EOF

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

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

   226 	  $offset = 0;

   227 #       copy request to device

   228 	  while ($len) {

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

   230 	    $len -= $written;

   231 	    $offset += $written;

   232 	  }

   233 	}

   234 #     look for some output from device

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

   236 	  print Client $stream;

   237 	} else {

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

   239 	}

   240       }

   241     };

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

   243   }

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

   245 }

   246 

   247 sub spawn {

   248   my $coderef = shift;

   249 

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

   251     confess "usage: spawn CODEREF";

   252   }

   253   my $pid;

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

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

   256     return;

   257   } elsif ($pid) {

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

   259     return; # Parent

   260   }

   261 

   262 # do not use fdup as in the original example

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

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

   265 # STDOUT->autoflush();

   266   exit &$coderef();

   267 }