1 |
#!/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 |
$Meteor::Socket::UDP_PROTO_NAME=getprotobyname('udp'); |
49 |
} |
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 |
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 |
############################################################################### |
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 |
############################################################################EOF |