1 |
andrew.betts |
9 |
#!/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 |
|
|
} |
49 |
|
|
|
50 |
|
|
############################################################################### |
51 |
|
|
# Factory methods |
52 |
|
|
############################################################################### |
53 |
|
|
sub new { |
54 |
|
|
my $class=shift; |
55 |
|
|
|
56 |
|
|
my $self=$class; |
57 |
|
|
|
58 |
|
|
unless(ref($class)) |
59 |
|
|
{ |
60 |
|
|
$self={}; |
61 |
|
|
bless($self,$class); |
62 |
|
|
} |
63 |
|
|
|
64 |
|
|
$self->{'timeout'}=0; |
65 |
|
|
$self->{'buffer'}=''; |
66 |
|
|
|
67 |
|
|
return $self; |
68 |
|
|
} |
69 |
|
|
|
70 |
|
|
sub newWithHandle { |
71 |
|
|
my $class=shift; |
72 |
|
|
|
73 |
|
|
my $self=$class->new; |
74 |
|
|
$self->{'handle'}=shift; |
75 |
|
|
|
76 |
|
|
my $vec=''; |
77 |
|
|
vec($vec,CORE::fileno($self->{'handle'}),1)=1; |
78 |
|
|
$self->{'handleVec'}=$vec; |
79 |
|
|
|
80 |
|
|
my $timeout=shift; |
81 |
|
|
($timeout) && ($self->{'timeout'}=$timeout); |
82 |
|
|
|
83 |
|
|
return $self; |
84 |
|
|
} |
85 |
|
|
|
86 |
|
|
sub newServer { |
87 |
|
|
my($class,$port,$queueSize,$srcIP)=@_; |
88 |
|
|
|
89 |
|
|
($port) || die("$class: port undefined!"); |
90 |
|
|
|
91 |
|
|
$queueSize||=5; |
92 |
|
|
|
93 |
|
|
my $self=$class->new; |
94 |
|
|
|
95 |
|
|
my $localAdr=INADDR_ANY; |
96 |
|
|
$localAdr=inet_aton($srcIP) if(defined($srcIP) && $srcIP ne ''); |
97 |
|
|
|
98 |
|
|
my $local; |
99 |
|
|
my $sockType=AF_INET; |
100 |
|
|
my $proto=$Meteor::Socket::TCP_PROTO_NAME; |
101 |
|
|
|
102 |
|
|
$self->{'port'}=$port; |
103 |
|
|
($local=sockaddr_in($port,$localAdr)) |
104 |
|
|
|| die("$class: sockaddr_in for port '$port' failed"); |
105 |
|
|
|
106 |
|
|
$self->{'handle'}=$self->nextHandle(); |
107 |
|
|
$self->{'socketType'}=$sockType; |
108 |
|
|
|
109 |
|
|
socket($self->{'handle'},$sockType,SOCK_STREAM,$proto) |
110 |
|
|
|| die("$class socket: $!"); |
111 |
|
|
|
112 |
|
|
setsockopt($self->{'handle'},SOL_SOCKET,SO_REUSEADDR,1); |
113 |
|
|
|
114 |
|
|
bind($self->{'handle'},$local) |
115 |
|
|
|| die("$class bind: $!"); |
116 |
|
|
listen($self->{'handle'},$queueSize) |
117 |
|
|
|| die("$class listen: $!"); |
118 |
|
|
|
119 |
|
|
select((select($self->{'handle'}),$|=1)[0]); |
120 |
|
|
|
121 |
|
|
my $vec=''; |
122 |
|
|
vec($vec,CORE::fileno($self->{'handle'}),1)=1; |
123 |
|
|
$self->{'handleVec'}=$vec; |
124 |
|
|
|
125 |
|
|
return $self; |
126 |
|
|
} |
127 |
|
|
|
128 |
|
|
############################################################################### |
129 |
|
|
# Instance methods |
130 |
|
|
############################################################################### |
131 |
|
|
sub DESTROY { |
132 |
|
|
my $self=shift; |
133 |
|
|
|
134 |
|
|
if(exists($self->{'handle'})) |
135 |
|
|
{ |
136 |
|
|
warn("$self->DESTROY caught unclosed socket") |
137 |
|
|
unless($Meteor::Socket::NO_WARN_ON_CLOSE); |
138 |
|
|
$self->close(); |
139 |
|
|
} |
140 |
|
|
} |
141 |
|
|
|
142 |
|
|
sub conSocket { |
143 |
|
|
my $self=shift; |
144 |
|
|
|
145 |
|
|
my $handle=$self->nextHandle(); |
146 |
|
|
|
147 |
|
|
my $paddr; |
148 |
|
|
$paddr=&saccept($handle,$self->{'handle'}) || die($!); |
149 |
|
|
|
150 |
|
|
select((select($handle),$|=1)[0]); |
151 |
|
|
|
152 |
|
|
my $newSock=Meteor::Socket->newWithHandle($handle,20); |
153 |
|
|
$newSock->{'socketType'}=$self->{'socketType'}; |
154 |
|
|
if($self->{'socketType'}==AF_INET) |
155 |
|
|
{ |
156 |
|
|
my($port,$iaddr)=unpack_sockaddr_in($paddr); |
157 |
|
|
|
158 |
|
|
$newSock->{'connection'}->{'port'}=$port; |
159 |
|
|
$newSock->{'connection'}->{'remoteIP'}=inet_ntoa($iaddr); |
160 |
|
|
} |
161 |
|
|
|
162 |
|
|
return $newSock; |
163 |
|
|
} |
164 |
|
|
|
165 |
|
|
sub setNonBlocking { |
166 |
|
|
my $self=shift; |
167 |
|
|
|
168 |
|
|
my $flags=fcntl($self->{'handle'},F_GETFL,0) |
169 |
|
|
or die("Can't get flags for the socket: $!"); |
170 |
|
|
fcntl($self->{'handle'},F_SETFL,$flags|O_NONBLOCK) |
171 |
|
|
or die("Can't set flags for the socket: $!"); |
172 |
|
|
} |
173 |
|
|
|
174 |
|
|
sub close { |
175 |
|
|
my $self=shift; |
176 |
|
|
|
177 |
|
|
if(exists($self->{'handle'})) |
178 |
|
|
{ |
179 |
|
|
close($self->{'handle'}); |
180 |
|
|
delete($self->{'handle'}); |
181 |
|
|
} |
182 |
|
|
} |
183 |
|
|
|
184 |
|
|
############################################################################### |
185 |
|
|
# Utility functions |
186 |
|
|
############################################################################### |
187 |
|
|
sub nextHandle { |
188 |
|
|
no strict 'refs'; |
189 |
|
|
|
190 |
|
|
my $name='MSHandle'.$Meteor::Socket::handleNum++; |
191 |
|
|
my $pack='Meteor::Socket::'; |
192 |
|
|
my $handle=\*{$pack.$name}; |
193 |
|
|
delete $$pack{$name}; |
194 |
|
|
|
195 |
|
|
$handle; |
196 |
|
|
} |
197 |
|
|
|
198 |
|
|
sub sselect { |
199 |
|
|
my $result; |
200 |
|
|
my $to=$_[3]; |
201 |
|
|
my $time=time; |
202 |
|
|
while(1) |
203 |
|
|
{ |
204 |
|
|
$result=CORE::select($_[0],$_[1],$_[2],$to); |
205 |
|
|
if($result<0) |
206 |
|
|
{ |
207 |
|
|
last unless(${!}==EINTR); |
208 |
|
|
return 0 if($::HUP || $::TERM || $::USR1 || $::USR2); |
209 |
|
|
my $tn=time; |
210 |
|
|
$to-=($tn-$time); |
211 |
|
|
$time=$tn; |
212 |
|
|
$to=1 if($to<1); |
213 |
|
|
} |
214 |
|
|
else |
215 |
|
|
{ |
216 |
|
|
last; |
217 |
|
|
} |
218 |
|
|
} |
219 |
|
|
|
220 |
|
|
$result; |
221 |
|
|
} |
222 |
|
|
|
223 |
|
|
sub saccept { |
224 |
|
|
my($dhandle,$shandle)=@_; |
225 |
|
|
|
226 |
|
|
my $result; |
227 |
|
|
while(1) |
228 |
|
|
{ |
229 |
|
|
$result=CORE::accept($dhandle,$shandle); |
230 |
|
|
unless($result) |
231 |
|
|
{ |
232 |
|
|
last unless(${!}==EINTR); |
233 |
|
|
return 0 if($::HUP || $::TERM || $::USR1 || $::USR2); |
234 |
|
|
} |
235 |
|
|
else |
236 |
|
|
{ |
237 |
|
|
last; |
238 |
|
|
} |
239 |
|
|
} |
240 |
|
|
|
241 |
|
|
$result; |
242 |
|
|
} |
243 |
|
|
|
244 |
|
|
sub fileno { |
245 |
|
|
CORE::fileno(shift->{'handle'}); |
246 |
|
|
} |
247 |
|
|
|
248 |
|
|
1; |
249 |
andrew.betts |
3 |
############################################################################EOF |