File Coverage

blib/lib/IO/Async/Internals/Connector.pm
Criterion Covered Total %
statement 112 141 79.4
branch 33 72 45.8
condition 35 58 60.3
subroutine 17 17 100.0
pod 0 2 0.0
total 197 290 67.9


line stmt bran cond sub pod time code
1             # You may distribute under the terms of either the GNU General Public License
2             # or the Artistic License (the same terms as Perl itself)
3             #
4             # (C) Paul Evans, 2008-2013 -- leonerd@leonerd.org.uk
5              
6             package # hide from CPAN
7             IO::Async::Internals::Connector;
8              
9 3     3   36 use strict;
  3         6  
  3         101  
10 3     3   15 use warnings;
  3         7  
  3         182  
11              
12             our $VERSION = '0.79';
13              
14 3     3   22 use Scalar::Util qw( weaken blessed );
  3         5  
  3         237  
15              
16 3     3   20 use POSIX qw( EINPROGRESS );
  3         6  
  3         22  
17 3     3   245 use Socket qw( SOL_SOCKET SO_ERROR );
  3         6  
  3         217  
18              
19 3     3   20 use Future 0.21;
  3         70  
  3         122  
20 3     3   21 use Future::Utils 0.18 qw( try_repeat_until_success );
  3         60  
  3         170  
21              
22 3     3   21 use IO::Async::OS;
  3         5  
  3         97  
23              
24 3     3   16 use Carp;
  3         6  
  3         257  
25              
26             use constant {
27 3         5261 CONNECT_EWOULDLBOCK => IO::Async::OS->HAVE_CONNECT_EWOULDBLOCK,
28             HAVE_SOCKADDR_IN6 => IO::Async::OS->HAVE_SOCKADDR_IN6,
29 3     3   32 };
  3         5  
30              
31             # Internal constructor
32             sub new
33             {
34 3     3 0 7 my $class = shift;
35 3         10 my ( %params ) = @_;
36              
37 3 50       39 my $loop = delete $params{loop} or croak "Expected a 'loop'";
38              
39 3         8 my $self = bless {}, $class;
40 3         44 weaken( $self->{loop} = $loop );
41              
42 3         18 return $self;
43             }
44              
45             ## Utility function
46             sub _get_sock_err
47             {
48 11     11   25 my ( $sock ) = @_;
49              
50 11         73 my $err = $sock->getsockopt( SOL_SOCKET, SO_ERROR );
51              
52 11 50       295 if( defined $err ) {
53             # 0 means no error, but is still defined
54 11 100       41 return undef if !$err;
55              
56 1         4 $! = $err;
57 1         6 return $!;
58             }
59              
60             # It seems we can't call getsockopt to query SO_ERROR. We'll try getpeername
61 0 0       0 if( defined getpeername( $sock ) ) {
62 0         0 return undef;
63             }
64              
65 0         0 my $peername_errno = $!+0;
66 0         0 my $peername_errstr = "$!";
67              
68             # Not connected so we know this ought to fail
69 0 0       0 if( read( $sock, my $buff, 1 ) ) {
70             # That was most unexpected. getpeername fails because we're not
71             # connected, yet read succeeds.
72 0         0 warn "getpeername fails with $peername_errno ($peername_errstr) but read is successful\n";
73 0         0 warn "Please see http://rt.cpan.org/Ticket/Display.html?id=38382\n";
74              
75 0         0 $! = $peername_errno;
76 0         0 return $!;
77             }
78              
79 0         0 return $!;
80             }
81              
82             sub _connect_addresses
83             {
84 15     15   28 my $self = shift;
85 15         31 my ( $addrlist, $on_fail ) = @_;
86              
87 15         32 my $loop = $self->{loop};
88              
89 15         30 my ( $connecterr, $binderr, $socketerr );
90              
91             my $future = try_repeat_until_success {
92 15     15   1193 my $addr = shift;
93             my ( $family, $socktype, $protocol, $localaddr, $peeraddr ) =
94 15         32 @{$addr}{qw( family socktype protocol localaddr peeraddr )};
  15         57  
95              
96 15         76 my $sock = IO::Async::OS->socket( $family, $socktype, $protocol );
97              
98 15 50       2136 if( !$sock ) {
99 0         0 $socketerr = $!;
100 0 0       0 $on_fail->( "socket", $family, $socktype, $protocol, $! ) if $on_fail;
101 0         0 return Future->fail( 1 );
102             }
103              
104 15 50 66     66 if( $localaddr and not $sock->bind( $localaddr ) ) {
105 0         0 $binderr = $!;
106 0 0       0 $on_fail->( "bind", $sock, $localaddr, $! ) if $on_fail;
107 0         0 return Future->fail( 1 );
108             }
109              
110 15         104 $sock->blocking( 0 );
111              
112             # TODO: $sock->connect returns success masking EINPROGRESS
113 15         1501 my $ret = connect( $sock, $peeraddr );
114 15 100 100     217 if( $ret ) {
    100          
115             # Succeeded already? Dubious, but OK. Can happen e.g. with connections to
116             # localhost, or UNIX sockets, or something like that.
117 2         13 return Future->done( $sock );
118             }
119             elsif( $! != EINPROGRESS and !CONNECT_EWOULDLBOCK || $! != POSIX::EWOULDBLOCK ) {
120 2         7 $connecterr = $!;
121 2 50       39 $on_fail->( "connect", $sock, $peeraddr, $! ) if $on_fail;
122 2         26 return Future->fail( 1 );
123             }
124              
125             # Else
126 11         54 my $f = $loop->new_future;
127             $loop->watch_io(
128             handle => $sock,
129             on_write_ready => sub {
130 11         45 $loop->unwatch_io( handle => $sock, on_write_ready => 1 );
131              
132 11         38 my $err = _get_sock_err( $sock );
133              
134 11 100       56 return $f->done( $sock ) if !$err;
135              
136 1         3 $connecterr = $!;
137 1 50       7 $on_fail->( "connect", $sock, $peeraddr, $err ) if $on_fail;
138 1         16 return $f->fail( 1 );
139             },
140 11         140 );
141             $f->on_cancel(
142 0         0 sub { $loop->unwatch_io( handle => $sock, on_write_ready => 1 ); }
143 11         91 );
144 11         263 return $f;
145 15         157 } foreach => $addrlist;
146              
147             return $future->else_with_f( sub {
148 3     3   385 my $f = shift;
149              
150 3 50       13 return $future->new->fail( "connect: $connecterr", connect => connect => $connecterr )
151             if $connecterr;
152 0 0       0 return $future->new->fail( "bind: $binderr", connect => bind => $binderr )
153             if $binderr;
154 0 0       0 return $future->new->fail( "socket: $socketerr", connect => socket => $socketerr )
155             if $socketerr;
156              
157             # If it gets this far then something went wrong
158 0         0 return $f;
159 15         1608 } );
160             }
161              
162             sub connect
163             {
164 15     15 0 27 my $self = shift;
165 15         42 my ( %params ) = @_;
166              
167 15         31 my $loop = $self->{loop};
168              
169 15         27 my $on_fail = $params{on_fail};
170              
171 15         26 my %gai_hints;
172 15   100     93 exists $params{$_} and $gai_hints{$_} = $params{$_} for qw( family socktype protocol flags );
173              
174 15 50 66     74 if( exists $params{host} or exists $params{local_host} or exists $params{local_port} ) {
      33        
175             # We'll be making a ->getaddrinfo call
176             defined $gai_hints{socktype} or defined $gai_hints{protocol} or
177 6 50 33     24 carp "Attempting to ->connect without either 'socktype' or 'protocol' hint is not portable";
178             }
179              
180 15         22 my $peeraddrfuture;
181 15 100 66     81 if( exists $params{host} and exists $params{service} ) {
    50 33        
    0          
182 6 50       21 my $host = $params{host} or croak "Expected 'host'";
183 6 50       22 my $service = $params{service} or croak "Expected 'service'";
184              
185 6         38 $peeraddrfuture = $loop->resolver->getaddrinfo(
186             host => $host,
187             service => $service,
188             %gai_hints,
189             );
190             }
191             elsif( exists $params{addrs} or exists $params{addr} ) {
192 9 50       25 my @addrs = exists $params{addrs} ? @{ $params{addrs} } : ( $params{addr} );
  0         0  
193              
194             # Warn about some common mistakes
195 9         20 foreach my $peer ( @addrs ) {
196 9         68 my ( $p_family, undef, undef, $p_addr ) = IO::Async::OS->extract_addrinfo( $peer );
197              
198 9         42 local our @CARP_NOT = qw( IO::Async::Loop IO::Async::Handle );
199              
200 9 100       29 if( $p_family == Socket::AF_INET ) {
    50          
201 7 50       51 carp "Connecting to 0.0.0.0 is non-portable and ill-advised"
202             if ( Socket::unpack_sockaddr_in $p_addr )[1] eq Socket::INADDR_ANY;
203             }
204             elsif( HAVE_SOCKADDR_IN6 and $p_family == Socket::AF_INET6 ) {
205 0 0       0 carp "Connecting to :: is non-portable and ill-advised"
206             if ( Socket::unpack_sockaddr_in6 $p_addr )[1] eq Socket::IN6ADDR_ANY;
207             }
208             }
209              
210 9         48 $peeraddrfuture = $loop->new_future->done( @addrs );
211             }
212             elsif( exists $params{peer} ) {
213 0         0 my $peer = delete $params{peer};
214 0 0 0     0 croak "Expected 'peer' to be an IO::Socket or subclass"
215             unless blessed $peer and $peer->isa( "IO::Socket" );
216              
217 0         0 my $p_family = $peer->sockdomain;
218              
219 0         0 $peeraddrfuture = $loop->new_future->done(
220             [ $p_family, $peer->socktype, $peer->protocol, IO::Async::OS->make_addr_for_peer( $p_family, $peer->sockname ) ]
221             );
222             }
223             else {
224 0         0 croak "Expected 'host' and 'service' or 'addrs' or 'addr' arguments";
225             }
226              
227 15         395 my $localaddrfuture;
228 15 100 66     130 if( defined $params{local_host} or defined $params{local_service} ) {
    50 33        
229             # Empty is fine on either of these
230 1         4 my $host = $params{local_host};
231 1         4 my $service = $params{local_service};
232              
233 1         4 $localaddrfuture = $loop->resolver->getaddrinfo(
234             host => $host,
235             service => $service,
236             %gai_hints,
237             );
238             }
239             elsif( exists $params{local_addrs} or exists $params{local_addr} ) {
240 0 0       0 $localaddrfuture = $loop->new_future->done( exists $params{local_addrs} ? @{ $params{local_addrs} } : ( $params{local_addr} ) );
  0         0  
241             }
242             else {
243 14         42 $localaddrfuture = $loop->new_future->done( {} );
244             }
245              
246             return Future->needs_all( $peeraddrfuture, $localaddrfuture )
247             ->then( sub {
248 15     15   2494 my @peeraddrs = $peeraddrfuture->get;
249 15         293 my @localaddrs = $localaddrfuture->get;
250              
251 15         197 my @addrs;
252              
253 15         30 foreach my $local ( @localaddrs ) {
254 15         75 my ( $l_family, $l_socktype, $l_protocol, $l_addr ) =
255             IO::Async::OS->extract_addrinfo( $local, 'local_addr' );
256 15         39 foreach my $peer ( @peeraddrs ) {
257 15         43 my ( $p_family, $p_socktype, $p_protocol, $p_addr ) =
258             IO::Async::OS->extract_addrinfo( $peer );
259              
260 15 50 66     74 next if $l_family and $p_family and $l_family != $p_family;
      66        
261 15 50 66     42 next if $l_socktype and $p_socktype and $l_socktype != $p_socktype;
      66        
262 15 50 66     49 next if $l_protocol and $p_protocol and $l_protocol != $p_protocol;
      66        
263              
264 15   66     186 push @addrs, {
      66        
      100        
265             family => $l_family || $p_family,
266             socktype => $l_socktype || $p_socktype,
267             protocol => $l_protocol || $p_protocol,
268             localaddr => $l_addr,
269             peeraddr => $p_addr,
270             };
271             }
272             }
273              
274 15         58 return $self->_connect_addresses( \@addrs, $on_fail );
275 15         484 } );
276             }
277              
278             0x55AA;