File Coverage

blib/lib/Coro/Socket.pm
Criterion Covered Total %
statement 21 68 30.8
branch 0 58 0.0
condition 0 42 0.0
subroutine 7 13 53.8
pod 1 2 50.0
total 29 183 15.8


line stmt bran cond sub pod time code
1             =head1 NAME
2              
3             Coro::Socket - non-blocking socket-I/O
4              
5             =head1 SYNOPSIS
6              
7             use Coro::Socket;
8              
9             # listen on an ipv4 socket
10             my $socket = new Coro::Socket PeerHost => "localhost",
11             PeerPort => 'finger';
12              
13             # listen on any other type of socket
14             my $socket = Coro::Socket->new_from_fh
15             (IO::Socket::UNIX->new
16             Local => "/tmp/socket",
17             Type => SOCK_STREAM,
18             );
19              
20             =head1 DESCRIPTION
21              
22             This module is an L user, you need to make sure that you use and
23             run a supported event loop.
24              
25             This module implements socket-handles in a coroutine-compatible way,
26             that is, other coroutines can run while reads or writes block on the
27             handle. See L, especially the note about prefering method
28             calls.
29              
30             =head1 IPV6 WARNING
31              
32             This module was written to imitate the L API, and derive
33             from it. Since IO::Socket::INET does not support IPv6, this module does
34             neither.
35              
36             Therefore it is not recommended to use Coro::Socket in new code. Instead,
37             use L and L, e.g.:
38              
39             use Coro;
40             use Coro::Handle;
41             use AnyEvent::Socket;
42              
43             # use tcp_connect from AnyEvent::Socket
44             # and call Coro::Handle::unblock on it.
45              
46             tcp_connect "www.google.com", 80, Coro::rouse_cb;
47             my $fh = unblock +(Coro::rouse_wait)[0];
48              
49             # now we have a perfectly thread-safe socket handle in $fh
50             print $fh "GET / HTTP/1.0\015\012\015\012";
51             local $/;
52             print <$fh>;
53              
54             Using C gives you transparent IPv6,
55             multi-homing, SRV-record etc. support.
56              
57             For listening sockets, use C.
58              
59             =over 4
60              
61             =cut
62              
63             package Coro::Socket;
64              
65 1     1   385 use common::sense;
  1         1  
  1         4  
66              
67 1     1   40 use Errno ();
  1         1  
  1         15  
68 1     1   4 use Carp qw(croak);
  1         2  
  1         37  
69 1     1   10 use Socket;
  1         2  
  1         418  
70 1     1   303 use IO::Socket::INET ();
  1         11347  
  1         22  
71              
72 1     1   6 use Coro::Util ();
  1         2  
  1         17  
73              
74 1     1   4 use base qw(Coro::Handle IO::Socket::INET);
  1         4  
  1         1029  
75              
76             our $VERSION = 6.514;
77              
78             our (%_proto, %_port);
79              
80             sub _proto($) {
81 0   0 0     $_proto{$_[0]} ||= do {
82 0 0 0       ((getprotobyname $_[0])[2] || (getprotobynumber $_[0])[2])
83             or croak "unsupported protocol: $_[0]";
84             };
85             }
86              
87             sub _port($$) {
88 0   0 0     $_port{$_[0],$_[1]} ||= do {
89 0 0         return $_[0] if $_[0] =~ /^\d+$/;
90              
91 0 0         $_[0] =~ /([^(]+)\s*(?:\((\d+)\))?/x
92             or croak "unparsable port number: $_[0]";
93 0 0 0       ((getservbyname $1, $_[1])[2]
      0        
94             || (getservbyport $1, $_[1])[2]
95             || $2)
96             or croak "unknown port: $_[0]";
97             };
98             }
99              
100             sub _sa($$$) {
101 0     0     my ($host, $port, $proto) = @_;
102              
103 0 0 0       $port or $host =~ s/:([^:]+)$// and $port = $1;
104              
105 0           my $_proto = _proto($proto);
106 0           my $_port = _port($port, $proto);
107              
108 0 0         my $_host = Coro::Util::inet_aton $host
109             or croak "$host: unable to resolve";
110              
111 0           pack_sockaddr_in $_port, $_host
112             }
113              
114             =item $fh = new Coro::Socket param => value, ...
115              
116             Create a new non-blocking tcp handle and connect to the given host
117             and port. The parameter names and values are mostly the same as for
118             IO::Socket::INET (as ugly as I think they are).
119              
120             The parameters officially supported currently are: C,
121             C, C, C, C, C, C,
122             C, C.
123              
124             $fh = new Coro::Socket PeerHost => "localhost", PeerPort => 'finger';
125              
126             =cut
127              
128             sub _prepare_socket {
129 0     0     my ($self, $arg) = @_;
130              
131 0           $self
132             }
133            
134             sub new {
135 0     0 1   my ($class, %arg) = @_;
136              
137 0   0       $arg{Proto} ||= 'tcp';
138 0   0       $arg{LocalHost} ||= delete $arg{LocalAddr};
139 0   0       $arg{PeerHost} ||= delete $arg{PeerAddr};
140 0 0         defined ($arg{Type}) or $arg{Type} = $arg{Proto} eq "tcp" ? SOCK_STREAM : SOCK_DGRAM;
    0          
141              
142             socket my $fh, PF_INET, $arg{Type}, _proto ($arg{Proto})
143 0 0         or return;
144              
145             my $self = bless Coro::Handle->new_from_fh (
146             $fh,
147             timeout => $arg{Timeout},
148             forward_class => $arg{forward_class},
149             partial => $arg{partial},
150 0 0         ), $class
151             or return;
152              
153 0           $self->configure (\%arg)
154             }
155              
156             sub configure {
157 0     0 0   my ($self, $arg) = @_;
158              
159 0 0         if ($arg->{ReuseAddr}) {
160 0 0         $self->setsockopt (SOL_SOCKET, SO_REUSEADDR, 1)
161             or croak "setsockopt(SO_REUSEADDR): $!";
162             }
163              
164 0 0         if ($arg->{ReusePort}) {
165 0 0         $self->setsockopt (SOL_SOCKET, SO_REUSEPORT, 1)
166             or croak "setsockopt(SO_REUSEPORT): $!";
167             }
168              
169 0 0         if ($arg->{Broadcast}) {
170 0 0         $self->setsockopt (SOL_SOCKET, SO_BROADCAST, 1)
171             or croak "setsockopt(SO_BROADCAST): $!";
172             }
173              
174 0 0         if ($arg->{SO_RCVBUF}) {
175             $self->setsockopt (SOL_SOCKET, SO_RCVBUF, $arg->{SO_RCVBUF})
176 0 0         or croak "setsockopt(SO_RCVBUF): $!";
177             }
178              
179 0 0         if ($arg->{SO_SNDBUF}) {
180             $self->setsockopt (SOL_SOCKET, SO_SNDBUF, $arg->{SO_SNDBUF})
181 0 0         or croak "setsockopt(SO_SNDBUF): $!";
182             }
183              
184 0 0 0       if ($arg->{LocalPort} || $arg->{LocalHost}) {
185 0   0       my @sa = _sa($arg->{LocalHost} || "0.0.0.0", $arg->{LocalPort} || 0, $arg->{Proto});
      0        
186 0 0         $self->bind ($sa[0])
187             or croak "bind($arg->{LocalHost}:$arg->{LocalPort}): $!";
188             }
189              
190 0 0         if ($arg->{PeerHost}) {
    0          
191 0           my @sa = _sa ($arg->{PeerHost}, $arg->{PeerPort}, $arg->{Proto});
192              
193 0           for (@sa) {
194 0           $! = 0;
195              
196 0 0         if ($self->connect ($_)) {
197 0 0         next unless writable $self;
198 0           $! = unpack "i", $self->getsockopt (SOL_SOCKET, SO_ERROR);
199             }
200              
201 0 0         $! or last;
202              
203             $!{ECONNREFUSED} or $!{ENETUNREACH} or $!{ETIMEDOUT} or $!{EHOSTUNREACH}
204 0 0 0       or return;
      0        
      0        
205             }
206             } elsif (exists $arg->{Listen}) {
207             $self->listen ($arg->{Listen})
208 0 0         or return;
209             }
210              
211             $self
212 0           }
213              
214             1;
215              
216             =back
217              
218             =head1 AUTHOR/SUPPORT/CONTACT
219              
220             Marc A. Lehmann
221             http://software.schmorp.de/pkg/Coro.html
222              
223             =cut
224