1 |
knops.gerd |
11 |
#!/usr/bin/perl -w |
2 |
|
|
############################################################################### |
3 |
|
|
# Meteor |
4 |
|
|
# An HTTP server for the 2.0 web |
5 |
|
|
# Copyright (c) 2006 contributing authors |
6 |
|
|
# |
7 |
|
|
# Subscriber.pm |
8 |
|
|
# |
9 |
|
|
# Description: |
10 |
|
|
# Meteor socket additions |
11 |
|
|
# |
12 |
|
|
############################################################################### |
13 |
|
|
# |
14 |
|
|
# This program is free software; you can redistribute it and/or modify it |
15 |
|
|
# under the terms of the GNU General Public License as published by the Free |
16 |
|
|
# Software Foundation; either version 2 of the License, or (at your option) |
17 |
|
|
# any later version. |
18 |
|
|
# |
19 |
|
|
# This program is distributed in the hope that it will be useful, but WITHOUT |
20 |
|
|
# ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or |
21 |
|
|
# FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for |
22 |
|
|
# more details. |
23 |
|
|
# |
24 |
|
|
# You should have received a copy of the GNU General Public License along |
25 |
|
|
# with this program; if not, write to the Free Software Foundation, Inc., |
26 |
|
|
# 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA |
27 |
|
|
# |
28 |
|
|
# For more information visit www.meteorserver.org |
29 |
|
|
# |
30 |
|
|
############################################################################### |
31 |
|
|
|
32 |
|
|
package Meteor::Socket; |
33 |
|
|
############################################################################### |
34 |
|
|
# Configuration |
35 |
|
|
############################################################################### |
36 |
|
|
|
37 |
|
|
use strict; |
38 |
|
|
|
39 |
|
|
use Socket; |
40 |
|
|
use Fcntl qw(F_GETFL F_SETFL O_NONBLOCK); |
41 |
|
|
use Errno qw(EINTR); |
42 |
|
|
|
43 |
|
|
BEGIN { |
44 |
|
|
$Meteor::Socket::handleNum=0; |
45 |
|
|
|
46 |
|
|
# Cache getprotobyname result as on some systems it is slow. |
47 |
|
|
$Meteor::Socket::TCP_PROTO_NAME=getprotobyname('tcp'); |
48 |
knops.gerd |
48 |
$Meteor::Socket::UDP_PROTO_NAME=getprotobyname('udp'); |
49 |
knops.gerd |
11 |
} |
50 |
|
|
|
51 |
|
|
############################################################################### |
52 |
|
|
# Factory methods |
53 |
|
|
############################################################################### |
54 |
|
|
sub new { |
55 |
|
|
my $class=shift; |
56 |
|
|
|
57 |
|
|
my $self=$class; |
58 |
|
|
|
59 |
|
|
unless(ref($class)) |
60 |
|
|
{ |
61 |
|
|
$self={}; |
62 |
|
|
bless($self,$class); |
63 |
|
|
} |
64 |
|
|
|
65 |
|
|
$self->{'timeout'}=0; |
66 |
|
|
$self->{'buffer'}=''; |
67 |
|
|
|
68 |
|
|
return $self; |
69 |
|
|
} |
70 |
|
|
|
71 |
|
|
sub newWithHandle { |
72 |
|
|
my $class=shift; |
73 |
|
|
|
74 |
|
|
my $self=$class->new; |
75 |
|
|
$self->{'handle'}=shift; |
76 |
|
|
|
77 |
|
|
my $vec=''; |
78 |
|
|
vec($vec,CORE::fileno($self->{'handle'}),1)=1; |
79 |
|
|
$self->{'handleVec'}=$vec; |
80 |
|
|
|
81 |
|
|
my $timeout=shift; |
82 |
|
|
($timeout) && ($self->{'timeout'}=$timeout); |
83 |
|
|
|
84 |
|
|
return $self; |
85 |
|
|
} |
86 |
|
|
|
87 |
|
|
sub newServer { |
88 |
|
|
my($class,$port,$queueSize,$srcIP)=@_; |
89 |
|
|
|
90 |
|
|
($port) || die("$class: port undefined!"); |
91 |
|
|
|
92 |
|
|
$queueSize||=5; |
93 |
|
|
|
94 |
|
|
my $self=$class->new; |
95 |
|
|
|
96 |
|
|
my $localAdr=INADDR_ANY; |
97 |
|
|
$localAdr=inet_aton($srcIP) if(defined($srcIP) && $srcIP ne ''); |
98 |
|
|
|
99 |
|
|
my $local; |
100 |
|
|
my $sockType=AF_INET; |
101 |
|
|
my $proto=$Meteor::Socket::TCP_PROTO_NAME; |
102 |
|
|
|
103 |
|
|
$self->{'port'}=$port; |
104 |
|
|
($local=sockaddr_in($port,$localAdr)) |
105 |
|
|
|| die("$class: sockaddr_in for port '$port' failed"); |
106 |
|
|
|
107 |
|
|
$self->{'handle'}=$self->nextHandle(); |
108 |
|
|
$self->{'socketType'}=$sockType; |
109 |
|
|
|
110 |
|
|
socket($self->{'handle'},$sockType,SOCK_STREAM,$proto) |
111 |
|
|
|| die("$class socket: $!"); |
112 |
|
|
|
113 |
|
|
setsockopt($self->{'handle'},SOL_SOCKET,SO_REUSEADDR,1); |
114 |
|
|
|
115 |
|
|
bind($self->{'handle'},$local) |
116 |
|
|
|| die("$class bind: $!"); |
117 |
|
|
listen($self->{'handle'},$queueSize) |
118 |
|
|
|| die("$class listen: $!"); |
119 |
|
|
|
120 |
|
|
select((select($self->{'handle'}),$|=1)[0]); |
121 |
|
|
|
122 |
|
|
my $vec=''; |
123 |
|
|
vec($vec,CORE::fileno($self->{'handle'}),1)=1; |
124 |
|
|
$self->{'handleVec'}=$vec; |
125 |
|
|
|
126 |
|
|
return $self; |
127 |
|
|
} |
128 |
|
|
|
129 |
knops.gerd |
48 |
sub newUDPServer { |
130 |
|
|
my($class,$port,$srcIP)=@_; |
131 |
|
|
|
132 |
|
|
($port) || die("$class: port undefined!"); |
133 |
|
|
|
134 |
|
|
my $self=$class->new; |
135 |
|
|
|
136 |
|
|
my $localAdr=INADDR_ANY; |
137 |
|
|
$localAdr=inet_aton($srcIP) if(defined($srcIP) && $srcIP ne ''); |
138 |
|
|
|
139 |
|
|
my $local; |
140 |
|
|
my $sockType=PF_INET; |
141 |
|
|
my $proto=$Meteor::Socket::UDP_PROTO_NAME; |
142 |
|
|
|
143 |
|
|
$self->{'port'}=$port; |
144 |
|
|
($local=sockaddr_in($port,$localAdr)) |
145 |
|
|
|| die("$class: sockaddr_in for port '$port' failed"); |
146 |
|
|
|
147 |
|
|
$self->{'handle'}=$self->nextHandle(); |
148 |
|
|
$self->{'socketType'}=$sockType; |
149 |
|
|
|
150 |
|
|
socket($self->{'handle'},$sockType,SOCK_DGRAM,$proto) |
151 |
|
|
|| die("$class socket: $!"); |
152 |
|
|
|
153 |
|
|
setsockopt($self->{'handle'},SOL_SOCKET,SO_REUSEADDR,pack("l", 1)) |
154 |
|
|
|| die("setsockopt: $!"); |
155 |
|
|
|
156 |
|
|
bind($self->{'handle'},$local) |
157 |
|
|
|| die("$class bind: $!"); |
158 |
|
|
|
159 |
|
|
select((select($self->{'handle'}),$|=1)[0]); |
160 |
|
|
|
161 |
|
|
my $vec=''; |
162 |
|
|
vec($vec,CORE::fileno($self->{'handle'}),1)=1; |
163 |
|
|
$self->{'handleVec'}=$vec; |
164 |
|
|
|
165 |
|
|
return $self; |
166 |
|
|
} |
167 |
|
|
|
168 |
knops.gerd |
11 |
############################################################################### |
169 |
|
|
# Instance methods |
170 |
|
|
############################################################################### |
171 |
|
|
sub DESTROY { |
172 |
|
|
my $self=shift; |
173 |
|
|
|
174 |
|
|
if(exists($self->{'handle'})) |
175 |
|
|
{ |
176 |
|
|
warn("$self->DESTROY caught unclosed socket") |
177 |
|
|
unless($Meteor::Socket::NO_WARN_ON_CLOSE); |
178 |
|
|
$self->close(); |
179 |
|
|
} |
180 |
|
|
} |
181 |
|
|
|
182 |
|
|
sub conSocket { |
183 |
|
|
my $self=shift; |
184 |
|
|
|
185 |
|
|
my $handle=$self->nextHandle(); |
186 |
|
|
|
187 |
|
|
my $paddr; |
188 |
|
|
$paddr=&saccept($handle,$self->{'handle'}) || die($!); |
189 |
|
|
|
190 |
|
|
select((select($handle),$|=1)[0]); |
191 |
|
|
|
192 |
|
|
my $newSock=Meteor::Socket->newWithHandle($handle,20); |
193 |
|
|
$newSock->{'socketType'}=$self->{'socketType'}; |
194 |
|
|
if($self->{'socketType'}==AF_INET) |
195 |
|
|
{ |
196 |
|
|
my($port,$iaddr)=unpack_sockaddr_in($paddr); |
197 |
|
|
|
198 |
|
|
$newSock->{'connection'}->{'port'}=$port; |
199 |
|
|
$newSock->{'connection'}->{'remoteIP'}=inet_ntoa($iaddr); |
200 |
|
|
} |
201 |
|
|
|
202 |
|
|
return $newSock; |
203 |
|
|
} |
204 |
|
|
|
205 |
|
|
sub setNonBlocking { |
206 |
|
|
my $self=shift; |
207 |
|
|
|
208 |
|
|
my $flags=fcntl($self->{'handle'},F_GETFL,0) |
209 |
|
|
or die("Can't get flags for the socket: $!"); |
210 |
|
|
fcntl($self->{'handle'},F_SETFL,$flags|O_NONBLOCK) |
211 |
|
|
or die("Can't set flags for the socket: $!"); |
212 |
|
|
} |
213 |
|
|
|
214 |
|
|
sub close { |
215 |
|
|
my $self=shift; |
216 |
|
|
|
217 |
|
|
if(exists($self->{'handle'})) |
218 |
|
|
{ |
219 |
|
|
close($self->{'handle'}); |
220 |
|
|
delete($self->{'handle'}); |
221 |
|
|
} |
222 |
|
|
} |
223 |
|
|
|
224 |
|
|
############################################################################### |
225 |
|
|
# Utility functions |
226 |
|
|
############################################################################### |
227 |
|
|
sub nextHandle { |
228 |
|
|
no strict 'refs'; |
229 |
|
|
|
230 |
|
|
my $name='MSHandle'.$Meteor::Socket::handleNum++; |
231 |
|
|
my $pack='Meteor::Socket::'; |
232 |
|
|
my $handle=\*{$pack.$name}; |
233 |
|
|
delete $$pack{$name}; |
234 |
|
|
|
235 |
|
|
$handle; |
236 |
|
|
} |
237 |
|
|
|
238 |
|
|
sub sselect { |
239 |
|
|
my $result; |
240 |
|
|
my $to=$_[3]; |
241 |
|
|
my $time=time; |
242 |
|
|
while(1) |
243 |
|
|
{ |
244 |
|
|
$result=CORE::select($_[0],$_[1],$_[2],$to); |
245 |
|
|
if($result<0) |
246 |
|
|
{ |
247 |
|
|
last unless(${!}==EINTR); |
248 |
|
|
return 0 if($::HUP || $::TERM || $::USR1 || $::USR2); |
249 |
|
|
my $tn=time; |
250 |
|
|
$to-=($tn-$time); |
251 |
|
|
$time=$tn; |
252 |
|
|
$to=1 if($to<1); |
253 |
|
|
} |
254 |
|
|
else |
255 |
|
|
{ |
256 |
|
|
last; |
257 |
|
|
} |
258 |
|
|
} |
259 |
|
|
|
260 |
|
|
$result; |
261 |
|
|
} |
262 |
|
|
|
263 |
|
|
sub saccept { |
264 |
|
|
my($dhandle,$shandle)=@_; |
265 |
|
|
|
266 |
|
|
my $result; |
267 |
|
|
while(1) |
268 |
|
|
{ |
269 |
|
|
$result=CORE::accept($dhandle,$shandle); |
270 |
|
|
unless($result) |
271 |
|
|
{ |
272 |
|
|
last unless(${!}==EINTR); |
273 |
|
|
return 0 if($::HUP || $::TERM || $::USR1 || $::USR2); |
274 |
|
|
} |
275 |
|
|
else |
276 |
|
|
{ |
277 |
|
|
last; |
278 |
|
|
} |
279 |
|
|
} |
280 |
|
|
|
281 |
|
|
$result; |
282 |
|
|
} |
283 |
|
|
|
284 |
|
|
sub fileno { |
285 |
|
|
CORE::fileno(shift->{'handle'}); |
286 |
|
|
} |
287 |
|
|
|
288 |
|
|
1; |
289 |
andrew.betts |
3 |
############################################################################EOF |