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.79 by root, Sun Jul 27 08:37:56 2008 UTC vs.
Revision 1.166 by root, Tue Jul 28 02:07:18 2009 UTC

1package AnyEvent::Handle; 1package AnyEvent::Handle;
2 2
3no warnings;
4use strict qw(subs vars);
5
6use AnyEvent ();
7use AnyEvent::Util qw(WSAEWOULDBLOCK);
8use Scalar::Util (); 3use Scalar::Util ();
9use Carp (); 4use Carp ();
10use Fcntl ();
11use Errno qw(EAGAIN EINTR); 5use Errno qw(EAGAIN EINTR);
12 6
7use AnyEvent (); BEGIN { AnyEvent::common_sense }
8use AnyEvent::Util qw(WSAEWOULDBLOCK);
9
13=head1 NAME 10=head1 NAME
14 11
15AnyEvent::Handle - non-blocking I/O on file handles via AnyEvent 12AnyEvent::Handle - non-blocking I/O on file handles via AnyEvent
16 13
17=cut 14=cut
18 15
19our $VERSION = 4.22; 16our $VERSION = 4.88;
20 17
21=head1 SYNOPSIS 18=head1 SYNOPSIS
22 19
23 use AnyEvent; 20 use AnyEvent;
24 use AnyEvent::Handle; 21 use AnyEvent::Handle;
25 22
26 my $cv = AnyEvent->condvar; 23 my $cv = AnyEvent->condvar;
27 24
28 my $handle = 25 my $hdl; $hdl = new AnyEvent::Handle
29 AnyEvent::Handle->new (
30 fh => \*STDIN, 26 fh => \*STDIN,
31 on_eof => sub { 27 on_error => sub {
32 $cv->broadcast; 28 my ($hdl, $fatal, $msg) = @_;
33 }, 29 warn "got error $msg\n";
30 $hdl->destroy;
31 $cv->send;
34 ); 32 );
35 33
36 # send some request line 34 # send some request line
37 $handle->push_write ("getinfo\015\012"); 35 $hdl->push_write ("getinfo\015\012");
38 36
39 # read the response line 37 # read the response line
40 $handle->push_read (line => sub { 38 $hdl->push_read (line => sub {
41 my ($handle, $line) = @_; 39 my ($hdl, $line) = @_;
42 warn "read line <$line>\n"; 40 warn "got line <$line>\n";
43 $cv->send; 41 $cv->send;
44 }); 42 });
45 43
46 $cv->recv; 44 $cv->recv;
47 45
48=head1 DESCRIPTION 46=head1 DESCRIPTION
49 47
50This module is a helper module to make it easier to do event-based I/O on 48This module is a helper module to make it easier to do event-based I/O on
51filehandles. For utility functions for doing non-blocking connects and accepts 49filehandles.
52on sockets see L<AnyEvent::Util>. 50
51The L<AnyEvent::Intro> tutorial contains some well-documented
52AnyEvent::Handle examples.
53 53
54In the following, when the documentation refers to of "bytes" then this 54In the following, when the documentation refers to of "bytes" then this
55means characters. As sysread and syswrite are used for all I/O, their 55means characters. As sysread and syswrite are used for all I/O, their
56treatment of characters applies to this module as well. 56treatment of characters applies to this module as well.
57 57
58At the very minimum, you should specify C<fh> or C<connect>, and the
59C<on_error> callback.
60
58All callbacks will be invoked with the handle object as their first 61All callbacks will be invoked with the handle object as their first
59argument. 62argument.
60 63
61=head1 METHODS 64=head1 METHODS
62 65
63=over 4 66=over 4
64 67
65=item B<new (%args)> 68=item $handle = B<new> AnyEvent::TLS fh => $filehandle, key => value...
66 69
67The constructor supports these arguments (all as key => value pairs). 70The constructor supports these arguments (all as C<< key => value >> pairs).
68 71
69=over 4 72=over 4
70 73
71=item fh => $filehandle [MANDATORY] 74=item fh => $filehandle [C<fh> or C<connect> MANDATORY]
72 75
73The filehandle this L<AnyEvent::Handle> object will operate on. 76The filehandle this L<AnyEvent::Handle> object will operate on.
74
75NOTE: The filehandle will be set to non-blocking (using 77NOTE: The filehandle will be set to non-blocking mode (using
76AnyEvent::Util::fh_nonblocking). 78C<AnyEvent::Util::fh_nonblocking>) by the constructor and needs to stay in
79that mode.
77 80
81=item connect => [$host, $service] [C<fh> or C<connect> MANDATORY]
82
83Try to connect to the specified host and service (port), using
84C<AnyEvent::Socket::tcp_connect>. The C<$host> additionally becomes the
85default C<peername>.
86
87You have to specify either this parameter, or C<fh>, above.
88
89It is possible to push requests on the read and write queues, and modify
90properties of the stream, even while AnyEvent::Handle is connecting.
91
92When this parameter is specified, then the C<on_prepare>,
93C<on_connect_error> and C<on_connect> callbacks will be called under the
94appropriate circumstances:
95
96=over 4
97
78=item on_eof => $cb->($handle) 98=item on_prepare => $cb->($handle)
79 99
80Set the callback to be called when an end-of-file condition is detected, 100This (rarely used) callback is called before a new connection is
81i.e. in the case of a socket, when the other side has closed the 101attempted, but after the file handle has been created. It could be used to
82connection cleanly. 102prepare the file handle with parameters required for the actual connect
103(as opposed to settings that can be changed when the connection is already
104established).
83 105
84While not mandatory, it is highly recommended to set an eof callback, 106The return value of this callback should be the connect timeout value in
85otherwise you might end up with a closed socket while you are still 107seconds (or C<0>, or C<undef>, or the empty list, to indicate the default
86waiting for data. 108timeout is to be used).
87 109
110=item on_connect => $cb->($handle, $host, $port, $retry->())
111
112This callback is called when a connection has been successfully established.
113
114The actual numeric host and port (the socket peername) are passed as
115parameters, together with a retry callback.
116
117When, for some reason, the handle is not acceptable, then calling
118C<$retry> will continue with the next conenction target (in case of
119multi-homed hosts or SRV records there can be multiple connection
120endpoints). When it is called then the read and write queues, eof status,
121tls status and similar properties of the handle are being reset.
122
123In most cases, ignoring the C<$retry> parameter is the way to go.
124
125=item on_connect_error => $cb->($handle, $message)
126
127This callback is called when the conenction could not be
128established. C<$!> will contain the relevant error code, and C<$message> a
129message describing it (usually the same as C<"$!">).
130
131If this callback isn't specified, then C<on_error> will be called with a
132fatal error instead.
133
134=back
135
88=item on_error => $cb->($handle, $fatal) 136=item on_error => $cb->($handle, $fatal, $message)
89 137
90This is the error callback, which is called when, well, some error 138This is the error callback, which is called when, well, some error
91occured, such as not being able to resolve the hostname, failure to 139occured, such as not being able to resolve the hostname, failure to
92connect or a read error. 140connect or a read error.
93 141
94Some errors are fatal (which is indicated by C<$fatal> being true). On 142Some errors are fatal (which is indicated by C<$fatal> being true). On
95fatal errors the handle object will be shut down and will not be 143fatal errors the handle object will be destroyed (by a call to C<< ->
144destroy >>) after invoking the error callback (which means you are free to
145examine the handle object). Examples of fatal errors are an EOF condition
146with active (but unsatisifable) read watchers (C<EPIPE>) or I/O errors. In
147cases where the other side can close the connection at their will it is
148often easiest to not report C<EPIPE> errors in this callback.
149
150AnyEvent::Handle tries to find an appropriate error code for you to check
151against, but in some cases (TLS errors), this does not work well. It is
152recommended to always output the C<$message> argument in human-readable
153error messages (it's usually the same as C<"$!">).
154
96usable. Non-fatal errors can be retried by simply returning, but it is 155Non-fatal errors can be retried by simply returning, but it is recommended
97recommended to simply ignore this parameter and instead abondon the handle 156to simply ignore this parameter and instead abondon the handle object
98object when this callback is invoked. 157when this callback is invoked. Examples of non-fatal errors are timeouts
158C<ETIMEDOUT>) or badly-formatted data (C<EBADMSG>).
99 159
100On callback entrance, the value of C<$!> contains the operating system 160On callback entrance, the value of C<$!> contains the operating system
101error (or C<ENOSPC>, C<EPIPE>, C<ETIMEDOUT> or C<EBADMSG>). 161error code (or C<ENOSPC>, C<EPIPE>, C<ETIMEDOUT>, C<EBADMSG> or
162C<EPROTO>).
102 163
103While not mandatory, it is I<highly> recommended to set this callback, as 164While not mandatory, it is I<highly> recommended to set this callback, as
104you will not be notified of errors otherwise. The default simply calls 165you will not be notified of errors otherwise. The default simply calls
105C<croak>. 166C<croak>.
106 167
110and no read request is in the queue (unlike read queue callbacks, this 171and no read request is in the queue (unlike read queue callbacks, this
111callback will only be called when at least one octet of data is in the 172callback will only be called when at least one octet of data is in the
112read buffer). 173read buffer).
113 174
114To access (and remove data from) the read buffer, use the C<< ->rbuf >> 175To access (and remove data from) the read buffer, use the C<< ->rbuf >>
115method or access the C<$handle->{rbuf}> member directly. 176method or access the C<< $handle->{rbuf} >> member directly. Note that you
177must not enlarge or modify the read buffer, you can only remove data at
178the beginning from it.
116 179
117When an EOF condition is detected then AnyEvent::Handle will first try to 180When an EOF condition is detected then AnyEvent::Handle will first try to
118feed all the remaining data to the queued callbacks and C<on_read> before 181feed all the remaining data to the queued callbacks and C<on_read> before
119calling the C<on_eof> callback. If no progress can be made, then a fatal 182calling the C<on_eof> callback. If no progress can be made, then a fatal
120error will be raised (with C<$!> set to C<EPIPE>). 183error will be raised (with C<$!> set to C<EPIPE>).
184
185Note that, unlike requests in the read queue, an C<on_read> callback
186doesn't mean you I<require> some data: if there is an EOF and there
187are outstanding read requests then an error will be flagged. With an
188C<on_read> callback, the C<on_eof> callback will be invoked.
189
190=item on_eof => $cb->($handle)
191
192Set the callback to be called when an end-of-file condition is detected,
193i.e. in the case of a socket, when the other side has closed the
194connection cleanly, and there are no outstanding read requests in the
195queue (if there are read requests, then an EOF counts as an unexpected
196connection close and will be flagged as an error).
197
198For sockets, this just means that the other side has stopped sending data,
199you can still try to write data, and, in fact, one can return from the EOF
200callback and continue writing data, as only the read part has been shut
201down.
202
203If an EOF condition has been detected but no C<on_eof> callback has been
204set, then a fatal error will be raised with C<$!> set to <0>.
121 205
122=item on_drain => $cb->($handle) 206=item on_drain => $cb->($handle)
123 207
124This sets the callback that is called when the write buffer becomes empty 208This sets the callback that is called when the write buffer becomes empty
125(or when the callback is set and the buffer is empty already). 209(or when the callback is set and the buffer is empty already).
135=item timeout => $fractional_seconds 219=item timeout => $fractional_seconds
136 220
137If non-zero, then this enables an "inactivity" timeout: whenever this many 221If non-zero, then this enables an "inactivity" timeout: whenever this many
138seconds pass without a successful read or write on the underlying file 222seconds pass without a successful read or write on the underlying file
139handle, the C<on_timeout> callback will be invoked (and if that one is 223handle, the C<on_timeout> callback will be invoked (and if that one is
140missing, an C<ETIMEDOUT> error will be raised). 224missing, a non-fatal C<ETIMEDOUT> error will be raised).
141 225
142Note that timeout processing is also active when you currently do not have 226Note that timeout processing is also active when you currently do not have
143any outstanding read or write requests: If you plan to keep the connection 227any outstanding read or write requests: If you plan to keep the connection
144idle then you should disable the timout temporarily or ignore the timeout 228idle then you should disable the timout temporarily or ignore the timeout
145in the C<on_timeout> callback. 229in the C<on_timeout> callback, in which case AnyEvent::Handle will simply
230restart the timeout.
146 231
147Zero (the default) disables this timeout. 232Zero (the default) disables this timeout.
148 233
149=item on_timeout => $cb->($handle) 234=item on_timeout => $cb->($handle)
150 235
154 239
155=item rbuf_max => <bytes> 240=item rbuf_max => <bytes>
156 241
157If defined, then a fatal error will be raised (with C<$!> set to C<ENOSPC>) 242If defined, then a fatal error will be raised (with C<$!> set to C<ENOSPC>)
158when the read buffer ever (strictly) exceeds this size. This is useful to 243when the read buffer ever (strictly) exceeds this size. This is useful to
159avoid denial-of-service attacks. 244avoid some forms of denial-of-service attacks.
160 245
161For example, a server accepting connections from untrusted sources should 246For example, a server accepting connections from untrusted sources should
162be configured to accept only so-and-so much data that it cannot act on 247be configured to accept only so-and-so much data that it cannot act on
163(for example, when expecting a line, an attacker could send an unlimited 248(for example, when expecting a line, an attacker could send an unlimited
164amount of data without a callback ever being called as long as the line 249amount of data without a callback ever being called as long as the line
165isn't finished). 250isn't finished).
166 251
167=item autocork => <boolean> 252=item autocork => <boolean>
168 253
169When disabled (the default), then C<push_write> will try to immediately 254When disabled (the default), then C<push_write> will try to immediately
170write the data to the handle if possible. This avoids having to register 255write the data to the handle, if possible. This avoids having to register
171a write watcher and wait for the next event loop iteration, but can be 256a write watcher and wait for the next event loop iteration, but can
172inefficient if you write multiple small chunks (this disadvantage is 257be inefficient if you write multiple small chunks (on the wire, this
173usually avoided by your kernel's nagle algorithm, see C<low_delay>). 258disadvantage is usually avoided by your kernel's nagle algorithm, see
259C<no_delay>, but this option can save costly syscalls).
174 260
175When enabled, then writes will always be queued till the next event loop 261When enabled, then writes will always be queued till the next event loop
176iteration. This is efficient when you do many small writes per iteration, 262iteration. This is efficient when you do many small writes per iteration,
177but less efficient when you do a single write only. 263but less efficient when you do a single write only per iteration (or when
264the write buffer often is full). It also increases write latency.
178 265
179=item no_delay => <boolean> 266=item no_delay => <boolean>
180 267
181When doing small writes on sockets, your operating system kernel might 268When doing small writes on sockets, your operating system kernel might
182wait a bit for more data before actually sending it out. This is called 269wait a bit for more data before actually sending it out. This is called
183the Nagle algorithm, and usually it is beneficial. 270the Nagle algorithm, and usually it is beneficial.
184 271
185In some situations you want as low a delay as possible, which cna be 272In some situations you want as low a delay as possible, which can be
186accomplishd by setting this option to true. 273accomplishd by setting this option to a true value.
187 274
188The default is your opertaing system's default behaviour, this option 275The default is your opertaing system's default behaviour (most likely
189explicitly enables or disables it, if possible. 276enabled), this option explicitly enables or disables it, if possible.
190 277
191=item read_size => <bytes> 278=item read_size => <bytes>
192 279
193The default read block size (the amount of bytes this module will try to read 280The default read block size (the amount of bytes this module will
194during each (loop iteration). Default: C<8192>. 281try to read during each loop iteration, which affects memory
282requirements). Default: C<8192>.
195 283
196=item low_water_mark => <bytes> 284=item low_water_mark => <bytes>
197 285
198Sets the amount of bytes (default: C<0>) that make up an "empty" write 286Sets the amount of bytes (default: C<0>) that make up an "empty" write
199buffer: If the write reaches this size or gets even samller it is 287buffer: If the write reaches this size or gets even samller it is
200considered empty. 288considered empty.
201 289
290Sometimes it can be beneficial (for performance reasons) to add data to
291the write buffer before it is fully drained, but this is a rare case, as
292the operating system kernel usually buffers data as well, so the default
293is good in almost all cases.
294
202=item linger => <seconds> 295=item linger => <seconds>
203 296
204If non-zero (default: C<3600>), then the destructor of the 297If non-zero (default: C<3600>), then the destructor of the
205AnyEvent::Handle object will check wether there is still outstanding write 298AnyEvent::Handle object will check whether there is still outstanding
206data and will install a watcher that will write out this data. No errors 299write data and will install a watcher that will write this data to the
207will be reported (this mostly matches how the operating system treats 300socket. No errors will be reported (this mostly matches how the operating
208outstanding data at socket close time). 301system treats outstanding data at socket close time).
209 302
210This will not work for partial TLS data that could not yet been 303This will not work for partial TLS data that could not be encoded
211encoded. This data will be lost. 304yet. This data will be lost. Calling the C<stoptls> method in time might
305help.
306
307=item peername => $string
308
309A string used to identify the remote site - usually the DNS hostname
310(I<not> IDN!) used to create the connection, rarely the IP address.
311
312Apart from being useful in error messages, this string is also used in TLS
313peername verification (see C<verify_peername> in L<AnyEvent::TLS>). This
314verification will be skipped when C<peername> is not specified or
315C<undef>.
212 316
213=item tls => "accept" | "connect" | Net::SSLeay::SSL object 317=item tls => "accept" | "connect" | Net::SSLeay::SSL object
214 318
215When this parameter is given, it enables TLS (SSL) mode, that means it 319When this parameter is given, it enables TLS (SSL) mode, that means
216will start making tls handshake and will transparently encrypt/decrypt 320AnyEvent will start a TLS handshake as soon as the conenction has been
217data. 321established and will transparently encrypt/decrypt data afterwards.
322
323All TLS protocol errors will be signalled as C<EPROTO>, with an
324appropriate error message.
218 325
219TLS mode requires Net::SSLeay to be installed (it will be loaded 326TLS mode requires Net::SSLeay to be installed (it will be loaded
220automatically when you try to create a TLS handle). 327automatically when you try to create a TLS handle): this module doesn't
328have a dependency on that module, so if your module requires it, you have
329to add the dependency yourself.
221 330
222For the TLS server side, use C<accept>, and for the TLS client side of a 331Unlike TCP, TLS has a server and client side: for the TLS server side, use
223connection, use C<connect> mode. 332C<accept>, and for the TLS client side of a connection, use C<connect>
333mode.
224 334
225You can also provide your own TLS connection object, but you have 335You can also provide your own TLS connection object, but you have
226to make sure that you call either C<Net::SSLeay::set_connect_state> 336to make sure that you call either C<Net::SSLeay::set_connect_state>
227or C<Net::SSLeay::set_accept_state> on it before you pass it to 337or C<Net::SSLeay::set_accept_state> on it before you pass it to
228AnyEvent::Handle. 338AnyEvent::Handle. Also, this module will take ownership of this connection
339object.
229 340
341At some future point, AnyEvent::Handle might switch to another TLS
342implementation, then the option to use your own session object will go
343away.
344
345B<IMPORTANT:> since Net::SSLeay "objects" are really only integers,
346passing in the wrong integer will lead to certain crash. This most often
347happens when one uses a stylish C<< tls => 1 >> and is surprised about the
348segmentation fault.
349
230See the C<starttls> method if you need to start TLS negotiation later. 350See the C<< ->starttls >> method for when need to start TLS negotiation later.
231 351
232=item tls_ctx => $ssl_ctx 352=item tls_ctx => $anyevent_tls
233 353
234Use the given Net::SSLeay::CTX object to create the new TLS connection 354Use the given C<AnyEvent::TLS> object to create the new TLS connection
235(unless a connection object was specified directly). If this parameter is 355(unless a connection object was specified directly). If this parameter is
236missing, then AnyEvent::Handle will use C<AnyEvent::Handle::TLS_CTX>. 356missing, then AnyEvent::Handle will use C<AnyEvent::Handle::TLS_CTX>.
237 357
358Instead of an object, you can also specify a hash reference with C<< key
359=> value >> pairs. Those will be passed to L<AnyEvent::TLS> to create a
360new TLS context object.
361
362=item on_starttls => $cb->($handle, $success[, $error_message])
363
364This callback will be invoked when the TLS/SSL handshake has finished. If
365C<$success> is true, then the TLS handshake succeeded, otherwise it failed
366(C<on_stoptls> will not be called in this case).
367
368The session in C<< $handle->{tls} >> can still be examined in this
369callback, even when the handshake was not successful.
370
371TLS handshake failures will not cause C<on_error> to be invoked when this
372callback is in effect, instead, the error message will be passed to C<on_starttls>.
373
374Without this callback, handshake failures lead to C<on_error> being
375called, as normal.
376
377Note that you cannot call C<starttls> right again in this callback. If you
378need to do that, start an zero-second timer instead whose callback can
379then call C<< ->starttls >> again.
380
381=item on_stoptls => $cb->($handle)
382
383When a SSLv3/TLS shutdown/close notify/EOF is detected and this callback is
384set, then it will be invoked after freeing the TLS session. If it is not,
385then a TLS shutdown condition will be treated like a normal EOF condition
386on the handle.
387
388The session in C<< $handle->{tls} >> can still be examined in this
389callback.
390
391This callback will only be called on TLS shutdowns, not when the
392underlying handle signals EOF.
393
238=item json => JSON or JSON::XS object 394=item json => JSON or JSON::XS object
239 395
240This is the json coder object used by the C<json> read and write types. 396This is the json coder object used by the C<json> read and write types.
241 397
242If you don't supply it, then AnyEvent::Handle will create and use a 398If you don't supply it, then AnyEvent::Handle will create and use a
243suitable one, which will write and expect UTF-8 encoded JSON texts. 399suitable one (on demand), which will write and expect UTF-8 encoded JSON
400texts.
244 401
245Note that you are responsible to depend on the JSON module if you want to 402Note that you are responsible to depend on the JSON module if you want to
246use this functionality, as AnyEvent does not have a dependency itself. 403use this functionality, as AnyEvent does not have a dependency itself.
247 404
248=item filter_r => $cb
249
250=item filter_w => $cb
251
252These exist, but are undocumented at this time.
253
254=back 405=back
255 406
256=cut 407=cut
257 408
258sub new { 409sub new {
259 my $class = shift; 410 my $class = shift;
260
261 my $self = bless { @_ }, $class; 411 my $self = bless { @_ }, $class;
262 412
263 $self->{fh} or Carp::croak "mandatory argument fh is missing"; 413 if ($self->{fh}) {
414 $self->_start;
415 return unless $self->{fh}; # could be gone by now
416
417 } elsif ($self->{connect}) {
418 require AnyEvent::Socket;
419
420 $self->{peername} = $self->{connect}[0]
421 unless exists $self->{peername};
422
423 $self->{_skip_drain_rbuf} = 1;
424
425 {
426 Scalar::Util::weaken (my $self = $self);
427
428 $self->{_connect} =
429 AnyEvent::Socket::tcp_connect (
430 $self->{connect}[0],
431 $self->{connect}[1],
432 sub {
433 my ($fh, $host, $port, $retry) = @_;
434
435 if ($fh) {
436 $self->{fh} = $fh;
437
438 delete $self->{_skip_drain_rbuf};
439 $self->_start;
440
441 $self->{on_connect}
442 and $self->{on_connect}($self, $host, $port, sub {
443 delete @$self{qw(fh _tw _ww _rw _eof _queue rbuf _wbuf tls _tls_rbuf _tls_wbuf)};
444 $self->{_skip_drain_rbuf} = 1;
445 &$retry;
446 });
447
448 } else {
449 if ($self->{on_connect_error}) {
450 $self->{on_connect_error}($self, "$!");
451 $self->destroy;
452 } else {
453 $self->_error ($!, 1);
454 }
455 }
456 },
457 sub {
458 local $self->{fh} = $_[0];
459
460 $self->{on_prepare}
461 ? $self->{on_prepare}->($self)
462 : ()
463 }
464 );
465 }
466
467 } else {
468 Carp::croak "AnyEvent::Handle: either an existing fh or the connect parameter must be specified";
469 }
470
471 $self
472}
473
474sub _start {
475 my ($self) = @_;
264 476
265 AnyEvent::Util::fh_nonblocking $self->{fh}, 1; 477 AnyEvent::Util::fh_nonblocking $self->{fh}, 1;
266
267 if ($self->{tls}) {
268 require Net::SSLeay;
269 $self->starttls (delete $self->{tls}, delete $self->{tls_ctx});
270 }
271 478
272 $self->{_activity} = AnyEvent->now; 479 $self->{_activity} = AnyEvent->now;
273 $self->_timeout; 480 $self->_timeout;
274 481
275 $self->on_drain (delete $self->{on_drain}) if exists $self->{on_drain};
276 $self->no_delay (delete $self->{no_delay}) if exists $self->{no_delay}; 482 $self->no_delay (delete $self->{no_delay}) if exists $self->{no_delay};
277 483
484 $self->starttls (delete $self->{tls}, delete $self->{tls_ctx})
485 if $self->{tls};
486
487 $self->on_drain (delete $self->{on_drain}) if $self->{on_drain};
488
278 $self->start_read 489 $self->start_read
279 if $self->{on_read}; 490 if $self->{on_read} || @{ $self->{_queue} };
280 491
281 $self 492 $self->_drain_wbuf;
282} 493}
283 494
284sub _shutdown { 495#sub _shutdown {
285 my ($self) = @_; 496# my ($self) = @_;
286 497#
287 delete $self->{_tw}; 498# delete @$self{qw(_tw _rw _ww fh wbuf on_read _queue)};
288 delete $self->{_rw}; 499# $self->{_eof} = 1; # tell starttls et. al to stop trying
289 delete $self->{_ww}; 500#
290 delete $self->{fh}; 501# &_freetls;
291 502#}
292 $self->stoptls;
293}
294 503
295sub _error { 504sub _error {
296 my ($self, $errno, $fatal) = @_; 505 my ($self, $errno, $fatal, $message) = @_;
297
298 $self->_shutdown
299 if $fatal;
300 506
301 $! = $errno; 507 $! = $errno;
508 $message ||= "$!";
302 509
303 if ($self->{on_error}) { 510 if ($self->{on_error}) {
304 $self->{on_error}($self, $fatal); 511 $self->{on_error}($self, $fatal, $message);
305 } else { 512 $self->destroy if $fatal;
513 } elsif ($self->{fh}) {
514 $self->destroy;
306 Carp::croak "AnyEvent::Handle uncaught error: $!"; 515 Carp::croak "AnyEvent::Handle uncaught error: $message";
307 } 516 }
308} 517}
309 518
310=item $fh = $handle->fh 519=item $fh = $handle->fh
311 520
312This method returns the file handle of the L<AnyEvent::Handle> object. 521This method returns the file handle used to create the L<AnyEvent::Handle> object.
313 522
314=cut 523=cut
315 524
316sub fh { $_[0]{fh} } 525sub fh { $_[0]{fh} }
317 526
335 $_[0]{on_eof} = $_[1]; 544 $_[0]{on_eof} = $_[1];
336} 545}
337 546
338=item $handle->on_timeout ($cb) 547=item $handle->on_timeout ($cb)
339 548
340Replace the current C<on_timeout> callback, or disables the callback 549Replace the current C<on_timeout> callback, or disables the callback (but
341(but not the timeout) if C<$cb> = C<undef>. See C<timeout> constructor 550not the timeout) if C<$cb> = C<undef>. See the C<timeout> constructor
342argument. 551argument and method.
343 552
344=cut 553=cut
345 554
346sub on_timeout { 555sub on_timeout {
347 $_[0]{on_timeout} = $_[1]; 556 $_[0]{on_timeout} = $_[1];
348} 557}
349 558
350=item $handle->autocork ($boolean) 559=item $handle->autocork ($boolean)
351 560
352Enables or disables the current autocork behaviour (see C<autocork> 561Enables or disables the current autocork behaviour (see C<autocork>
353constructor argument). 562constructor argument). Changes will only take effect on the next write.
354 563
355=cut 564=cut
565
566sub autocork {
567 $_[0]{autocork} = $_[1];
568}
356 569
357=item $handle->no_delay ($boolean) 570=item $handle->no_delay ($boolean)
358 571
359Enables or disables the C<no_delay> setting (see constructor argument of 572Enables or disables the C<no_delay> setting (see constructor argument of
360the same name for details). 573the same name for details).
364sub no_delay { 577sub no_delay {
365 $_[0]{no_delay} = $_[1]; 578 $_[0]{no_delay} = $_[1];
366 579
367 eval { 580 eval {
368 local $SIG{__DIE__}; 581 local $SIG{__DIE__};
369 setsockopt $_[0]{fh}, &Socket::IPPROTO_TCP, &Socket::TCP_NODELAY, int $_[1]; 582 setsockopt $_[0]{fh}, &Socket::IPPROTO_TCP, &Socket::TCP_NODELAY, int $_[1]
583 if $_[0]{fh};
370 }; 584 };
585}
586
587=item $handle->on_starttls ($cb)
588
589Replace the current C<on_starttls> callback (see the C<on_starttls> constructor argument).
590
591=cut
592
593sub on_starttls {
594 $_[0]{on_starttls} = $_[1];
595}
596
597=item $handle->on_stoptls ($cb)
598
599Replace the current C<on_stoptls> callback (see the C<on_stoptls> constructor argument).
600
601=cut
602
603sub on_starttls {
604 $_[0]{on_stoptls} = $_[1];
371} 605}
372 606
373############################################################################# 607#############################################################################
374 608
375=item $handle->timeout ($seconds) 609=item $handle->timeout ($seconds)
388# reset the timeout watcher, as neccessary 622# reset the timeout watcher, as neccessary
389# also check for time-outs 623# also check for time-outs
390sub _timeout { 624sub _timeout {
391 my ($self) = @_; 625 my ($self) = @_;
392 626
393 if ($self->{timeout}) { 627 if ($self->{timeout} && $self->{fh}) {
394 my $NOW = AnyEvent->now; 628 my $NOW = AnyEvent->now;
395 629
396 # when would the timeout trigger? 630 # when would the timeout trigger?
397 my $after = $self->{_activity} + $self->{timeout} - $NOW; 631 my $after = $self->{_activity} + $self->{timeout} - $NOW;
398 632
401 $self->{_activity} = $NOW; 635 $self->{_activity} = $NOW;
402 636
403 if ($self->{on_timeout}) { 637 if ($self->{on_timeout}) {
404 $self->{on_timeout}($self); 638 $self->{on_timeout}($self);
405 } else { 639 } else {
406 $self->_error (&Errno::ETIMEDOUT); 640 $self->_error (Errno::ETIMEDOUT);
407 } 641 }
408 642
409 # callback could have changed timeout value, optimise 643 # callback could have changed timeout value, optimise
410 return unless $self->{timeout}; 644 return unless $self->{timeout};
411 645
453 my ($self, $cb) = @_; 687 my ($self, $cb) = @_;
454 688
455 $self->{on_drain} = $cb; 689 $self->{on_drain} = $cb;
456 690
457 $cb->($self) 691 $cb->($self)
458 if $cb && $self->{low_water_mark} >= length $self->{wbuf}; 692 if $cb && $self->{low_water_mark} >= (length $self->{wbuf}) + (length $self->{_tls_wbuf});
459} 693}
460 694
461=item $handle->push_write ($data) 695=item $handle->push_write ($data)
462 696
463Queues the given scalar to be written. You can push as much data as you 697Queues the given scalar to be written. You can push as much data as you
474 Scalar::Util::weaken $self; 708 Scalar::Util::weaken $self;
475 709
476 my $cb = sub { 710 my $cb = sub {
477 my $len = syswrite $self->{fh}, $self->{wbuf}; 711 my $len = syswrite $self->{fh}, $self->{wbuf};
478 712
479 if ($len >= 0) { 713 if (defined $len) {
480 substr $self->{wbuf}, 0, $len, ""; 714 substr $self->{wbuf}, 0, $len, "";
481 715
482 $self->{_activity} = AnyEvent->now; 716 $self->{_activity} = AnyEvent->now;
483 717
484 $self->{on_drain}($self) 718 $self->{on_drain}($self)
485 if $self->{low_water_mark} >= length $self->{wbuf} 719 if $self->{low_water_mark} >= (length $self->{wbuf}) + (length $self->{_tls_wbuf})
486 && $self->{on_drain}; 720 && $self->{on_drain};
487 721
488 delete $self->{_ww} unless length $self->{wbuf}; 722 delete $self->{_ww} unless length $self->{wbuf};
489 } elsif ($! != EAGAIN && $! != EINTR && $! != WSAEWOULDBLOCK) { 723 } elsif ($! != EAGAIN && $! != EINTR && $! != WSAEWOULDBLOCK) {
490 $self->_error ($!, 1); 724 $self->_error ($!, 1);
514 748
515 @_ = ($WH{$type} or Carp::croak "unsupported type passed to AnyEvent::Handle::push_write") 749 @_ = ($WH{$type} or Carp::croak "unsupported type passed to AnyEvent::Handle::push_write")
516 ->($self, @_); 750 ->($self, @_);
517 } 751 }
518 752
519 if ($self->{filter_w}) { 753 if ($self->{tls}) {
520 $self->{filter_w}($self, \$_[0]); 754 $self->{_tls_wbuf} .= $_[0];
755 &_dotls ($self) if $self->{fh};
521 } else { 756 } else {
522 $self->{wbuf} .= $_[0]; 757 $self->{wbuf} .= $_[0];
523 $self->_drain_wbuf; 758 $self->_drain_wbuf if $self->{fh};
524 } 759 }
525} 760}
526 761
527=item $handle->push_write (type => @args) 762=item $handle->push_write (type => @args)
528 763
542=cut 777=cut
543 778
544register_write_type netstring => sub { 779register_write_type netstring => sub {
545 my ($self, $string) = @_; 780 my ($self, $string) = @_;
546 781
547 sprintf "%d:%s,", (length $string), $string 782 (length $string) . ":$string,"
548}; 783};
549 784
550=item packstring => $format, $data 785=item packstring => $format, $data
551 786
552An octet string prefixed with an encoded length. The encoding C<$format> 787An octet string prefixed with an encoded length. The encoding C<$format>
617 852
618 pack "w/a*", Storable::nfreeze ($ref) 853 pack "w/a*", Storable::nfreeze ($ref)
619}; 854};
620 855
621=back 856=back
857
858=item $handle->push_shutdown
859
860Sometimes you know you want to close the socket after writing your data
861before it was actually written. One way to do that is to replace your
862C<on_drain> handler by a callback that shuts down the socket (and set
863C<low_water_mark> to C<0>). This method is a shorthand for just that, and
864replaces the C<on_drain> callback with:
865
866 sub { shutdown $_[0]{fh}, 1 } # for push_shutdown
867
868This simply shuts down the write side and signals an EOF condition to the
869the peer.
870
871You can rely on the normal read queue and C<on_eof> handling
872afterwards. This is the cleanest way to close a connection.
873
874=cut
875
876sub push_shutdown {
877 my ($self) = @_;
878
879 delete $self->{low_water_mark};
880 $self->on_drain (sub { shutdown $_[0]{fh}, 1 });
881}
622 882
623=item AnyEvent::Handle::register_write_type type => $coderef->($handle, @args) 883=item AnyEvent::Handle::register_write_type type => $coderef->($handle, @args)
624 884
625This function (not method) lets you add your own types to C<push_write>. 885This function (not method) lets you add your own types to C<push_write>.
626Whenever the given C<type> is used, C<push_write> will invoke the code 886Whenever the given C<type> is used, C<push_write> will invoke the code
720=cut 980=cut
721 981
722sub _drain_rbuf { 982sub _drain_rbuf {
723 my ($self) = @_; 983 my ($self) = @_;
724 984
985 # avoid recursion
986 return if exists $self->{_skip_drain_rbuf};
725 local $self->{_in_drain} = 1; 987 local $self->{_skip_drain_rbuf} = 1;
726 988
727 if ( 989 if (
728 defined $self->{rbuf_max} 990 defined $self->{rbuf_max}
729 && $self->{rbuf_max} < length $self->{rbuf} 991 && $self->{rbuf_max} < length $self->{rbuf}
730 ) { 992 ) {
731 return $self->_error (&Errno::ENOSPC, 1); 993 $self->_error (Errno::ENOSPC, 1), return;
732 } 994 }
733 995
734 while () { 996 while () {
997 # we need to use a separate tls read buffer, as we must not receive data while
998 # we are draining the buffer, and this can only happen with TLS.
999 $self->{rbuf} .= delete $self->{_tls_rbuf}
1000 if exists $self->{_tls_rbuf};
1001
735 my $len = length $self->{rbuf}; 1002 my $len = length $self->{rbuf};
736 1003
737 if (my $cb = shift @{ $self->{_queue} }) { 1004 if (my $cb = shift @{ $self->{_queue} }) {
738 unless ($cb->($self)) { 1005 unless ($cb->($self)) {
739 if ($self->{_eof}) { 1006 # no progress can be made
740 # no progress can be made (not enough data and no data forthcoming) 1007 # (not enough data and no data forthcoming)
741 $self->_error (&Errno::EPIPE, 1), last; 1008 $self->_error (Errno::EPIPE, 1), return
742 } 1009 if $self->{_eof};
743 1010
744 unshift @{ $self->{_queue} }, $cb; 1011 unshift @{ $self->{_queue} }, $cb;
745 last; 1012 last;
746 } 1013 }
747 } elsif ($self->{on_read}) { 1014 } elsif ($self->{on_read}) {
754 && !@{ $self->{_queue} } # and the queue is still empty 1021 && !@{ $self->{_queue} } # and the queue is still empty
755 && $self->{on_read} # but we still have on_read 1022 && $self->{on_read} # but we still have on_read
756 ) { 1023 ) {
757 # no further data will arrive 1024 # no further data will arrive
758 # so no progress can be made 1025 # so no progress can be made
759 $self->_error (&Errno::EPIPE, 1), last 1026 $self->_error (Errno::EPIPE, 1), return
760 if $self->{_eof}; 1027 if $self->{_eof};
761 1028
762 last; # more data might arrive 1029 last; # more data might arrive
763 } 1030 }
764 } else { 1031 } else {
765 # read side becomes idle 1032 # read side becomes idle
766 delete $self->{_rw}; 1033 delete $self->{_rw} unless $self->{tls};
767 last; 1034 last;
768 } 1035 }
769 } 1036 }
770 1037
1038 if ($self->{_eof}) {
1039 $self->{on_eof}
771 $self->{on_eof}($self) 1040 ? $self->{on_eof}($self)
772 if $self->{_eof} && $self->{on_eof}; 1041 : $self->_error (0, 1, "Unexpected end-of-file");
1042
1043 return;
1044 }
773 1045
774 # may need to restart read watcher 1046 # may need to restart read watcher
775 unless ($self->{_rw}) { 1047 unless ($self->{_rw}) {
776 $self->start_read 1048 $self->start_read
777 if $self->{on_read} || @{ $self->{_queue} }; 1049 if $self->{on_read} || @{ $self->{_queue} };
788 1060
789sub on_read { 1061sub on_read {
790 my ($self, $cb) = @_; 1062 my ($self, $cb) = @_;
791 1063
792 $self->{on_read} = $cb; 1064 $self->{on_read} = $cb;
793 $self->_drain_rbuf if $cb && !$self->{_in_drain}; 1065 $self->_drain_rbuf if $cb;
794} 1066}
795 1067
796=item $handle->rbuf 1068=item $handle->rbuf
797 1069
798Returns the read buffer (as a modifiable lvalue). 1070Returns the read buffer (as a modifiable lvalue).
799 1071
800You can access the read buffer directly as the C<< ->{rbuf} >> member, if 1072You can access the read buffer directly as the C<< ->{rbuf} >>
801you want. 1073member, if you want. However, the only operation allowed on the
1074read buffer (apart from looking at it) is removing data from its
1075beginning. Otherwise modifying or appending to it is not allowed and will
1076lead to hard-to-track-down bugs.
802 1077
803NOTE: The read buffer should only be used or modified if the C<on_read>, 1078NOTE: The read buffer should only be used or modified if the C<on_read>,
804C<push_read> or C<unshift_read> methods are used. The other read methods 1079C<push_read> or C<unshift_read> methods are used. The other read methods
805automatically manage the read buffer. 1080automatically manage the read buffer.
806 1081
847 $cb = ($RH{$type} or Carp::croak "unsupported type passed to AnyEvent::Handle::push_read") 1122 $cb = ($RH{$type} or Carp::croak "unsupported type passed to AnyEvent::Handle::push_read")
848 ->($self, $cb, @_); 1123 ->($self, $cb, @_);
849 } 1124 }
850 1125
851 push @{ $self->{_queue} }, $cb; 1126 push @{ $self->{_queue} }, $cb;
852 $self->_drain_rbuf unless $self->{_in_drain}; 1127 $self->_drain_rbuf;
853} 1128}
854 1129
855sub unshift_read { 1130sub unshift_read {
856 my $self = shift; 1131 my $self = shift;
857 my $cb = pop; 1132 my $cb = pop;
863 ->($self, $cb, @_); 1138 ->($self, $cb, @_);
864 } 1139 }
865 1140
866 1141
867 unshift @{ $self->{_queue} }, $cb; 1142 unshift @{ $self->{_queue} }, $cb;
868 $self->_drain_rbuf unless $self->{_in_drain}; 1143 $self->_drain_rbuf;
869} 1144}
870 1145
871=item $handle->push_read (type => @args, $cb) 1146=item $handle->push_read (type => @args, $cb)
872 1147
873=item $handle->unshift_read (type => @args, $cb) 1148=item $handle->unshift_read (type => @args, $cb)
1006 return 1; 1281 return 1;
1007 } 1282 }
1008 1283
1009 # reject 1284 # reject
1010 if ($reject && $$rbuf =~ $reject) { 1285 if ($reject && $$rbuf =~ $reject) {
1011 $self->_error (&Errno::EBADMSG); 1286 $self->_error (Errno::EBADMSG);
1012 } 1287 }
1013 1288
1014 # skip 1289 # skip
1015 if ($skip && $$rbuf =~ $skip) { 1290 if ($skip && $$rbuf =~ $skip) {
1016 $data .= substr $$rbuf, 0, $+[0], ""; 1291 $data .= substr $$rbuf, 0, $+[0], "";
1032 my ($self, $cb) = @_; 1307 my ($self, $cb) = @_;
1033 1308
1034 sub { 1309 sub {
1035 unless ($_[0]{rbuf} =~ s/^(0|[1-9][0-9]*)://) { 1310 unless ($_[0]{rbuf} =~ s/^(0|[1-9][0-9]*)://) {
1036 if ($_[0]{rbuf} =~ /[^0-9]/) { 1311 if ($_[0]{rbuf} =~ /[^0-9]/) {
1037 $self->_error (&Errno::EBADMSG); 1312 $self->_error (Errno::EBADMSG);
1038 } 1313 }
1039 return; 1314 return;
1040 } 1315 }
1041 1316
1042 my $len = $1; 1317 my $len = $1;
1045 my $string = $_[1]; 1320 my $string = $_[1];
1046 $_[0]->unshift_read (chunk => 1, sub { 1321 $_[0]->unshift_read (chunk => 1, sub {
1047 if ($_[1] eq ",") { 1322 if ($_[1] eq ",") {
1048 $cb->($_[0], $string); 1323 $cb->($_[0], $string);
1049 } else { 1324 } else {
1050 $self->_error (&Errno::EBADMSG); 1325 $self->_error (Errno::EBADMSG);
1051 } 1326 }
1052 }); 1327 });
1053 }); 1328 });
1054 1329
1055 1 1330 1
1061An octet string prefixed with an encoded length. The encoding C<$format> 1336An octet string prefixed with an encoded length. The encoding C<$format>
1062uses the same format as a Perl C<pack> format, but must specify a single 1337uses the same format as a Perl C<pack> format, but must specify a single
1063integer only (only one of C<cCsSlLqQiInNvVjJw> is allowed, plus an 1338integer only (only one of C<cCsSlLqQiInNvVjJw> is allowed, plus an
1064optional C<!>, C<< < >> or C<< > >> modifier). 1339optional C<!>, C<< < >> or C<< > >> modifier).
1065 1340
1066DNS over TCP uses a prefix of C<n>, EPP uses a prefix of C<N>. 1341For example, DNS over TCP uses a prefix of C<n> (2 octet network order),
1342EPP uses a prefix of C<N> (4 octtes).
1067 1343
1068Example: read a block of data prefixed by its length in BER-encoded 1344Example: read a block of data prefixed by its length in BER-encoded
1069format (very efficient). 1345format (very efficient).
1070 1346
1071 $handle->push_read (packstring => "w", sub { 1347 $handle->push_read (packstring => "w", sub {
1101 } 1377 }
1102}; 1378};
1103 1379
1104=item json => $cb->($handle, $hash_or_arrayref) 1380=item json => $cb->($handle, $hash_or_arrayref)
1105 1381
1106Reads a JSON object or array, decodes it and passes it to the callback. 1382Reads a JSON object or array, decodes it and passes it to the
1383callback. When a parse error occurs, an C<EBADMSG> error will be raised.
1107 1384
1108If a C<json> object was passed to the constructor, then that will be used 1385If a C<json> object was passed to the constructor, then that will be used
1109for the final decode, otherwise it will create a JSON coder expecting UTF-8. 1386for the final decode, otherwise it will create a JSON coder expecting UTF-8.
1110 1387
1111This read type uses the incremental parser available with JSON version 1388This read type uses the incremental parser available with JSON version
1120=cut 1397=cut
1121 1398
1122register_read_type json => sub { 1399register_read_type json => sub {
1123 my ($self, $cb) = @_; 1400 my ($self, $cb) = @_;
1124 1401
1125 require JSON; 1402 my $json = $self->{json} ||=
1403 eval { require JSON::XS; JSON::XS->new->utf8 }
1404 || do { require JSON; JSON->new->utf8 };
1126 1405
1127 my $data; 1406 my $data;
1128 my $rbuf = \$self->{rbuf}; 1407 my $rbuf = \$self->{rbuf};
1129 1408
1130 my $json = $self->{json} ||= JSON->new->utf8;
1131
1132 sub { 1409 sub {
1133 my $ref = $json->incr_parse ($self->{rbuf}); 1410 my $ref = eval { $json->incr_parse ($self->{rbuf}) };
1134 1411
1135 if ($ref) { 1412 if ($ref) {
1136 $self->{rbuf} = $json->incr_text; 1413 $self->{rbuf} = $json->incr_text;
1137 $json->incr_text = ""; 1414 $json->incr_text = "";
1138 $cb->($self, $ref); 1415 $cb->($self, $ref);
1139 1416
1140 1 1417 1
1418 } elsif ($@) {
1419 # error case
1420 $json->incr_skip;
1421
1422 $self->{rbuf} = $json->incr_text;
1423 $json->incr_text = "";
1424
1425 $self->_error (Errno::EBADMSG);
1426
1427 ()
1141 } else { 1428 } else {
1142 $self->{rbuf} = ""; 1429 $self->{rbuf} = "";
1430
1143 () 1431 ()
1144 } 1432 }
1145 } 1433 }
1146}; 1434};
1147 1435
1179 # read remaining chunk 1467 # read remaining chunk
1180 $_[0]->unshift_read (chunk => $len, sub { 1468 $_[0]->unshift_read (chunk => $len, sub {
1181 if (my $ref = eval { Storable::thaw ($_[1]) }) { 1469 if (my $ref = eval { Storable::thaw ($_[1]) }) {
1182 $cb->($_[0], $ref); 1470 $cb->($_[0], $ref);
1183 } else { 1471 } else {
1184 $self->_error (&Errno::EBADMSG); 1472 $self->_error (Errno::EBADMSG);
1185 } 1473 }
1186 }); 1474 });
1187 } 1475 }
1188 1476
1189 1 1477 1
1224Note that AnyEvent::Handle will automatically C<start_read> for you when 1512Note that AnyEvent::Handle will automatically C<start_read> for you when
1225you change the C<on_read> callback or push/unshift a read callback, and it 1513you change the C<on_read> callback or push/unshift a read callback, and it
1226will automatically C<stop_read> for you when neither C<on_read> is set nor 1514will automatically C<stop_read> for you when neither C<on_read> is set nor
1227there are any read requests in the queue. 1515there are any read requests in the queue.
1228 1516
1517These methods will have no effect when in TLS mode (as TLS doesn't support
1518half-duplex connections).
1519
1229=cut 1520=cut
1230 1521
1231sub stop_read { 1522sub stop_read {
1232 my ($self) = @_; 1523 my ($self) = @_;
1233 1524
1234 delete $self->{_rw}; 1525 delete $self->{_rw} unless $self->{tls};
1235} 1526}
1236 1527
1237sub start_read { 1528sub start_read {
1238 my ($self) = @_; 1529 my ($self) = @_;
1239 1530
1240 unless ($self->{_rw} || $self->{_eof}) { 1531 unless ($self->{_rw} || $self->{_eof}) {
1241 Scalar::Util::weaken $self; 1532 Scalar::Util::weaken $self;
1242 1533
1243 $self->{_rw} = AnyEvent->io (fh => $self->{fh}, poll => "r", cb => sub { 1534 $self->{_rw} = AnyEvent->io (fh => $self->{fh}, poll => "r", cb => sub {
1244 my $rbuf = $self->{filter_r} ? \my $buf : \$self->{rbuf}; 1535 my $rbuf = \($self->{tls} ? my $buf : $self->{rbuf});
1245 my $len = sysread $self->{fh}, $$rbuf, $self->{read_size} || 8192, length $$rbuf; 1536 my $len = sysread $self->{fh}, $$rbuf, $self->{read_size} || 8192, length $$rbuf;
1246 1537
1247 if ($len > 0) { 1538 if ($len > 0) {
1248 $self->{_activity} = AnyEvent->now; 1539 $self->{_activity} = AnyEvent->now;
1249 1540
1250 $self->{filter_r} 1541 if ($self->{tls}) {
1251 ? $self->{filter_r}($self, $rbuf) 1542 Net::SSLeay::BIO_write ($self->{_rbio}, $$rbuf);
1252 : $self->{_in_drain} || $self->_drain_rbuf; 1543
1544 &_dotls ($self);
1545 } else {
1546 $self->_drain_rbuf;
1547 }
1253 1548
1254 } elsif (defined $len) { 1549 } elsif (defined $len) {
1255 delete $self->{_rw}; 1550 delete $self->{_rw};
1256 $self->{_eof} = 1; 1551 $self->{_eof} = 1;
1257 $self->_drain_rbuf unless $self->{_in_drain}; 1552 $self->_drain_rbuf;
1258 1553
1259 } elsif ($! != EAGAIN && $! != EINTR && $! != WSAEWOULDBLOCK) { 1554 } elsif ($! != EAGAIN && $! != EINTR && $! != WSAEWOULDBLOCK) {
1260 return $self->_error ($!, 1); 1555 return $self->_error ($!, 1);
1261 } 1556 }
1262 }); 1557 });
1263 } 1558 }
1264} 1559}
1265 1560
1561our $ERROR_SYSCALL;
1562our $ERROR_WANT_READ;
1563
1564sub _tls_error {
1565 my ($self, $err) = @_;
1566
1567 return $self->_error ($!, 1)
1568 if $err == Net::SSLeay::ERROR_SYSCALL ();
1569
1570 my $err =Net::SSLeay::ERR_error_string (Net::SSLeay::ERR_get_error ());
1571
1572 # reduce error string to look less scary
1573 $err =~ s/^error:[0-9a-fA-F]{8}:[^:]+:([^:]+):/\L$1: /;
1574
1575 if ($self->{_on_starttls}) {
1576 (delete $self->{_on_starttls})->($self, undef, $err);
1577 &_freetls;
1578 } else {
1579 &_freetls;
1580 $self->_error (Errno::EPROTO, 1, $err);
1581 }
1582}
1583
1584# poll the write BIO and send the data if applicable
1585# also decode read data if possible
1586# this is basiclaly our TLS state machine
1587# more efficient implementations are possible with openssl,
1588# but not with the buggy and incomplete Net::SSLeay.
1266sub _dotls { 1589sub _dotls {
1267 my ($self) = @_; 1590 my ($self) = @_;
1268 1591
1269 my $buf; 1592 my $tmp;
1270 1593
1271 if (length $self->{_tls_wbuf}) { 1594 if (length $self->{_tls_wbuf}) {
1272 while ((my $len = Net::SSLeay::write ($self->{tls}, $self->{_tls_wbuf})) > 0) { 1595 while (($tmp = Net::SSLeay::write ($self->{tls}, $self->{_tls_wbuf})) > 0) {
1273 substr $self->{_tls_wbuf}, 0, $len, ""; 1596 substr $self->{_tls_wbuf}, 0, $tmp, "";
1274 } 1597 }
1275 }
1276 1598
1599 $tmp = Net::SSLeay::get_error ($self->{tls}, $tmp);
1600 return $self->_tls_error ($tmp)
1601 if $tmp != $ERROR_WANT_READ
1602 && ($tmp != $ERROR_SYSCALL || $!);
1603 }
1604
1605 while (defined ($tmp = Net::SSLeay::read ($self->{tls}))) {
1606 unless (length $tmp) {
1607 $self->{_on_starttls}
1608 and (delete $self->{_on_starttls})->($self, undef, "EOF during handshake"); # ???
1609 &_freetls;
1610
1611 if ($self->{on_stoptls}) {
1612 $self->{on_stoptls}($self);
1613 return;
1614 } else {
1615 # let's treat SSL-eof as we treat normal EOF
1616 delete $self->{_rw};
1617 $self->{_eof} = 1;
1618 }
1619 }
1620
1621 $self->{_tls_rbuf} .= $tmp;
1622 $self->_drain_rbuf;
1623 $self->{tls} or return; # tls session might have gone away in callback
1624 }
1625
1626 $tmp = Net::SSLeay::get_error ($self->{tls}, -1);
1627 return $self->_tls_error ($tmp)
1628 if $tmp != $ERROR_WANT_READ
1629 && ($tmp != $ERROR_SYSCALL || $!);
1630
1277 if (length ($buf = Net::SSLeay::BIO_read ($self->{_wbio}))) { 1631 while (length ($tmp = Net::SSLeay::BIO_read ($self->{_wbio}))) {
1278 $self->{wbuf} .= $buf; 1632 $self->{wbuf} .= $tmp;
1279 $self->_drain_wbuf; 1633 $self->_drain_wbuf;
1280 } 1634 }
1281 1635
1282 while (defined ($buf = Net::SSLeay::read ($self->{tls}))) { 1636 $self->{_on_starttls}
1283 if (length $buf) { 1637 and Net::SSLeay::state ($self->{tls}) == Net::SSLeay::ST_OK ()
1284 $self->{rbuf} .= $buf; 1638 and (delete $self->{_on_starttls})->($self, 1, "TLS/SSL connection established");
1285 $self->_drain_rbuf unless $self->{_in_drain};
1286 } else {
1287 # let's treat SSL-eof as we treat normal EOF
1288 $self->{_eof} = 1;
1289 $self->_shutdown;
1290 return;
1291 }
1292 }
1293
1294 my $err = Net::SSLeay::get_error ($self->{tls}, -1);
1295
1296 if ($err!= Net::SSLeay::ERROR_WANT_READ ()) {
1297 if ($err == Net::SSLeay::ERROR_SYSCALL ()) {
1298 return $self->_error ($!, 1);
1299 } elsif ($err == Net::SSLeay::ERROR_SSL ()) {
1300 return $self->_error (&Errno::EIO, 1);
1301 }
1302
1303 # all others are fine for our purposes
1304 }
1305} 1639}
1306 1640
1307=item $handle->starttls ($tls[, $tls_ctx]) 1641=item $handle->starttls ($tls[, $tls_ctx])
1308 1642
1309Instead of starting TLS negotiation immediately when the AnyEvent::Handle 1643Instead of starting TLS negotiation immediately when the AnyEvent::Handle
1310object is created, you can also do that at a later time by calling 1644object is created, you can also do that at a later time by calling
1311C<starttls>. 1645C<starttls>.
1312 1646
1647Starting TLS is currently an asynchronous operation - when you push some
1648write data and then call C<< ->starttls >> then TLS negotiation will start
1649immediately, after which the queued write data is then sent.
1650
1313The first argument is the same as the C<tls> constructor argument (either 1651The first argument is the same as the C<tls> constructor argument (either
1314C<"connect">, C<"accept"> or an existing Net::SSLeay object). 1652C<"connect">, C<"accept"> or an existing Net::SSLeay object).
1315 1653
1316The second argument is the optional C<Net::SSLeay::CTX> object that is 1654The second argument is the optional C<AnyEvent::TLS> object that is used
1317used when AnyEvent::Handle has to create its own TLS connection object. 1655when AnyEvent::Handle has to create its own TLS connection object, or
1656a hash reference with C<< key => value >> pairs that will be used to
1657construct a new context.
1318 1658
1319The TLS connection object will end up in C<< $handle->{tls} >> after this 1659The TLS connection object will end up in C<< $handle->{tls} >>, the TLS
1320call and can be used or changed to your liking. Note that the handshake 1660context in C<< $handle->{tls_ctx} >> after this call and can be used or
1321might have already started when this function returns. 1661changed to your liking. Note that the handshake might have already started
1662when this function returns.
1322 1663
1664Due to bugs in OpenSSL, it might or might not be possible to do multiple
1665handshakes on the same stream. Best do not attempt to use the stream after
1666stopping TLS.
1667
1323=cut 1668=cut
1669
1670our %TLS_CACHE; #TODO not yet documented, should we?
1324 1671
1325sub starttls { 1672sub starttls {
1326 my ($self, $ssl, $ctx) = @_; 1673 my ($self, $tls, $ctx) = @_;
1327 1674
1328 $self->stoptls; 1675 Carp::croak "It is an error to call starttls on an AnyEvent::Handle object while TLS is already active, caught"
1676 if $self->{tls};
1329 1677
1330 if ($ssl eq "accept") { 1678 $self->{tls} = $tls;
1331 $ssl = Net::SSLeay::new ($ctx || TLS_CTX ()); 1679 $self->{tls_ctx} = $ctx if @_ > 2;
1332 Net::SSLeay::set_accept_state ($ssl); 1680
1333 } elsif ($ssl eq "connect") { 1681 return unless $self->{fh};
1334 $ssl = Net::SSLeay::new ($ctx || TLS_CTX ()); 1682
1335 Net::SSLeay::set_connect_state ($ssl); 1683 require Net::SSLeay;
1684
1685 $ERROR_SYSCALL = Net::SSLeay::ERROR_SYSCALL ();
1686 $ERROR_WANT_READ = Net::SSLeay::ERROR_WANT_READ ();
1687
1688 $tls = $self->{tls};
1689 $ctx = $self->{tls_ctx};
1690
1691 local $Carp::CarpLevel = 1; # skip ourselves when creating a new context or session
1692
1693 if ("HASH" eq ref $ctx) {
1694 require AnyEvent::TLS;
1695
1696 if ($ctx->{cache}) {
1697 my $key = $ctx+0;
1698 $ctx = $TLS_CACHE{$key} ||= new AnyEvent::TLS %$ctx;
1699 } else {
1700 $ctx = new AnyEvent::TLS %$ctx;
1701 }
1702 }
1336 } 1703
1337 1704 $self->{tls_ctx} = $ctx || TLS_CTX ();
1338 $self->{tls} = $ssl; 1705 $self->{tls} = $tls = $self->{tls_ctx}->_get_session ($tls, $self, $self->{peername});
1339 1706
1340 # basically, this is deep magic (because SSL_read should have the same issues) 1707 # basically, this is deep magic (because SSL_read should have the same issues)
1341 # but the openssl maintainers basically said: "trust us, it just works". 1708 # but the openssl maintainers basically said: "trust us, it just works".
1342 # (unfortunately, we have to hardcode constants because the abysmally misdesigned 1709 # (unfortunately, we have to hardcode constants because the abysmally misdesigned
1343 # and mismaintained ssleay-module doesn't even offer them). 1710 # and mismaintained ssleay-module doesn't even offer them).
1344 # http://www.mail-archive.com/openssl-dev@openssl.org/msg22420.html 1711 # http://www.mail-archive.com/openssl-dev@openssl.org/msg22420.html
1712 #
1713 # in short: this is a mess.
1714 #
1715 # note that we do not try to keep the length constant between writes as we are required to do.
1716 # we assume that most (but not all) of this insanity only applies to non-blocking cases,
1717 # and we drive openssl fully in blocking mode here. Or maybe we don't - openssl seems to
1718 # have identity issues in that area.
1345 Net::SSLeay::CTX_set_mode ($self->{tls}, 1719# Net::SSLeay::CTX_set_mode ($ssl,
1346 (eval { local $SIG{__DIE__}; Net::SSLeay::MODE_ENABLE_PARTIAL_WRITE () } || 1) 1720# (eval { local $SIG{__DIE__}; Net::SSLeay::MODE_ENABLE_PARTIAL_WRITE () } || 1)
1347 | (eval { local $SIG{__DIE__}; Net::SSLeay::MODE_ACCEPT_MOVING_WRITE_BUFFER () } || 2)); 1721# | (eval { local $SIG{__DIE__}; Net::SSLeay::MODE_ACCEPT_MOVING_WRITE_BUFFER () } || 2));
1722 Net::SSLeay::CTX_set_mode ($tls, 1|2);
1348 1723
1349 $self->{_rbio} = Net::SSLeay::BIO_new (Net::SSLeay::BIO_s_mem ()); 1724 $self->{_rbio} = Net::SSLeay::BIO_new (Net::SSLeay::BIO_s_mem ());
1350 $self->{_wbio} = Net::SSLeay::BIO_new (Net::SSLeay::BIO_s_mem ()); 1725 $self->{_wbio} = Net::SSLeay::BIO_new (Net::SSLeay::BIO_s_mem ());
1351 1726
1352 Net::SSLeay::set_bio ($ssl, $self->{_rbio}, $self->{_wbio}); 1727 Net::SSLeay::set_bio ($tls, $self->{_rbio}, $self->{_wbio});
1353 1728
1354 $self->{filter_w} = sub { 1729 $self->{_on_starttls} = sub { $_[0]{on_starttls}(@_) }
1355 $_[0]{_tls_wbuf} .= ${$_[1]}; 1730 if $self->{on_starttls};
1356 &_dotls; 1731
1357 }; 1732 &_dotls; # need to trigger the initial handshake
1358 $self->{filter_r} = sub { 1733 $self->start_read; # make sure we actually do read
1359 Net::SSLeay::BIO_write ($_[0]{_rbio}, ${$_[1]});
1360 &_dotls;
1361 };
1362} 1734}
1363 1735
1364=item $handle->stoptls 1736=item $handle->stoptls
1365 1737
1366Destroys the SSL connection, if any. Partial read or write data will be 1738Shuts down the SSL connection - this makes a proper EOF handshake by
1367lost. 1739sending a close notify to the other side, but since OpenSSL doesn't
1740support non-blocking shut downs, it is not guarenteed that you can re-use
1741the stream afterwards.
1368 1742
1369=cut 1743=cut
1370 1744
1371sub stoptls { 1745sub stoptls {
1372 my ($self) = @_; 1746 my ($self) = @_;
1373 1747
1374 Net::SSLeay::free (delete $self->{tls}) if $self->{tls}; 1748 if ($self->{tls}) {
1749 Net::SSLeay::shutdown ($self->{tls});
1375 1750
1376 delete $self->{_rbio}; 1751 &_dotls;
1377 delete $self->{_wbio}; 1752
1378 delete $self->{_tls_wbuf}; 1753# # we don't give a shit. no, we do, but we can't. no...#d#
1379 delete $self->{filter_r}; 1754# # we, we... have to use openssl :/#d#
1380 delete $self->{filter_w}; 1755# &_freetls;#d#
1756 }
1757}
1758
1759sub _freetls {
1760 my ($self) = @_;
1761
1762 return unless $self->{tls};
1763
1764 $self->{tls_ctx}->_put_session (delete $self->{tls})
1765 if ref $self->{tls};
1766
1767 delete @$self{qw(_rbio _wbio _tls_wbuf _on_starttls)};
1381} 1768}
1382 1769
1383sub DESTROY { 1770sub DESTROY {
1384 my $self = shift; 1771 my ($self) = @_;
1385 1772
1386 $self->stoptls; 1773 &_freetls;
1387 1774
1388 my $linger = exists $self->{linger} ? $self->{linger} : 3600; 1775 my $linger = exists $self->{linger} ? $self->{linger} : 3600;
1389 1776
1390 if ($linger && length $self->{wbuf}) { 1777 if ($linger && length $self->{wbuf} && $self->{fh}) {
1391 my $fh = delete $self->{fh}; 1778 my $fh = delete $self->{fh};
1392 my $wbuf = delete $self->{wbuf}; 1779 my $wbuf = delete $self->{wbuf};
1393 1780
1394 my @linger; 1781 my @linger;
1395 1782
1406 @linger = (); 1793 @linger = ();
1407 }); 1794 });
1408 } 1795 }
1409} 1796}
1410 1797
1798=item $handle->destroy
1799
1800Shuts down the handle object as much as possible - this call ensures that
1801no further callbacks will be invoked and as many resources as possible
1802will be freed. Any method you will call on the handle object after
1803destroying it in this way will be silently ignored (and it will return the
1804empty list).
1805
1806Normally, you can just "forget" any references to an AnyEvent::Handle
1807object and it will simply shut down. This works in fatal error and EOF
1808callbacks, as well as code outside. It does I<NOT> work in a read or write
1809callback, so when you want to destroy the AnyEvent::Handle object from
1810within such an callback. You I<MUST> call C<< ->destroy >> explicitly in
1811that case.
1812
1813Destroying the handle object in this way has the advantage that callbacks
1814will be removed as well, so if those are the only reference holders (as
1815is common), then one doesn't need to do anything special to break any
1816reference cycles.
1817
1818The handle might still linger in the background and write out remaining
1819data, as specified by the C<linger> option, however.
1820
1821=cut
1822
1823sub destroy {
1824 my ($self) = @_;
1825
1826 $self->DESTROY;
1827 %$self = ();
1828 bless $self, "AnyEvent::Handle::destroyed";
1829}
1830
1831sub AnyEvent::Handle::destroyed::AUTOLOAD {
1832 #nop
1833}
1834
1411=item AnyEvent::Handle::TLS_CTX 1835=item AnyEvent::Handle::TLS_CTX
1412 1836
1413This function creates and returns the Net::SSLeay::CTX object used by 1837This function creates and returns the AnyEvent::TLS object used by default
1414default for TLS mode. 1838for TLS mode.
1415 1839
1416The context is created like this: 1840The context is created by calling L<AnyEvent::TLS> without any arguments.
1417
1418 Net::SSLeay::load_error_strings;
1419 Net::SSLeay::SSLeay_add_ssl_algorithms;
1420 Net::SSLeay::randomize;
1421
1422 my $CTX = Net::SSLeay::CTX_new;
1423
1424 Net::SSLeay::CTX_set_options $CTX, Net::SSLeay::OP_ALL
1425 1841
1426=cut 1842=cut
1427 1843
1428our $TLS_CTX; 1844our $TLS_CTX;
1429 1845
1430sub TLS_CTX() { 1846sub TLS_CTX() {
1431 $TLS_CTX || do { 1847 $TLS_CTX ||= do {
1432 require Net::SSLeay; 1848 require AnyEvent::TLS;
1433 1849
1434 Net::SSLeay::load_error_strings (); 1850 new AnyEvent::TLS
1435 Net::SSLeay::SSLeay_add_ssl_algorithms ();
1436 Net::SSLeay::randomize ();
1437
1438 $TLS_CTX = Net::SSLeay::CTX_new ();
1439
1440 Net::SSLeay::CTX_set_options ($TLS_CTX, Net::SSLeay::OP_ALL ());
1441
1442 $TLS_CTX
1443 } 1851 }
1444} 1852}
1445 1853
1446=back 1854=back
1855
1856
1857=head1 NONFREQUENTLY ASKED QUESTIONS
1858
1859=over 4
1860
1861=item I C<undef> the AnyEvent::Handle reference inside my callback and
1862still get further invocations!
1863
1864That's because AnyEvent::Handle keeps a reference to itself when handling
1865read or write callbacks.
1866
1867It is only safe to "forget" the reference inside EOF or error callbacks,
1868from within all other callbacks, you need to explicitly call the C<<
1869->destroy >> method.
1870
1871=item I get different callback invocations in TLS mode/Why can't I pause
1872reading?
1873
1874Unlike, say, TCP, TLS connections do not consist of two independent
1875communication channels, one for each direction. Or put differently. The
1876read and write directions are not independent of each other: you cannot
1877write data unless you are also prepared to read, and vice versa.
1878
1879This can mean than, in TLS mode, you might get C<on_error> or C<on_eof>
1880callback invocations when you are not expecting any read data - the reason
1881is that AnyEvent::Handle always reads in TLS mode.
1882
1883During the connection, you have to make sure that you always have a
1884non-empty read-queue, or an C<on_read> watcher. At the end of the
1885connection (or when you no longer want to use it) you can call the
1886C<destroy> method.
1887
1888=item How do I read data until the other side closes the connection?
1889
1890If you just want to read your data into a perl scalar, the easiest way
1891to achieve this is by setting an C<on_read> callback that does nothing,
1892clearing the C<on_eof> callback and in the C<on_error> callback, the data
1893will be in C<$_[0]{rbuf}>:
1894
1895 $handle->on_read (sub { });
1896 $handle->on_eof (undef);
1897 $handle->on_error (sub {
1898 my $data = delete $_[0]{rbuf};
1899 });
1900
1901The reason to use C<on_error> is that TCP connections, due to latencies
1902and packets loss, might get closed quite violently with an error, when in
1903fact, all data has been received.
1904
1905It is usually better to use acknowledgements when transferring data,
1906to make sure the other side hasn't just died and you got the data
1907intact. This is also one reason why so many internet protocols have an
1908explicit QUIT command.
1909
1910=item I don't want to destroy the handle too early - how do I wait until
1911all data has been written?
1912
1913After writing your last bits of data, set the C<on_drain> callback
1914and destroy the handle in there - with the default setting of
1915C<low_water_mark> this will be called precisely when all data has been
1916written to the socket:
1917
1918 $handle->push_write (...);
1919 $handle->on_drain (sub {
1920 warn "all data submitted to the kernel\n";
1921 undef $handle;
1922 });
1923
1924If you just want to queue some data and then signal EOF to the other side,
1925consider using C<< ->push_shutdown >> instead.
1926
1927=item I want to contact a TLS/SSL server, I don't care about security.
1928
1929If your TLS server is a pure TLS server (e.g. HTTPS) that only speaks TLS,
1930simply connect to it and then create the AnyEvent::Handle with the C<tls>
1931parameter:
1932
1933 tcp_connect $host, $port, sub {
1934 my ($fh) = @_;
1935
1936 my $handle = new AnyEvent::Handle
1937 fh => $fh,
1938 tls => "connect",
1939 on_error => sub { ... };
1940
1941 $handle->push_write (...);
1942 };
1943
1944=item I want to contact a TLS/SSL server, I do care about security.
1945
1946Then you should additionally enable certificate verification, including
1947peername verification, if the protocol you use supports it (see
1948L<AnyEvent::TLS>, C<verify_peername>).
1949
1950E.g. for HTTPS:
1951
1952 tcp_connect $host, $port, sub {
1953 my ($fh) = @_;
1954
1955 my $handle = new AnyEvent::Handle
1956 fh => $fh,
1957 peername => $host,
1958 tls => "connect",
1959 tls_ctx => { verify => 1, verify_peername => "https" },
1960 ...
1961
1962Note that you must specify the hostname you connected to (or whatever
1963"peername" the protocol needs) as the C<peername> argument, otherwise no
1964peername verification will be done.
1965
1966The above will use the system-dependent default set of trusted CA
1967certificates. If you want to check against a specific CA, add the
1968C<ca_file> (or C<ca_cert>) arguments to C<tls_ctx>:
1969
1970 tls_ctx => {
1971 verify => 1,
1972 verify_peername => "https",
1973 ca_file => "my-ca-cert.pem",
1974 },
1975
1976=item I want to create a TLS/SSL server, how do I do that?
1977
1978Well, you first need to get a server certificate and key. You have
1979three options: a) ask a CA (buy one, use cacert.org etc.) b) create a
1980self-signed certificate (cheap. check the search engine of your choice,
1981there are many tutorials on the net) or c) make your own CA (tinyca2 is a
1982nice program for that purpose).
1983
1984Then create a file with your private key (in PEM format, see
1985L<AnyEvent::TLS>), followed by the certificate (also in PEM format). The
1986file should then look like this:
1987
1988 -----BEGIN RSA PRIVATE KEY-----
1989 ...header data
1990 ... lots of base64'y-stuff
1991 -----END RSA PRIVATE KEY-----
1992
1993 -----BEGIN CERTIFICATE-----
1994 ... lots of base64'y-stuff
1995 -----END CERTIFICATE-----
1996
1997The important bits are the "PRIVATE KEY" and "CERTIFICATE" parts. Then
1998specify this file as C<cert_file>:
1999
2000 tcp_server undef, $port, sub {
2001 my ($fh) = @_;
2002
2003 my $handle = new AnyEvent::Handle
2004 fh => $fh,
2005 tls => "accept",
2006 tls_ctx => { cert_file => "my-server-keycert.pem" },
2007 ...
2008
2009When you have intermediate CA certificates that your clients might not
2010know about, just append them to the C<cert_file>.
2011
2012=back
2013
1447 2014
1448=head1 SUBCLASSING AnyEvent::Handle 2015=head1 SUBCLASSING AnyEvent::Handle
1449 2016
1450In many cases, you might want to subclass AnyEvent::Handle. 2017In many cases, you might want to subclass AnyEvent::Handle.
1451 2018

Diff Legend

Removed lines
+ Added lines
< Changed lines
> Changed lines