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 |
} |
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 |
############################################################################EOF |