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