1 #!/usr/bin/perl -w |
1 #!/usr/bin/perl -w |
2 |
2 #------------------------------------------------------------ |
|
3 # |
|
4 # (C) Copyright |
|
5 # Diese Software ist geistiges Eigentum der |
|
6 # Ingenieurgemeinschaft IgH. Sie darf von |
|
7 # Toyota Motorsport GmbH |
|
8 # beliebig kopiert und veraendert werden. |
|
9 # Die Weitergabe an Dritte ist untersagt. |
|
10 # Dieser Urhebrrechtshinweis muss erhalten |
|
11 # bleiben. |
|
12 # |
|
13 # Ingenieurgemeinschaft IgH |
|
14 # Heinz-Baecker-Strasse 34 |
|
15 # D-45356 Essen |
|
16 # Tel.: +49-201/61 99 31 |
|
17 # Fax.: +49-201/61 98 36 |
|
18 # WWW: http://www.igh-essen.com |
|
19 # Email: msr@igh-essen.com |
|
20 # |
|
21 #------------------------------------------------------------ |
|
22 # |
3 # Multithreaded Server |
23 # Multithreaded Server |
4 # according to the example from "Programming Perl" |
24 # according to the example from "Programming Perl" |
|
25 # this code is improved according to the example from |
|
26 # perldoc perlipc, so now safely being usable under Perl 5.8 |
|
27 # (see note (*)) |
5 # |
28 # |
6 # works with read/write on a device-file |
29 # works with read/write on a device-file |
7 # |
30 # |
8 # $Revision: 1.1 $ |
31 # $Revision: 1.1 $ |
9 # $Date: 2002/07/09 10:10:59 $ |
32 # $Date: 2004/10/01 16:00:42 $ |
10 # $RCSfile: msrserv.pl,v $ |
33 # $RCSfile: msrserv.pl,v $ |
11 # |
34 # |
|
35 #------------------------------------------------------------ |
12 |
36 |
13 require 5.002; |
37 require 5.002; |
14 use strict; |
38 use strict; |
15 BEGIN { $ENV{PATH} = '/usr/bin:/bin' } |
39 BEGIN { $ENV{PATH} = '/opt/msr/bin:/usr/bin:/bin' } |
16 use Socket; |
40 use Socket; |
17 use Carp; |
41 use Carp; |
18 use FileHandle; |
42 use FileHandle; |
19 use Getopt::Std; |
43 use Getopt::Std; |
20 |
44 |
21 use Sys::Syslog qw(:DEFAULT setlogsock); |
45 use Sys::Syslog qw(:DEFAULT setlogsock); |
22 |
46 |
23 use vars qw ( |
47 use vars qw ( |
24 $self $pid $dolog $port $dev %opts $selfbase |
48 $self $pid $dolog $port $dev %opts $selfbase |
25 $len $offset $stream $written $read $log $blksize |
49 $len $offset $stream $written $read $log $blksize |
|
50 $instdir |
26 $authfile %authhosts |
51 $authfile %authhosts |
27 ); |
52 ); |
28 |
53 |
29 |
54 |
30 # Do logging to local syslogd by unix-domain socket instead of inetd |
55 # Do logging to local syslogd by unix-domain socket instead of inetd |
31 setlogsock("unix"); |
56 setlogsock("unix"); |
32 |
57 |
33 # Prototypes and some little Tools |
58 # Prototypes and some little Tools |
34 sub spawn; |
59 sub spawn; |
35 sub logmsg { |
60 sub logmsg { |
36 my ($level, @text) = @_; |
61 my ($level, $debug, @text) = @_; |
37 syslog("daemon|$level", @text) if $dolog; |
62 syslog("daemon|$level", @text) if $debug > $dolog; |
38 # print STDERR "daemon|$level", @text, "\n" if $dolog; |
63 # print STDERR "daemon|$level", @text, "\n" if $dolog; |
39 } |
64 } |
40 sub out { |
65 sub out { |
41 my $waitpid = wait; |
66 my $waitpid = wait; |
42 logmsg("notice", "$waitpid exited"); |
67 logmsg("notice", 2, "$waitpid exited"); |
43 unlink "$selfbase.pid"; |
68 unlink "$selfbase.pid"; |
44 exit 0; |
69 exit 0; |
45 } |
70 } |
46 |
71 |
47 sub help { |
72 sub help { |
105 or die "listen: $!"; |
131 or die "listen: $!"; |
106 |
132 |
107 %authhosts = (); |
133 %authhosts = (); |
108 # get authorized hosts |
134 # get authorized hosts |
109 open (AUTH, $authfile) |
135 open (AUTH, $authfile) |
110 or logmsg ("notice", "Could not read allowed hosts file: $authfile"); |
136 or logmsg ("notice", 2, "Could not read allowed hosts file: $authfile"); |
111 while (<AUTH>) { |
137 while (<AUTH>) { |
112 chomp; |
138 chomp; |
113 my $host = lc $_; |
139 my $host = lc $_; |
114 logmsg ("notice", "Authorized host: $host"); |
140 if ($host =~ /^[\d\w]/) { |
115 $authhosts{$_} = 1 if $host =~ /^[\d\w]/; |
141 $authhosts{$_} = 1; |
|
142 logmsg ("notice", 2, "Authorized host: >$host<"); |
|
143 } |
116 } |
144 } |
117 close (AUTH); |
145 close (AUTH); |
118 |
146 |
119 # tell about open server socket |
147 # tell about open server socket |
120 logmsg ("notice", "Server started at port $port"); |
148 logmsg ("notice", 2, "Server started at port $port"); |
121 |
149 |
122 my $waitpid = 0; |
150 my $waitedpid = 0; |
123 my $paddr; |
151 my $paddr; |
124 |
152 |
125 # wait for children to return, thus avoiding zombies |
153 # wait for children to return, thus avoiding zombies |
|
154 # improvement (*) |
|
155 use POSIX ":sys_wait_h"; |
126 sub REAPER { |
156 sub REAPER { |
127 $waitpid = wait; |
157 my $child; |
128 $SIG{CHLD} = \&REAPER; |
158 while (($waitedpid = waitpid(-1,WNOHANG)) > 0) { |
129 logmsg ("notice", "reaped $waitpid", ($? ? " with exit $?" : "")); |
159 logmsg ("notice", 2, "reaped $waitedpid", ($? ? " with exit $?" : "")); |
|
160 } |
|
161 $SIG{CHLD} = \&REAPER; # loathe sysV |
130 } |
162 } |
131 |
163 |
132 # also all sub-processes should wait for their children |
164 # also all sub-processes should wait for their children |
133 $SIG{CHLD} = \&REAPER; |
165 $SIG{CHLD} = \&REAPER; |
134 |
166 |
135 # start a new server for every incoming request |
167 # start a new server for every incoming request |
136 for ( ; $paddr = accept(Client, Server); close (Client)) { |
168 # improvement (*) -- loop forever |
137 my ($port, $iaddr) = sockaddr_in($paddr); |
169 |
138 my $name = lc gethostbyaddr($iaddr, AF_INET); |
170 while ( 1 ) { |
139 my $ipaddr = inet_ntoa($iaddr); |
171 for ( $waitedpid = 0; |
140 my $n = 0; |
172 ($paddr = accept(Client,Server)) || $waitedpid; |
141 |
173 $waitedpid = 0, close Client ) { |
|
174 next if $waitedpid and not $paddr; |
|
175 my ($port, $iaddr) = sockaddr_in($paddr); |
|
176 my $name = lc gethostbyaddr($iaddr, AF_INET); |
|
177 my $ipaddr = inet_ntoa($iaddr); |
|
178 my $n = 0; |
|
179 |
142 # tell about the requesting client |
180 # tell about the requesting client |
143 logmsg ("info", "Connection from $ipaddr ($name) at port $port"); |
181 logmsg ("info", 2, "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 |
182 |
|
183 spawn sub { |
|
184 my ($head, $hlen, $pos, $pegel, $typ, $siz, $nch, $nrec, $dat, $i, $j, $n, $llen); |
|
185 my ($watchpegel, $shmpegel); |
|
186 my ($rin, $rout, $in, $line, $data_requested, $oversample); |
|
187 my (@channels); |
|
188 |
151 # to use stdio on writing to Client |
189 # to use stdio on writing to Client |
152 Client->autoflush(); |
190 Client->autoflush(); |
153 |
191 |
154 # Open Device |
192 # Open Device |
155 sysopen (DEV, "$dev", O_RDWR | O_NONBLOCK, 0666) or die("can't open $dev"); |
193 sysopen (DEV, "$dev", O_RDWR | O_NONBLOCK, 0666) or die("can't open $dev"); |
156 |
194 |
157 # Bitmask to check for input on stdin |
195 # Bitmask to check for input on stdin |
158 $rin = ""; |
196 $rin = ""; |
159 vec($rin, fileno(Client), 1) = 1; |
197 vec($rin, fileno(Client), 1) = 1; |
160 |
198 |
161 # check for authorized hosts |
199 # check for authorized hosts |
162 my $access = 'allow'; |
200 my $access = 'deny'; |
163 $access = 'allow' if $authhosts{$ipaddr}; |
201 $access = 'allow' if $authhosts{$ipaddr}; |
164 $line = "<remote_host host=\"$ipaddr\" access=\"$access\">\n"; |
202 $line = "<remote_host host=\"$ipaddr\" access=\"$access\">\n"; |
165 $len = length $line; |
203 logmsg ("info", 2, $line); |
166 $offset = 0; |
204 $len = length $line; |
167 while ($len) { |
205 $offset = 0; |
|
206 while ($len) { |
168 $written = syswrite (DEV, $line, $len, $offset); |
207 $written = syswrite (DEV, $line, $len, $offset); |
169 $len -= $written; |
208 $len -= $written; |
170 $offset += $written; |
209 $offset += $written; |
171 } |
210 } |
172 |
211 |
173 while ( 1 ) { |
212 while ( 1 ) { |
174 $in = select ($rout=$rin, undef, undef, 0.0); # poll client |
213 $in = select ($rout=$rin, undef, undef, 0.0); # poll client |
175 # look for any Input from Client |
214 # look for any Input from Client |
176 if ($in) { |
215 if ($in) { |
177 # exit on EOF |
216 # exit on EOF |
178 $len = sysread (Client, $line, $blksize) or exit; |
217 $len = sysread (Client, $line, $blksize) or exit; |
179 logmsg("info", "got $len bytes: \"$line\""); |
218 logmsg("info", 0, "got $len bytes: \"$line\""); |
180 $offset = 0; |
219 $offset = 0; |
181 # copy request to device |
220 # copy request to device |
182 while ($len) { |
221 while ($len) { |
183 $written = syswrite (DEV, $line, $len, $offset); |
222 $written = syswrite (DEV, $line, $len, $offset); |
184 $len -= $written; |
223 $len -= $written; |
185 $offset += $written; |
224 $offset += $written; |
|
225 } |
|
226 } |
|
227 # look for some output from device |
|
228 if ($len = sysread DEV, $stream, $blksize) { |
|
229 print Client $stream; |
|
230 } else { |
|
231 select undef, undef, undef, 0.1; # calm down if nothing on device |
186 } |
232 } |
187 } |
233 } |
188 # look for some output from device |
234 }; |
189 if ($len = sysread DEV, $stream, $blksize) { |
235 logmsg("info", 2, "spawned\n"); |
190 print Client $stream; |
236 } |
191 } else { |
237 logmsg("info", 2, "server loop\n"); |
192 select undef, undef, undef, 0.1; # calm down if nothing on device |
|
193 } |
|
194 } |
|
195 } |
|
196 } |
238 } |
197 |
239 |
198 sub spawn { |
240 sub spawn { |
199 my $coderef = shift; |
241 my $coderef = shift; |
200 |
242 |
201 unless (@_ == 0 && $coderef && ref($coderef) eq 'CODE') { |
243 unless (@_ == 0 && $coderef && ref($coderef) eq 'CODE') { |
202 confess "usage: spawn CODEREF"; |
244 confess "usage: spawn CODEREF"; |
203 } |
245 } |
204 my $pid; |
246 my $pid; |
205 if (!defined($pid = fork)) { |
247 if (!defined($pid = fork)) { |
206 logmsg ("notice", "fork failed: $!"); |
248 logmsg ("notice", 2, "fork failed: $!"); |
207 return; |
249 return; |
208 } elsif ($pid) { |
250 } elsif ($pid) { |
209 logmsg ("notice", "Request $pid"); |
251 logmsg ("notice", 2, "Request $pid"); |
210 return; # Parent |
252 return; # Parent |
211 } |
253 } |
212 |
254 |
213 # do not use fdup as in the original example |
255 # do not use fdup as in the original example |
214 # open (STDIN, "<&Client") or die "Can't dup client to stdin"; |
256 # open (STDIN, "<&Client") or die "Can't dup client to stdin"; |