ViewVC Help
View File | Revision Log | Show Annotations | Download File
/cvs/AnyEvent/lib/AnyEvent/Handle.pm
(Generate patch)

Comparing AnyEvent/lib/AnyEvent/Handle.pm (file contents):
Revision 1.242 by root, Wed Dec 10 04:29:33 2014 UTC vs.
Revision 1.252 by root, Fri Oct 18 20:12:16 2019 UTC

30 30
31 $cv->recv; 31 $cv->recv;
32 32
33=head1 DESCRIPTION 33=head1 DESCRIPTION
34 34
35This is a helper module to make it easier to do event-based I/O on 35This is a helper module to make it easier to do event-based I/O
36stream-based filehandles (sockets, pipes, and other stream things). 36on stream-based filehandles (sockets, pipes, and other stream
37things). Specifically, it doesn't work as expected on files, packet-based
38sockets or similar things.
37 39
38The L<AnyEvent::Intro> tutorial contains some well-documented 40The L<AnyEvent::Intro> tutorial contains some well-documented
39AnyEvent::Handle examples. 41AnyEvent::Handle examples.
40 42
41In the following, where the documentation refers to "bytes", it means 43In the following, where the documentation refers to "bytes", it means
53package AnyEvent::Handle; 55package AnyEvent::Handle;
54 56
55use Scalar::Util (); 57use Scalar::Util ();
56use List::Util (); 58use List::Util ();
57use Carp (); 59use Carp ();
58use Errno qw(EAGAIN EINTR); 60use Errno qw(EAGAIN EWOULDBLOCK EINTR);
59 61
60use AnyEvent (); BEGIN { AnyEvent::common_sense } 62use AnyEvent (); BEGIN { AnyEvent::common_sense }
61use AnyEvent::Util qw(WSAEWOULDBLOCK); 63use AnyEvent::Util qw(WSAEWOULDBLOCK);
62 64
63our $VERSION = $AnyEvent::VERSION; 65our $VERSION = $AnyEvent::VERSION;
91 93
92=item fh => $filehandle [C<fh> or C<connect> MANDATORY] 94=item fh => $filehandle [C<fh> or C<connect> MANDATORY]
93 95
94The filehandle this L<AnyEvent::Handle> object will operate on. 96The filehandle this L<AnyEvent::Handle> object will operate on.
95NOTE: The filehandle will be set to non-blocking mode (using 97NOTE: The filehandle will be set to non-blocking mode (using
96C<AnyEvent::Util::fh_nonblocking>) by the constructor and needs to stay in 98C<AnyEvent::fh_unblock>) by the constructor and needs to stay in
97that mode. 99that mode.
98 100
99=item connect => [$host, $service] [C<fh> or C<connect> MANDATORY] 101=item connect => [$host, $service] [C<fh> or C<connect> MANDATORY]
100 102
101Try to connect to the specified host and service (port), using 103Try to connect to the specified host and service (port), using
611 # with AnyEvent::Handle, do them a favour. 613 # with AnyEvent::Handle, do them a favour.
612 my $type = getsockopt $self->{fh}, Socket::SOL_SOCKET (), Socket::SO_TYPE (); 614 my $type = getsockopt $self->{fh}, Socket::SOL_SOCKET (), Socket::SO_TYPE ();
613 Carp::croak "AnyEvent::Handle: only stream sockets supported, anything else will NOT work!" 615 Carp::croak "AnyEvent::Handle: only stream sockets supported, anything else will NOT work!"
614 if Socket::SOCK_STREAM () != (unpack "I", $type) && defined $type; 616 if Socket::SOCK_STREAM () != (unpack "I", $type) && defined $type;
615 617
616 AnyEvent::Util::fh_nonblocking $self->{fh}, 1; 618 AnyEvent::fh_unblock $self->{fh};
617 619
618 $self->{_activity} = 620 $self->{_activity} =
619 $self->{_ractivity} = 621 $self->{_ractivity} =
620 $self->{_wactivity} = AE::now; 622 $self->{_wactivity} = AE::now;
621 623
753 $_[0]{oobinline} = $_[1]; 755 $_[0]{oobinline} = $_[1];
754 756
755 eval { 757 eval {
756 local $SIG{__DIE__}; 758 local $SIG{__DIE__};
757 setsockopt $_[0]{fh}, Socket::SOL_SOCKET (), Socket::SO_OOBINLINE (), int $_[1] 759 setsockopt $_[0]{fh}, Socket::SOL_SOCKET (), Socket::SO_OOBINLINE (), int $_[1]
758 if $_[0]{fh};
759 };
760}
761
762=item $handle->keepalive ($boolean)
763
764Enables or disables the C<keepalive> setting (see constructor argument of
765the same name for details).
766
767=cut
768
769sub keepalive {
770 $_[0]{keepalive} = $_[1];
771
772 eval {
773 local $SIG{__DIE__};
774 setsockopt $_[0]{fh}, Socket::SOL_SOCKET (), Socket::SO_KEEPALIVE (), int $_[1]
775 if $_[0]{fh}; 760 if $_[0]{fh};
776 }; 761 };
777} 762}
778 763
779=item $handle->on_starttls ($cb) 764=item $handle->on_starttls ($cb)
971 $self->{on_drain}($self) 956 $self->{on_drain}($self)
972 if $self->{low_water_mark} >= (length $self->{wbuf}) + (length $self->{_tls_wbuf}) 957 if $self->{low_water_mark} >= (length $self->{wbuf}) + (length $self->{_tls_wbuf})
973 && $self->{on_drain}; 958 && $self->{on_drain};
974 959
975 delete $self->{_ww} unless length $self->{wbuf}; 960 delete $self->{_ww} unless length $self->{wbuf};
976 } elsif ($! != EAGAIN && $! != EINTR && $! != WSAEWOULDBLOCK) { 961 } elsif ($! != EAGAIN && $! != EINTR && $! != EWOULDBLOCK && $! != WSAEWOULDBLOCK) {
977 $self->_error ($!, 1); 962 $self->_error ($!, 1);
978 } 963 }
979 }; 964 };
980 965
981 # try to write data immediately 966 # try to write data immediately
1570}; 1555};
1571 1556
1572=item regex => $accept[, $reject[, $skip], $cb->($handle, $data) 1557=item regex => $accept[, $reject[, $skip], $cb->($handle, $data)
1573 1558
1574Makes a regex match against the regex object C<$accept> and returns 1559Makes a regex match against the regex object C<$accept> and returns
1575everything up to and including the match. 1560everything up to and including the match. All the usual regex variables
1561($1, %+ etc.) from the regex match are available in the callback.
1576 1562
1577Example: read a single line terminated by '\n'. 1563Example: read a single line terminated by '\n'.
1578 1564
1579 $handle->push_read (regex => qr<\n>, sub { ... }); 1565 $handle->push_read (regex => qr<\n>, sub { ... });
1580 1566
1870is handled, up to the fictituous protocol 4.x (but both SSL3+ and 1856is handled, up to the fictituous protocol 4.x (but both SSL3+ and
1871SSL2-compatible framing is supported). 1857SSL2-compatible framing is supported).
1872 1858
1873If it detects that the input data is likely TLS, it calls the callback 1859If it detects that the input data is likely TLS, it calls the callback
1874with a true value for C<$detect> and the (on-wire) TLS version as second 1860with a true value for C<$detect> and the (on-wire) TLS version as second
1875and third argument (C<$major> is C<3>, and C<$minor> is 0..3 for SSL 1861and third argument (C<$major> is C<3>, and C<$minor> is 0..4 for SSL
18763.0, TLS 1.0, 1.1 and 1.2, respectively). If it detects the input to 18623.0, TLS 1.0, 1.1, 1.2 and 1.3, respectively). If it detects the input
1877be definitely not TLS, it calls the callback with a false value for 1863to be definitely not TLS, it calls the callback with a false value for
1878C<$detect>. 1864C<$detect>.
1879 1865
1880The callback could use this information to decide whether or not to start 1866The callback could use this information to decide whether or not to start
1881TLS negotiation. 1867TLS negotiation.
1882 1868
1892accomodate protocol changes. 1878accomodate protocol changes.
1893 1879
1894This read type does not rely on L<AnyEvent::TLS> (and thus, not on 1880This read type does not rely on L<AnyEvent::TLS> (and thus, not on
1895L<Net::SSLeay>). 1881L<Net::SSLeay>).
1896 1882
1897=item tls_autostart => $tls[, $tls_ctx] 1883=item tls_autostart => [$tls_ctx, ]$tls
1898 1884
1899Tries to detect a valid SSL or TLS handshake. If one is detected, it tries 1885Tries to detect a valid SSL or TLS handshake. If one is detected, it tries
1900to start tls by calling C<starttls> with the given arguments. 1886to start tls by calling C<starttls> with the given arguments.
1901 1887
1902In practise, C<$tls> must be C<accept>, or a Net::SSLeay context that has 1888In practise, C<$tls> must be C<accept>, or a Net::SSLeay context that has
1906See C<tls_detect> above for more details. 1892See C<tls_detect> above for more details.
1907 1893
1908Example: give the client a chance to start TLS before accepting a text 1894Example: give the client a chance to start TLS before accepting a text
1909line. 1895line.
1910 1896
1911 $hdl->push_read (tls_detect => "accept"); 1897 $hdl->push_read (tls_autostart => "accept");
1912 $hdl->push_read (line => sub { 1898 $hdl->push_read (line => sub {
1913 print "received ", ($_[0]{tls} ? "encrypted" : "cleartext"), " <$_[1]>\n"; 1899 print "received ", ($_[0]{tls} ? "encrypted" : "cleartext"), " <$_[1]>\n";
1914 }); 1900 });
1915 1901
1916=cut 1902=cut
1928 ) { 1914 ) {
1929 return if 3 != length $1; # partial match, can't decide yet 1915 return if 3 != length $1; # partial match, can't decide yet
1930 1916
1931 # full match, valid TLS record 1917 # full match, valid TLS record
1932 my ($major, $minor) = unpack "CC", $1; 1918 my ($major, $minor) = unpack "CC", $1;
1933 $cb->($self, "accept", $major + $minor * 0.1); 1919 $cb->($self, "accept", $major, $minor);
1934 } else { 1920 } else {
1935 # mismatch == guaranteed not TLS 1921 # mismatch == guaranteed not TLS
1936 $cb->($self, undef); 1922 $cb->($self, undef);
1937 } 1923 }
1938 1924
2038 } elsif (defined $len) { 2024 } elsif (defined $len) {
2039 delete $self->{_rw}; 2025 delete $self->{_rw};
2040 $self->{_eof} = 1; 2026 $self->{_eof} = 1;
2041 $self->_drain_rbuf; 2027 $self->_drain_rbuf;
2042 2028
2043 } elsif ($! != EAGAIN && $! != EINTR && $! != WSAEWOULDBLOCK) { 2029 } elsif ($! != EAGAIN && $! != EINTR && $! != EWOULDBLOCK && $! != WSAEWOULDBLOCK) {
2044 return $self->_error ($!, 1); 2030 return $self->_error ($!, 1);
2045 } 2031 }
2046 }; 2032 };
2047 } 2033 }
2048} 2034}
2207 $self->{tls} = $tls = $self->{tls_ctx}->_get_session ($tls, $self, $self->{peername}); 2193 $self->{tls} = $tls = $self->{tls_ctx}->_get_session ($tls, $self, $self->{peername});
2208 2194
2209 # basically, this is deep magic (because SSL_read should have the same issues) 2195 # basically, this is deep magic (because SSL_read should have the same issues)
2210 # but the openssl maintainers basically said: "trust us, it just works". 2196 # but the openssl maintainers basically said: "trust us, it just works".
2211 # (unfortunately, we have to hardcode constants because the abysmally misdesigned 2197 # (unfortunately, we have to hardcode constants because the abysmally misdesigned
2212 # and mismaintained ssleay-module doesn't even offer them). 2198 # and mismaintained ssleay-module didn't offer them for a decade or so).
2213 # http://www.mail-archive.com/openssl-dev@openssl.org/msg22420.html 2199 # http://www.mail-archive.com/openssl-dev@openssl.org/msg22420.html
2214 # 2200 #
2215 # in short: this is a mess. 2201 # in short: this is a mess.
2216 # 2202 #
2217 # note that we do not try to keep the length constant between writes as we are required to do. 2203 # note that we do not try to keep the length constant between writes as we are required to do.
2218 # we assume that most (but not all) of this insanity only applies to non-blocking cases, 2204 # we assume that most (but not all) of this insanity only applies to non-blocking cases,
2219 # and we drive openssl fully in blocking mode here. Or maybe we don't - openssl seems to 2205 # and we drive openssl fully in blocking mode here. Or maybe we don't - openssl seems to
2220 # have identity issues in that area. 2206 # have identity issues in that area.
2221# Net::SSLeay::CTX_set_mode ($ssl, 2207# Net::SSLeay::set_mode ($ssl,
2222# (eval { local $SIG{__DIE__}; Net::SSLeay::MODE_ENABLE_PARTIAL_WRITE () } || 1) 2208# (eval { local $SIG{__DIE__}; Net::SSLeay::MODE_ENABLE_PARTIAL_WRITE () } || 1)
2223# | (eval { local $SIG{__DIE__}; Net::SSLeay::MODE_ACCEPT_MOVING_WRITE_BUFFER () } || 2)); 2209# | (eval { local $SIG{__DIE__}; Net::SSLeay::MODE_ACCEPT_MOVING_WRITE_BUFFER () } || 2));
2224 Net::SSLeay::CTX_set_mode ($tls, 1|2); 2210 Net::SSLeay::set_mode ($tls, 1|2);
2225 2211
2226 $self->{_rbio} = Net::SSLeay::BIO_new (Net::SSLeay::BIO_s_mem ()); 2212 $self->{_rbio} = Net::SSLeay::BIO_new (Net::SSLeay::BIO_s_mem ());
2227 $self->{_wbio} = Net::SSLeay::BIO_new (Net::SSLeay::BIO_s_mem ()); 2213 $self->{_wbio} = Net::SSLeay::BIO_new (Net::SSLeay::BIO_s_mem ());
2228 2214
2229 Net::SSLeay::BIO_write ($self->{_rbio}, $self->{rbuf}); 2215 Net::SSLeay::BIO_write ($self->{_rbio}, $self->{rbuf});
2269 2255
2270 return unless $self->{tls}; 2256 return unless $self->{tls};
2271 2257
2272 $self->{tls_ctx}->_put_session (delete $self->{tls}) 2258 $self->{tls_ctx}->_put_session (delete $self->{tls})
2273 if $self->{tls} > 0; 2259 if $self->{tls} > 0;
2274 2260
2275 delete @$self{qw(_rbio _wbio _tls_wbuf _on_starttls)}; 2261 delete @$self{qw(_rbio _wbio _tls_wbuf _on_starttls)};
2276} 2262}
2277 2263
2278=item $handle->resettls 2264=item $handle->resettls
2279 2265
2304 push @linger, AE::io $fh, 1, sub { 2290 push @linger, AE::io $fh, 1, sub {
2305 my $len = syswrite $fh, $wbuf, length $wbuf; 2291 my $len = syswrite $fh, $wbuf, length $wbuf;
2306 2292
2307 if ($len > 0) { 2293 if ($len > 0) {
2308 substr $wbuf, 0, $len, ""; 2294 substr $wbuf, 0, $len, "";
2309 } elsif (defined $len || ($! != EAGAIN && $! != EINTR && $! != WSAEWOULDBLOCK)) { 2295 } elsif (defined $len || ($! != EAGAIN && $! != EINTR && $! != EWOULDBLOCK && $! != WSAEWOULDBLOCK)) {
2310 @linger = (); # end 2296 @linger = (); # end
2311 } 2297 }
2312 }; 2298 };
2313 push @linger, AE::timer $linger, 0, sub { 2299 push @linger, AE::timer $linger, 0, sub {
2314 @linger = (); 2300 @linger = ();

Diff Legend

Removed lines
+ Added lines
< Changed lines
> Changed lines