/[meteor]/googlecode.com/svn/trunk/Meteor/Socket.pm
This is repository of my old source code which isn't updated any more. Go to git.rot13.org for current projects!
ViewVC logotype

Diff of /googlecode.com/svn/trunk/Meteor/Socket.pm

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

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

Legend:
Removed from v.8  
changed lines
  Added in v.9

  ViewVC Help
Powered by ViewVC 1.1.26