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.71 by root, Thu Jul 3 02:03:33 2008 UTC vs.
Revision 1.150 by root, Thu Jul 16 04:16:25 2009 UTC

1package AnyEvent::Handle; 1package AnyEvent::Handle;
2 2
3no warnings; 3no warnings;
4use strict; 4use strict qw(subs vars);
5 5
6use AnyEvent (); 6use AnyEvent ();
7use AnyEvent::Util qw(WSAEWOULDBLOCK); 7use AnyEvent::Util qw(WSAEWOULDBLOCK);
8use Scalar::Util (); 8use Scalar::Util ();
9use Carp (); 9use Carp ();
14 14
15AnyEvent::Handle - non-blocking I/O on file handles via AnyEvent 15AnyEvent::Handle - non-blocking I/O on file handles via AnyEvent
16 16
17=cut 17=cut
18 18
19our $VERSION = 4.160; 19our $VERSION = 4.82;
20 20
21=head1 SYNOPSIS 21=head1 SYNOPSIS
22 22
23 use AnyEvent; 23 use AnyEvent;
24 use AnyEvent::Handle; 24 use AnyEvent::Handle;
25 25
26 my $cv = AnyEvent->condvar; 26 my $cv = AnyEvent->condvar;
27 27
28 my $handle = 28 my $hdl; $hdl = new AnyEvent::Handle
29 AnyEvent::Handle->new (
30 fh => \*STDIN, 29 fh => \*STDIN,
31 on_eof => sub { 30 on_error => sub {
32 $cv->broadcast; 31 warn "got error $_[2]\n";
33 }, 32 $cv->send;
34 ); 33 );
35 34
36 # send some request line 35 # send some request line
37 $handle->push_write ("getinfo\015\012"); 36 $hdl->push_write ("getinfo\015\012");
38 37
39 # read the response line 38 # read the response line
40 $handle->push_read (line => sub { 39 $hdl->push_read (line => sub {
41 my ($handle, $line) = @_; 40 my ($hdl, $line) = @_;
42 warn "read line <$line>\n"; 41 warn "got line <$line>\n";
43 $cv->send; 42 $cv->send;
44 }); 43 });
45 44
46 $cv->recv; 45 $cv->recv;
47 46
49 48
50This module is a helper module to make it easier to do event-based I/O on 49This 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 50filehandles. For utility functions for doing non-blocking connects and accepts
52on sockets see L<AnyEvent::Util>. 51on sockets see L<AnyEvent::Util>.
53 52
53The L<AnyEvent::Intro> tutorial contains some well-documented
54AnyEvent::Handle examples.
55
54In the following, when the documentation refers to of "bytes" then this 56In the following, when the documentation refers to of "bytes" then this
55means characters. As sysread and syswrite are used for all I/O, their 57means characters. As sysread and syswrite are used for all I/O, their
56treatment of characters applies to this module as well. 58treatment of characters applies to this module as well.
57 59
58All callbacks will be invoked with the handle object as their first 60All callbacks will be invoked with the handle object as their first
60 62
61=head1 METHODS 63=head1 METHODS
62 64
63=over 4 65=over 4
64 66
65=item B<new (%args)> 67=item $handle = B<new> AnyEvent::TLS fh => $filehandle, key => value...
66 68
67The constructor supports these arguments (all as key => value pairs). 69The constructor supports these arguments (all as C<< key => value >> pairs).
68 70
69=over 4 71=over 4
70 72
71=item fh => $filehandle [MANDATORY] 73=item fh => $filehandle [MANDATORY]
72 74
73The filehandle this L<AnyEvent::Handle> object will operate on. 75The filehandle this L<AnyEvent::Handle> object will operate on.
74 76
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
78=item on_eof => $cb->($handle) 81=item on_eof => $cb->($handle)
79 82
80Set the callback to be called when an end-of-file condition is detcted, 83Set the callback to be called when an end-of-file condition is detected,
81i.e. in the case of a socket, when the other side has closed the 84i.e. in the case of a socket, when the other side has closed the
82connection cleanly. 85connection cleanly, and there are no outstanding read requests in the
86queue (if there are read requests, then an EOF counts as an unexpected
87connection close and will be flagged as an error).
83 88
84While not mandatory, it is highly recommended to set an eof callback, 89For sockets, this just means that the other side has stopped sending data,
85otherwise you might end up with a closed socket while you are still 90you can still try to write data, and, in fact, one can return from the EOF
86waiting for data. 91callback and continue writing data, as only the read part has been shut
92down.
87 93
94If an EOF condition has been detected but no C<on_eof> callback has been
95set, then a fatal error will be raised with C<$!> set to <0>.
96
88=item on_error => $cb->($handle, $fatal) 97=item on_error => $cb->($handle, $fatal, $message)
89 98
90This is the error callback, which is called when, well, some error 99This is the error callback, which is called when, well, some error
91occured, such as not being able to resolve the hostname, failure to 100occured, such as not being able to resolve the hostname, failure to
92connect or a read error. 101connect or a read error.
93 102
94Some errors are fatal (which is indicated by C<$fatal> being true). On 103Some 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 104fatal errors the handle object will be destroyed (by a call to C<< ->
105destroy >>) after invoking the error callback (which means you are free to
106examine the handle object). Examples of fatal errors are an EOF condition
107with active (but unsatisifable) read watchers (C<EPIPE>) or I/O errors.
108
109AnyEvent::Handle tries to find an appropriate error code for you to check
110against, but in some cases (TLS errors), this does not work well. It is
111recommended to always output the C<$message> argument in human-readable
112error messages (it's usually the same as C<"$!">).
113
96usable. Non-fatal errors can be retried by simply returning, but it is 114Non-fatal errors can be retried by simply returning, but it is recommended
97recommended to simply ignore this parameter and instead abondon the handle 115to simply ignore this parameter and instead abondon the handle object
98object when this callback is invoked. 116when this callback is invoked. Examples of non-fatal errors are timeouts
117C<ETIMEDOUT>) or badly-formatted data (C<EBADMSG>).
99 118
100On callback entrance, the value of C<$!> contains the operating system 119On callback entrance, the value of C<$!> contains the operating system
101error (or C<ENOSPC>, C<EPIPE>, C<ETIMEDOUT> or C<EBADMSG>). 120error code (or C<ENOSPC>, C<EPIPE>, C<ETIMEDOUT>, C<EBADMSG> or
121C<EPROTO>).
102 122
103While not mandatory, it is I<highly> recommended to set this callback, as 123While not mandatory, it is I<highly> recommended to set this callback, as
104you will not be notified of errors otherwise. The default simply calls 124you will not be notified of errors otherwise. The default simply calls
105C<croak>. 125C<croak>.
106 126
110and no read request is in the queue (unlike read queue callbacks, this 130and 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 131callback will only be called when at least one octet of data is in the
112read buffer). 132read buffer).
113 133
114To access (and remove data from) the read buffer, use the C<< ->rbuf >> 134To access (and remove data from) the read buffer, use the C<< ->rbuf >>
115method or access the C<$handle->{rbuf}> member directly. 135method or access the C<< $handle->{rbuf} >> member directly. Note that you
136must not enlarge or modify the read buffer, you can only remove data at
137the beginning from it.
116 138
117When an EOF condition is detected then AnyEvent::Handle will first try to 139When 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 140feed 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 141calling the C<on_eof> callback. If no progress can be made, then a fatal
120error will be raised (with C<$!> set to C<EPIPE>). 142error will be raised (with C<$!> set to C<EPIPE>).
143
144Note that, unlike requests in the read queue, an C<on_read> callback
145doesn't mean you I<require> some data: if there is an EOF and there
146are outstanding read requests then an error will be flagged. With an
147C<on_read> callback, the C<on_eof> callback will be invoked.
121 148
122=item on_drain => $cb->($handle) 149=item on_drain => $cb->($handle)
123 150
124This sets the callback that is called when the write buffer becomes empty 151This 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). 152(or when the callback is set and the buffer is empty already).
135=item timeout => $fractional_seconds 162=item timeout => $fractional_seconds
136 163
137If non-zero, then this enables an "inactivity" timeout: whenever this many 164If non-zero, then this enables an "inactivity" timeout: whenever this many
138seconds pass without a successful read or write on the underlying file 165seconds 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 166handle, the C<on_timeout> callback will be invoked (and if that one is
140missing, an C<ETIMEDOUT> error will be raised). 167missing, a non-fatal C<ETIMEDOUT> error will be raised).
141 168
142Note that timeout processing is also active when you currently do not have 169Note 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 170any outstanding read or write requests: If you plan to keep the connection
144idle then you should disable the timout temporarily or ignore the timeout 171idle then you should disable the timout temporarily or ignore the timeout
145in the C<on_timeout> callback. 172in the C<on_timeout> callback, in which case AnyEvent::Handle will simply
173restart the timeout.
146 174
147Zero (the default) disables this timeout. 175Zero (the default) disables this timeout.
148 176
149=item on_timeout => $cb->($handle) 177=item on_timeout => $cb->($handle)
150 178
154 182
155=item rbuf_max => <bytes> 183=item rbuf_max => <bytes>
156 184
157If defined, then a fatal error will be raised (with C<$!> set to C<ENOSPC>) 185If 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 186when the read buffer ever (strictly) exceeds this size. This is useful to
159avoid denial-of-service attacks. 187avoid some forms of denial-of-service attacks.
160 188
161For example, a server accepting connections from untrusted sources should 189For example, a server accepting connections from untrusted sources should
162be configured to accept only so-and-so much data that it cannot act on 190be 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 191(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 192amount of data without a callback ever being called as long as the line
165isn't finished). 193isn't finished).
166 194
167=item autocork => <boolean> 195=item autocork => <boolean>
168 196
169When disabled (the default), then C<push_write> will try to immediately 197When disabled (the default), then C<push_write> will try to immediately
170write the data to the handle if possible. This avoids having to register 198write 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 199a write watcher and wait for the next event loop iteration, but can
172inefficient if you write multiple small chunks (this disadvantage is 200be inefficient if you write multiple small chunks (on the wire, this
173usually avoided by your kernel's nagle algorithm, see C<low_delay>). 201disadvantage is usually avoided by your kernel's nagle algorithm, see
202C<no_delay>, but this option can save costly syscalls).
174 203
175When enabled, then writes will always be queued till the next event loop 204When enabled, then writes will always be queued till the next event loop
176iteration. This is efficient when you do many small writes per iteration, 205iteration. This is efficient when you do many small writes per iteration,
177but less efficient when you do a single write only. 206but less efficient when you do a single write only per iteration (or when
207the write buffer often is full). It also increases write latency.
178 208
179=item no_delay => <boolean> 209=item no_delay => <boolean>
180 210
181When doing small writes on sockets, your operating system kernel might 211When doing small writes on sockets, your operating system kernel might
182wait a bit for more data before actually sending it out. This is called 212wait a bit for more data before actually sending it out. This is called
183the Nagle algorithm, and usually it is beneficial. 213the Nagle algorithm, and usually it is beneficial.
184 214
185In some situations you want as low a delay as possible, which cna be 215In some situations you want as low a delay as possible, which can be
186accomplishd by setting this option to true. 216accomplishd by setting this option to a true value.
187 217
188The default is your opertaing system's default behaviour, this option 218The default is your opertaing system's default behaviour (most likely
189explicitly enables or disables it, if possible. 219enabled), this option explicitly enables or disables it, if possible.
190 220
191=item read_size => <bytes> 221=item read_size => <bytes>
192 222
193The default read block size (the amount of bytes this module will try to read 223The default read block size (the amount of bytes this module will
194during each (loop iteration). Default: C<8192>. 224try to read during each loop iteration, which affects memory
225requirements). Default: C<8192>.
195 226
196=item low_water_mark => <bytes> 227=item low_water_mark => <bytes>
197 228
198Sets the amount of bytes (default: C<0>) that make up an "empty" write 229Sets 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 230buffer: If the write reaches this size or gets even samller it is
200considered empty. 231considered empty.
201 232
233Sometimes it can be beneficial (for performance reasons) to add data to
234the write buffer before it is fully drained, but this is a rare case, as
235the operating system kernel usually buffers data as well, so the default
236is good in almost all cases.
237
202=item linger => <seconds> 238=item linger => <seconds>
203 239
204If non-zero (default: C<3600>), then the destructor of the 240If non-zero (default: C<3600>), then the destructor of the
205AnyEvent::Handle object will check wether there is still outstanding write 241AnyEvent::Handle object will check whether there is still outstanding
206data and will install a watcher that will write out this data. No errors 242write data and will install a watcher that will write this data to the
207will be reported (this mostly matches how the operating system treats 243socket. No errors will be reported (this mostly matches how the operating
208outstanding data at socket close time). 244system treats outstanding data at socket close time).
209 245
210This will not work for partial TLS data that could not yet been 246This will not work for partial TLS data that could not be encoded
211encoded. This data will be lost. 247yet. This data will be lost. Calling the C<stoptls> method in time might
248help.
249
250=item peername => $string
251
252A string used to identify the remote site - usually the DNS hostname
253(I<not> IDN!) used to create the connection, rarely the IP address.
254
255Apart from being useful in error messages, this string is also used in TLS
256peername verification (see C<verify_peername> in L<AnyEvent::TLS>). This
257verification will be skipped when C<peername> is not specified or
258C<undef>.
212 259
213=item tls => "accept" | "connect" | Net::SSLeay::SSL object 260=item tls => "accept" | "connect" | Net::SSLeay::SSL object
214 261
215When this parameter is given, it enables TLS (SSL) mode, that means it 262When this parameter is given, it enables TLS (SSL) mode, that means
216will start making tls handshake and will transparently encrypt/decrypt 263AnyEvent will start a TLS handshake as soon as the conenction has been
217data. 264established and will transparently encrypt/decrypt data afterwards.
265
266All TLS protocol errors will be signalled as C<EPROTO>, with an
267appropriate error message.
218 268
219TLS mode requires Net::SSLeay to be installed (it will be loaded 269TLS mode requires Net::SSLeay to be installed (it will be loaded
220automatically when you try to create a TLS handle). 270automatically when you try to create a TLS handle): this module doesn't
271have a dependency on that module, so if your module requires it, you have
272to add the dependency yourself.
221 273
222For the TLS server side, use C<accept>, and for the TLS client side of a 274Unlike TCP, TLS has a server and client side: for the TLS server side, use
223connection, use C<connect> mode. 275C<accept>, and for the TLS client side of a connection, use C<connect>
276mode.
224 277
225You can also provide your own TLS connection object, but you have 278You can also provide your own TLS connection object, but you have
226to make sure that you call either C<Net::SSLeay::set_connect_state> 279to 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 280or C<Net::SSLeay::set_accept_state> on it before you pass it to
228AnyEvent::Handle. 281AnyEvent::Handle. Also, this module will take ownership of this connection
282object.
229 283
284At some future point, AnyEvent::Handle might switch to another TLS
285implementation, then the option to use your own session object will go
286away.
287
288B<IMPORTANT:> since Net::SSLeay "objects" are really only integers,
289passing in the wrong integer will lead to certain crash. This most often
290happens when one uses a stylish C<< tls => 1 >> and is surprised about the
291segmentation fault.
292
230See the C<starttls> method if you need to start TLs negotiation later. 293See the C<< ->starttls >> method for when need to start TLS negotiation later.
231 294
232=item tls_ctx => $ssl_ctx 295=item tls_ctx => $anyevent_tls
233 296
234Use the given Net::SSLeay::CTX object to create the new TLS connection 297Use the given C<AnyEvent::TLS> object to create the new TLS connection
235(unless a connection object was specified directly). If this parameter is 298(unless a connection object was specified directly). If this parameter is
236missing, then AnyEvent::Handle will use C<AnyEvent::Handle::TLS_CTX>. 299missing, then AnyEvent::Handle will use C<AnyEvent::Handle::TLS_CTX>.
237 300
301Instead of an object, you can also specify a hash reference with C<< key
302=> value >> pairs. Those will be passed to L<AnyEvent::TLS> to create a
303new TLS context object.
304
305=item on_starttls => $cb->($handle, $success[, $error_message])
306
307This callback will be invoked when the TLS/SSL handshake has finished. If
308C<$success> is true, then the TLS handshake succeeded, otherwise it failed
309(C<on_stoptls> will not be called in this case).
310
311The session in C<< $handle->{tls} >> can still be examined in this
312callback, even when the handshake was not successful.
313
314TLS handshake failures will not cause C<on_error> to be invoked when this
315callback is in effect, instead, the error message will be passed to C<on_starttls>.
316
317Without this callback, handshake failures lead to C<on_error> being
318called, as normal.
319
320Note that you cannot call C<starttls> right again in this callback. If you
321need to do that, start an zero-second timer instead whose callback can
322then call C<< ->starttls >> again.
323
324=item on_stoptls => $cb->($handle)
325
326When a SSLv3/TLS shutdown/close notify/EOF is detected and this callback is
327set, then it will be invoked after freeing the TLS session. If it is not,
328then a TLS shutdown condition will be treated like a normal EOF condition
329on the handle.
330
331The session in C<< $handle->{tls} >> can still be examined in this
332callback.
333
334This callback will only be called on TLS shutdowns, not when the
335underlying handle signals EOF.
336
238=item json => JSON or JSON::XS object 337=item json => JSON or JSON::XS object
239 338
240This is the json coder object used by the C<json> read and write types. 339This is the json coder object used by the C<json> read and write types.
241 340
242If you don't supply it, then AnyEvent::Handle will create and use a 341If 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. 342suitable one (on demand), which will write and expect UTF-8 encoded JSON
343texts.
244 344
245Note that you are responsible to depend on the JSON module if you want to 345Note 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. 346use this functionality, as AnyEvent does not have a dependency itself.
247 347
248=item filter_r => $cb
249
250=item filter_w => $cb
251
252These exist, but are undocumented at this time.
253
254=back 348=back
255 349
256=cut 350=cut
257 351
258sub new { 352sub new {
259 my $class = shift; 353 my $class = shift;
260
261 my $self = bless { @_ }, $class; 354 my $self = bless { @_ }, $class;
262 355
263 $self->{fh} or Carp::croak "mandatory argument fh is missing"; 356 $self->{fh} or Carp::croak "mandatory argument fh is missing";
264 357
265 AnyEvent::Util::fh_nonblocking $self->{fh}, 1; 358 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 359
272 $self->{_activity} = AnyEvent->now; 360 $self->{_activity} = AnyEvent->now;
273 $self->_timeout; 361 $self->_timeout;
274 362
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}; 363 $self->no_delay (delete $self->{no_delay}) if exists $self->{no_delay};
364
365 $self->starttls (delete $self->{tls}, delete $self->{tls_ctx})
366 if $self->{tls};
367
368 $self->on_drain (delete $self->{on_drain}) if $self->{on_drain};
277 369
278 $self->start_read 370 $self->start_read
279 if $self->{on_read}; 371 if $self->{on_read};
280 372
281 $self 373 $self->{fh} && $self
282} 374}
283 375
284sub _shutdown { 376#sub _shutdown {
285 my ($self) = @_; 377# my ($self) = @_;
286 378#
287 delete $self->{_tw}; 379# delete @$self{qw(_tw _rw _ww fh wbuf on_read _queue)};
288 delete $self->{_rw}; 380# $self->{_eof} = 1; # tell starttls et. al to stop trying
289 delete $self->{_ww}; 381#
290 delete $self->{fh}; 382# &_freetls;
291 383#}
292 $self->stoptls;
293}
294 384
295sub _error { 385sub _error {
296 my ($self, $errno, $fatal) = @_; 386 my ($self, $errno, $fatal, $message) = @_;
297
298 $self->_shutdown
299 if $fatal;
300 387
301 $! = $errno; 388 $! = $errno;
389 $message ||= "$!";
302 390
303 if ($self->{on_error}) { 391 if ($self->{on_error}) {
304 $self->{on_error}($self, $fatal); 392 $self->{on_error}($self, $fatal, $message);
305 } else { 393 $self->destroy;
394 } elsif ($self->{fh}) {
395 $self->destroy;
306 Carp::croak "AnyEvent::Handle uncaught error: $!"; 396 Carp::croak "AnyEvent::Handle uncaught error: $message";
307 } 397 }
308} 398}
309 399
310=item $fh = $handle->fh 400=item $fh = $handle->fh
311 401
312This method returns the file handle of the L<AnyEvent::Handle> object. 402This method returns the file handle used to create the L<AnyEvent::Handle> object.
313 403
314=cut 404=cut
315 405
316sub fh { $_[0]{fh} } 406sub fh { $_[0]{fh} }
317 407
335 $_[0]{on_eof} = $_[1]; 425 $_[0]{on_eof} = $_[1];
336} 426}
337 427
338=item $handle->on_timeout ($cb) 428=item $handle->on_timeout ($cb)
339 429
340Replace the current C<on_timeout> callback, or disables the callback 430Replace 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 431not the timeout) if C<$cb> = C<undef>. See the C<timeout> constructor
342argument. 432argument and method.
343 433
344=cut 434=cut
345 435
346sub on_timeout { 436sub on_timeout {
347 $_[0]{on_timeout} = $_[1]; 437 $_[0]{on_timeout} = $_[1];
348} 438}
349 439
350=item $handle->autocork ($boolean) 440=item $handle->autocork ($boolean)
351 441
352Enables or disables the current autocork behaviour (see C<autocork> 442Enables or disables the current autocork behaviour (see C<autocork>
353constructor argument). 443constructor argument). Changes will only take effect on the next write.
354 444
355=cut 445=cut
446
447sub autocork {
448 $_[0]{autocork} = $_[1];
449}
356 450
357=item $handle->no_delay ($boolean) 451=item $handle->no_delay ($boolean)
358 452
359Enables or disables the C<no_delay> setting (see constructor argument of 453Enables or disables the C<no_delay> setting (see constructor argument of
360the same name for details). 454the same name for details).
368 local $SIG{__DIE__}; 462 local $SIG{__DIE__};
369 setsockopt $_[0]{fh}, &Socket::IPPROTO_TCP, &Socket::TCP_NODELAY, int $_[1]; 463 setsockopt $_[0]{fh}, &Socket::IPPROTO_TCP, &Socket::TCP_NODELAY, int $_[1];
370 }; 464 };
371} 465}
372 466
467=item $handle->on_starttls ($cb)
468
469Replace the current C<on_starttls> callback (see the C<on_starttls> constructor argument).
470
471=cut
472
473sub on_starttls {
474 $_[0]{on_starttls} = $_[1];
475}
476
477=item $handle->on_stoptls ($cb)
478
479Replace the current C<on_stoptls> callback (see the C<on_stoptls> constructor argument).
480
481=cut
482
483sub on_starttls {
484 $_[0]{on_stoptls} = $_[1];
485}
486
373############################################################################# 487#############################################################################
374 488
375=item $handle->timeout ($seconds) 489=item $handle->timeout ($seconds)
376 490
377Configures (or disables) the inactivity timeout. 491Configures (or disables) the inactivity timeout.
401 $self->{_activity} = $NOW; 515 $self->{_activity} = $NOW;
402 516
403 if ($self->{on_timeout}) { 517 if ($self->{on_timeout}) {
404 $self->{on_timeout}($self); 518 $self->{on_timeout}($self);
405 } else { 519 } else {
406 $self->_error (&Errno::ETIMEDOUT); 520 $self->_error (Errno::ETIMEDOUT);
407 } 521 }
408 522
409 # callback could have changed timeout value, optimise 523 # callback could have changed timeout value, optimise
410 return unless $self->{timeout}; 524 return unless $self->{timeout};
411 525
453 my ($self, $cb) = @_; 567 my ($self, $cb) = @_;
454 568
455 $self->{on_drain} = $cb; 569 $self->{on_drain} = $cb;
456 570
457 $cb->($self) 571 $cb->($self)
458 if $cb && $self->{low_water_mark} >= length $self->{wbuf}; 572 if $cb && $self->{low_water_mark} >= (length $self->{wbuf}) + (length $self->{_tls_wbuf});
459} 573}
460 574
461=item $handle->push_write ($data) 575=item $handle->push_write ($data)
462 576
463Queues the given scalar to be written. You can push as much data as you 577Queues the given scalar to be written. You can push as much data as you
474 Scalar::Util::weaken $self; 588 Scalar::Util::weaken $self;
475 589
476 my $cb = sub { 590 my $cb = sub {
477 my $len = syswrite $self->{fh}, $self->{wbuf}; 591 my $len = syswrite $self->{fh}, $self->{wbuf};
478 592
479 if ($len >= 0) { 593 if (defined $len) {
480 substr $self->{wbuf}, 0, $len, ""; 594 substr $self->{wbuf}, 0, $len, "";
481 595
482 $self->{_activity} = AnyEvent->now; 596 $self->{_activity} = AnyEvent->now;
483 597
484 $self->{on_drain}($self) 598 $self->{on_drain}($self)
485 if $self->{low_water_mark} >= length $self->{wbuf} 599 if $self->{low_water_mark} >= (length $self->{wbuf}) + (length $self->{_tls_wbuf})
486 && $self->{on_drain}; 600 && $self->{on_drain};
487 601
488 delete $self->{_ww} unless length $self->{wbuf}; 602 delete $self->{_ww} unless length $self->{wbuf};
489 } elsif ($! != EAGAIN && $! != EINTR && $! != WSAEWOULDBLOCK) { 603 } elsif ($! != EAGAIN && $! != EINTR && $! != WSAEWOULDBLOCK) {
490 $self->_error ($!, 1); 604 $self->_error ($!, 1);
514 628
515 @_ = ($WH{$type} or Carp::croak "unsupported type passed to AnyEvent::Handle::push_write") 629 @_ = ($WH{$type} or Carp::croak "unsupported type passed to AnyEvent::Handle::push_write")
516 ->($self, @_); 630 ->($self, @_);
517 } 631 }
518 632
519 if ($self->{filter_w}) { 633 if ($self->{tls}) {
520 $self->{filter_w}($self, \$_[0]); 634 $self->{_tls_wbuf} .= $_[0];
635
636 &_dotls ($self);
521 } else { 637 } else {
522 $self->{wbuf} .= $_[0]; 638 $self->{wbuf} .= $_[0];
523 $self->_drain_wbuf; 639 $self->_drain_wbuf;
524 } 640 }
525} 641}
542=cut 658=cut
543 659
544register_write_type netstring => sub { 660register_write_type netstring => sub {
545 my ($self, $string) = @_; 661 my ($self, $string) = @_;
546 662
547 sprintf "%d:%s,", (length $string), $string 663 (length $string) . ":$string,"
548}; 664};
549 665
550=item packstring => $format, $data 666=item packstring => $format, $data
551 667
552An octet string prefixed with an encoded length. The encoding C<$format> 668An octet string prefixed with an encoded length. The encoding C<$format>
617 733
618 pack "w/a*", Storable::nfreeze ($ref) 734 pack "w/a*", Storable::nfreeze ($ref)
619}; 735};
620 736
621=back 737=back
738
739=item $handle->push_shutdown
740
741Sometimes you know you want to close the socket after writing your data
742before it was actually written. One way to do that is to replace your
743C<on_drain> handler by a callback that shuts down the socket (and set
744C<low_water_mark> to C<0>). This method is a shorthand for just that, and
745replaces the C<on_drain> callback with:
746
747 sub { shutdown $_[0]{fh}, 1 } # for push_shutdown
748
749This simply shuts down the write side and signals an EOF condition to the
750the peer.
751
752You can rely on the normal read queue and C<on_eof> handling
753afterwards. This is the cleanest way to close a connection.
754
755=cut
756
757sub push_shutdown {
758 my ($self) = @_;
759
760 delete $self->{low_water_mark};
761 $self->on_drain (sub { shutdown $_[0]{fh}, 1 });
762}
622 763
623=item AnyEvent::Handle::register_write_type type => $coderef->($handle, @args) 764=item AnyEvent::Handle::register_write_type type => $coderef->($handle, @args)
624 765
625This function (not method) lets you add your own types to C<push_write>. 766This 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 767Whenever the given C<type> is used, C<push_write> will invoke the code
726 867
727 if ( 868 if (
728 defined $self->{rbuf_max} 869 defined $self->{rbuf_max}
729 && $self->{rbuf_max} < length $self->{rbuf} 870 && $self->{rbuf_max} < length $self->{rbuf}
730 ) { 871 ) {
731 return $self->_error (&Errno::ENOSPC, 1); 872 $self->_error (Errno::ENOSPC, 1), return;
732 } 873 }
733 874
734 while () { 875 while () {
735 no strict 'refs'; 876 # we need to use a separate tls read buffer, as we must not receive data while
877 # we are draining the buffer, and this can only happen with TLS.
878 $self->{rbuf} .= delete $self->{_tls_rbuf} if exists $self->{_tls_rbuf};
736 879
737 my $len = length $self->{rbuf}; 880 my $len = length $self->{rbuf};
738 881
739 if (my $cb = shift @{ $self->{_queue} }) { 882 if (my $cb = shift @{ $self->{_queue} }) {
740 unless ($cb->($self)) { 883 unless ($cb->($self)) {
741 if ($self->{_eof}) { 884 if ($self->{_eof}) {
742 # no progress can be made (not enough data and no data forthcoming) 885 # no progress can be made (not enough data and no data forthcoming)
743 $self->_error (&Errno::EPIPE, 1), last; 886 $self->_error (Errno::EPIPE, 1), return;
744 } 887 }
745 888
746 unshift @{ $self->{_queue} }, $cb; 889 unshift @{ $self->{_queue} }, $cb;
747 last; 890 last;
748 } 891 }
756 && !@{ $self->{_queue} } # and the queue is still empty 899 && !@{ $self->{_queue} } # and the queue is still empty
757 && $self->{on_read} # but we still have on_read 900 && $self->{on_read} # but we still have on_read
758 ) { 901 ) {
759 # no further data will arrive 902 # no further data will arrive
760 # so no progress can be made 903 # so no progress can be made
761 $self->_error (&Errno::EPIPE, 1), last 904 $self->_error (Errno::EPIPE, 1), return
762 if $self->{_eof}; 905 if $self->{_eof};
763 906
764 last; # more data might arrive 907 last; # more data might arrive
765 } 908 }
766 } else { 909 } else {
767 # read side becomes idle 910 # read side becomes idle
768 delete $self->{_rw}; 911 delete $self->{_rw} unless $self->{tls};
769 last; 912 last;
770 } 913 }
771 } 914 }
772 915
916 if ($self->{_eof}) {
917 if ($self->{on_eof}) {
773 $self->{on_eof}($self) 918 $self->{on_eof}($self)
774 if $self->{_eof} && $self->{on_eof}; 919 } else {
920 $self->_error (0, 1, "Unexpected end-of-file");
921 }
922 }
775 923
776 # may need to restart read watcher 924 # may need to restart read watcher
777 unless ($self->{_rw}) { 925 unless ($self->{_rw}) {
778 $self->start_read 926 $self->start_read
779 if $self->{on_read} || @{ $self->{_queue} }; 927 if $self->{on_read} || @{ $self->{_queue} };
797 945
798=item $handle->rbuf 946=item $handle->rbuf
799 947
800Returns the read buffer (as a modifiable lvalue). 948Returns the read buffer (as a modifiable lvalue).
801 949
802You can access the read buffer directly as the C<< ->{rbuf} >> member, if 950You can access the read buffer directly as the C<< ->{rbuf} >>
803you want. 951member, if you want. However, the only operation allowed on the
952read buffer (apart from looking at it) is removing data from its
953beginning. Otherwise modifying or appending to it is not allowed and will
954lead to hard-to-track-down bugs.
804 955
805NOTE: The read buffer should only be used or modified if the C<on_read>, 956NOTE: The read buffer should only be used or modified if the C<on_read>,
806C<push_read> or C<unshift_read> methods are used. The other read methods 957C<push_read> or C<unshift_read> methods are used. The other read methods
807automatically manage the read buffer. 958automatically manage the read buffer.
808 959
905 $cb->($_[0], substr $_[0]{rbuf}, 0, $len, ""); 1056 $cb->($_[0], substr $_[0]{rbuf}, 0, $len, "");
906 1 1057 1
907 } 1058 }
908}; 1059};
909 1060
910# compatibility with older API
911sub push_read_chunk {
912 $_[0]->push_read (chunk => $_[1], $_[2]);
913}
914
915sub unshift_read_chunk {
916 $_[0]->unshift_read (chunk => $_[1], $_[2]);
917}
918
919=item line => [$eol, ]$cb->($handle, $line, $eol) 1061=item line => [$eol, ]$cb->($handle, $line, $eol)
920 1062
921The callback will be called only once a full line (including the end of 1063The callback will be called only once a full line (including the end of
922line marker, C<$eol>) has been read. This line (excluding the end of line 1064line marker, C<$eol>) has been read. This line (excluding the end of line
923marker) will be passed to the callback as second argument (C<$line>), and 1065marker) will be passed to the callback as second argument (C<$line>), and
938=cut 1080=cut
939 1081
940register_read_type line => sub { 1082register_read_type line => sub {
941 my ($self, $cb, $eol) = @_; 1083 my ($self, $cb, $eol) = @_;
942 1084
943 $eol = qr|(\015?\012)| if @_ < 3; 1085 if (@_ < 3) {
1086 # this is more than twice as fast as the generic code below
1087 sub {
1088 $_[0]{rbuf} =~ s/^([^\015\012]*)(\015?\012)// or return;
1089
1090 $cb->($_[0], $1, $2);
1091 1
1092 }
1093 } else {
944 $eol = quotemeta $eol unless ref $eol; 1094 $eol = quotemeta $eol unless ref $eol;
945 $eol = qr|^(.*?)($eol)|s; 1095 $eol = qr|^(.*?)($eol)|s;
946 1096
947 sub { 1097 sub {
948 $_[0]{rbuf} =~ s/$eol// or return; 1098 $_[0]{rbuf} =~ s/$eol// or return;
949 1099
950 $cb->($_[0], $1, $2); 1100 $cb->($_[0], $1, $2);
1101 1
951 1 1102 }
952 } 1103 }
953}; 1104};
954
955# compatibility with older API
956sub push_read_line {
957 my $self = shift;
958 $self->push_read (line => @_);
959}
960
961sub unshift_read_line {
962 my $self = shift;
963 $self->unshift_read (line => @_);
964}
965 1105
966=item regex => $accept[, $reject[, $skip], $cb->($handle, $data) 1106=item regex => $accept[, $reject[, $skip], $cb->($handle, $data)
967 1107
968Makes a regex match against the regex object C<$accept> and returns 1108Makes a regex match against the regex object C<$accept> and returns
969everything up to and including the match. 1109everything up to and including the match.
1019 return 1; 1159 return 1;
1020 } 1160 }
1021 1161
1022 # reject 1162 # reject
1023 if ($reject && $$rbuf =~ $reject) { 1163 if ($reject && $$rbuf =~ $reject) {
1024 $self->_error (&Errno::EBADMSG); 1164 $self->_error (Errno::EBADMSG);
1025 } 1165 }
1026 1166
1027 # skip 1167 # skip
1028 if ($skip && $$rbuf =~ $skip) { 1168 if ($skip && $$rbuf =~ $skip) {
1029 $data .= substr $$rbuf, 0, $+[0], ""; 1169 $data .= substr $$rbuf, 0, $+[0], "";
1045 my ($self, $cb) = @_; 1185 my ($self, $cb) = @_;
1046 1186
1047 sub { 1187 sub {
1048 unless ($_[0]{rbuf} =~ s/^(0|[1-9][0-9]*)://) { 1188 unless ($_[0]{rbuf} =~ s/^(0|[1-9][0-9]*)://) {
1049 if ($_[0]{rbuf} =~ /[^0-9]/) { 1189 if ($_[0]{rbuf} =~ /[^0-9]/) {
1050 $self->_error (&Errno::EBADMSG); 1190 $self->_error (Errno::EBADMSG);
1051 } 1191 }
1052 return; 1192 return;
1053 } 1193 }
1054 1194
1055 my $len = $1; 1195 my $len = $1;
1058 my $string = $_[1]; 1198 my $string = $_[1];
1059 $_[0]->unshift_read (chunk => 1, sub { 1199 $_[0]->unshift_read (chunk => 1, sub {
1060 if ($_[1] eq ",") { 1200 if ($_[1] eq ",") {
1061 $cb->($_[0], $string); 1201 $cb->($_[0], $string);
1062 } else { 1202 } else {
1063 $self->_error (&Errno::EBADMSG); 1203 $self->_error (Errno::EBADMSG);
1064 } 1204 }
1065 }); 1205 });
1066 }); 1206 });
1067 1207
1068 1 1208 1
1074An octet string prefixed with an encoded length. The encoding C<$format> 1214An octet string prefixed with an encoded length. The encoding C<$format>
1075uses the same format as a Perl C<pack> format, but must specify a single 1215uses the same format as a Perl C<pack> format, but must specify a single
1076integer only (only one of C<cCsSlLqQiInNvVjJw> is allowed, plus an 1216integer only (only one of C<cCsSlLqQiInNvVjJw> is allowed, plus an
1077optional C<!>, C<< < >> or C<< > >> modifier). 1217optional C<!>, C<< < >> or C<< > >> modifier).
1078 1218
1079DNS over TCP uses a prefix of C<n>, EPP uses a prefix of C<N>. 1219For example, DNS over TCP uses a prefix of C<n> (2 octet network order),
1220EPP uses a prefix of C<N> (4 octtes).
1080 1221
1081Example: read a block of data prefixed by its length in BER-encoded 1222Example: read a block of data prefixed by its length in BER-encoded
1082format (very efficient). 1223format (very efficient).
1083 1224
1084 $handle->push_read (packstring => "w", sub { 1225 $handle->push_read (packstring => "w", sub {
1090register_read_type packstring => sub { 1231register_read_type packstring => sub {
1091 my ($self, $cb, $format) = @_; 1232 my ($self, $cb, $format) = @_;
1092 1233
1093 sub { 1234 sub {
1094 # when we can use 5.10 we can use ".", but for 5.8 we use the re-pack method 1235 # when we can use 5.10 we can use ".", but for 5.8 we use the re-pack method
1095 defined (my $len = eval { unpack $format, $_[0]->{rbuf} }) 1236 defined (my $len = eval { unpack $format, $_[0]{rbuf} })
1096 or return; 1237 or return;
1097 1238
1239 $format = length pack $format, $len;
1240
1241 # bypass unshift if we already have the remaining chunk
1242 if ($format + $len <= length $_[0]{rbuf}) {
1243 my $data = substr $_[0]{rbuf}, $format, $len;
1244 substr $_[0]{rbuf}, 0, $format + $len, "";
1245 $cb->($_[0], $data);
1246 } else {
1098 # remove prefix 1247 # remove prefix
1099 substr $_[0]->{rbuf}, 0, (length pack $format, $len), ""; 1248 substr $_[0]{rbuf}, 0, $format, "";
1100 1249
1101 # read rest 1250 # read remaining chunk
1102 $_[0]->unshift_read (chunk => $len, $cb); 1251 $_[0]->unshift_read (chunk => $len, $cb);
1252 }
1103 1253
1104 1 1254 1
1105 } 1255 }
1106}; 1256};
1107 1257
1108=item json => $cb->($handle, $hash_or_arrayref) 1258=item json => $cb->($handle, $hash_or_arrayref)
1109 1259
1110Reads a JSON object or array, decodes it and passes it to the callback. 1260Reads a JSON object or array, decodes it and passes it to the
1261callback. When a parse error occurs, an C<EBADMSG> error will be raised.
1111 1262
1112If a C<json> object was passed to the constructor, then that will be used 1263If a C<json> object was passed to the constructor, then that will be used
1113for the final decode, otherwise it will create a JSON coder expecting UTF-8. 1264for the final decode, otherwise it will create a JSON coder expecting UTF-8.
1114 1265
1115This read type uses the incremental parser available with JSON version 1266This read type uses the incremental parser available with JSON version
1124=cut 1275=cut
1125 1276
1126register_read_type json => sub { 1277register_read_type json => sub {
1127 my ($self, $cb) = @_; 1278 my ($self, $cb) = @_;
1128 1279
1129 require JSON; 1280 my $json = $self->{json} ||=
1281 eval { require JSON::XS; JSON::XS->new->utf8 }
1282 || do { require JSON; JSON->new->utf8 };
1130 1283
1131 my $data; 1284 my $data;
1132 my $rbuf = \$self->{rbuf}; 1285 my $rbuf = \$self->{rbuf};
1133 1286
1134 my $json = $self->{json} ||= JSON->new->utf8;
1135
1136 sub { 1287 sub {
1137 my $ref = $json->incr_parse ($self->{rbuf}); 1288 my $ref = eval { $json->incr_parse ($self->{rbuf}) };
1138 1289
1139 if ($ref) { 1290 if ($ref) {
1140 $self->{rbuf} = $json->incr_text; 1291 $self->{rbuf} = $json->incr_text;
1141 $json->incr_text = ""; 1292 $json->incr_text = "";
1142 $cb->($self, $ref); 1293 $cb->($self, $ref);
1143 1294
1144 1 1295 1
1296 } elsif ($@) {
1297 # error case
1298 $json->incr_skip;
1299
1300 $self->{rbuf} = $json->incr_text;
1301 $json->incr_text = "";
1302
1303 $self->_error (Errno::EBADMSG);
1304
1305 ()
1145 } else { 1306 } else {
1146 $self->{rbuf} = ""; 1307 $self->{rbuf} = "";
1308
1147 () 1309 ()
1148 } 1310 }
1149 } 1311 }
1150}; 1312};
1151 1313
1164 1326
1165 require Storable; 1327 require Storable;
1166 1328
1167 sub { 1329 sub {
1168 # when we can use 5.10 we can use ".", but for 5.8 we use the re-pack method 1330 # when we can use 5.10 we can use ".", but for 5.8 we use the re-pack method
1169 defined (my $len = eval { unpack "w", $_[0]->{rbuf} }) 1331 defined (my $len = eval { unpack "w", $_[0]{rbuf} })
1170 or return; 1332 or return;
1171 1333
1334 my $format = length pack "w", $len;
1335
1336 # bypass unshift if we already have the remaining chunk
1337 if ($format + $len <= length $_[0]{rbuf}) {
1338 my $data = substr $_[0]{rbuf}, $format, $len;
1339 substr $_[0]{rbuf}, 0, $format + $len, "";
1340 $cb->($_[0], Storable::thaw ($data));
1341 } else {
1172 # remove prefix 1342 # remove prefix
1173 substr $_[0]->{rbuf}, 0, (length pack "w", $len), ""; 1343 substr $_[0]{rbuf}, 0, $format, "";
1174 1344
1175 # read rest 1345 # read remaining chunk
1176 $_[0]->unshift_read (chunk => $len, sub { 1346 $_[0]->unshift_read (chunk => $len, sub {
1177 if (my $ref = eval { Storable::thaw ($_[1]) }) { 1347 if (my $ref = eval { Storable::thaw ($_[1]) }) {
1178 $cb->($_[0], $ref); 1348 $cb->($_[0], $ref);
1179 } else { 1349 } else {
1180 $self->_error (&Errno::EBADMSG); 1350 $self->_error (Errno::EBADMSG);
1351 }
1181 } 1352 });
1182 }); 1353 }
1354
1355 1
1183 } 1356 }
1184}; 1357};
1185 1358
1186=back 1359=back
1187 1360
1217Note that AnyEvent::Handle will automatically C<start_read> for you when 1390Note that AnyEvent::Handle will automatically C<start_read> for you when
1218you change the C<on_read> callback or push/unshift a read callback, and it 1391you change the C<on_read> callback or push/unshift a read callback, and it
1219will automatically C<stop_read> for you when neither C<on_read> is set nor 1392will automatically C<stop_read> for you when neither C<on_read> is set nor
1220there are any read requests in the queue. 1393there are any read requests in the queue.
1221 1394
1395These methods will have no effect when in TLS mode (as TLS doesn't support
1396half-duplex connections).
1397
1222=cut 1398=cut
1223 1399
1224sub stop_read { 1400sub stop_read {
1225 my ($self) = @_; 1401 my ($self) = @_;
1226 1402
1227 delete $self->{_rw}; 1403 delete $self->{_rw} unless $self->{tls};
1228} 1404}
1229 1405
1230sub start_read { 1406sub start_read {
1231 my ($self) = @_; 1407 my ($self) = @_;
1232 1408
1233 unless ($self->{_rw} || $self->{_eof}) { 1409 unless ($self->{_rw} || $self->{_eof}) {
1234 Scalar::Util::weaken $self; 1410 Scalar::Util::weaken $self;
1235 1411
1236 $self->{_rw} = AnyEvent->io (fh => $self->{fh}, poll => "r", cb => sub { 1412 $self->{_rw} = AnyEvent->io (fh => $self->{fh}, poll => "r", cb => sub {
1237 my $rbuf = $self->{filter_r} ? \my $buf : \$self->{rbuf}; 1413 my $rbuf = \($self->{tls} ? my $buf : $self->{rbuf});
1238 my $len = sysread $self->{fh}, $$rbuf, $self->{read_size} || 8192, length $$rbuf; 1414 my $len = sysread $self->{fh}, $$rbuf, $self->{read_size} || 8192, length $$rbuf;
1239 1415
1240 if ($len > 0) { 1416 if ($len > 0) {
1241 $self->{_activity} = AnyEvent->now; 1417 $self->{_activity} = AnyEvent->now;
1242 1418
1243 $self->{filter_r} 1419 if ($self->{tls}) {
1244 ? $self->{filter_r}($self, $rbuf) 1420 Net::SSLeay::BIO_write ($self->{_rbio}, $$rbuf);
1245 : $self->{_in_drain} || $self->_drain_rbuf; 1421
1422 &_dotls ($self);
1423 } else {
1424 $self->_drain_rbuf unless $self->{_in_drain};
1425 }
1246 1426
1247 } elsif (defined $len) { 1427 } elsif (defined $len) {
1248 delete $self->{_rw}; 1428 delete $self->{_rw};
1249 $self->{_eof} = 1; 1429 $self->{_eof} = 1;
1250 $self->_drain_rbuf unless $self->{_in_drain}; 1430 $self->_drain_rbuf unless $self->{_in_drain};
1254 } 1434 }
1255 }); 1435 });
1256 } 1436 }
1257} 1437}
1258 1438
1439our $ERROR_SYSCALL;
1440our $ERROR_WANT_READ;
1441
1442sub _tls_error {
1443 my ($self, $err) = @_;
1444
1445 return $self->_error ($!, 1)
1446 if $err == Net::SSLeay::ERROR_SYSCALL ();
1447
1448 my $err =Net::SSLeay::ERR_error_string (Net::SSLeay::ERR_get_error ());
1449
1450 # reduce error string to look less scary
1451 $err =~ s/^error:[0-9a-fA-F]{8}:[^:]+:([^:]+):/\L$1: /;
1452
1453 if ($self->{_on_starttls}) {
1454 (delete $self->{_on_starttls})->($self, undef, $err);
1455 &_freetls;
1456 } else {
1457 &_freetls;
1458 $self->_error (Errno::EPROTO, 1, $err);
1459 }
1460}
1461
1462# poll the write BIO and send the data if applicable
1463# also decode read data if possible
1464# this is basiclaly our TLS state machine
1465# more efficient implementations are possible with openssl,
1466# but not with the buggy and incomplete Net::SSLeay.
1259sub _dotls { 1467sub _dotls {
1260 my ($self) = @_; 1468 my ($self) = @_;
1261 1469
1262 my $buf; 1470 my $tmp;
1263 1471
1264 if (length $self->{_tls_wbuf}) { 1472 if (length $self->{_tls_wbuf}) {
1265 while ((my $len = Net::SSLeay::write ($self->{tls}, $self->{_tls_wbuf})) > 0) { 1473 while (($tmp = Net::SSLeay::write ($self->{tls}, $self->{_tls_wbuf})) > 0) {
1266 substr $self->{_tls_wbuf}, 0, $len, ""; 1474 substr $self->{_tls_wbuf}, 0, $tmp, "";
1267 } 1475 }
1268 }
1269 1476
1477 $tmp = Net::SSLeay::get_error ($self->{tls}, $tmp);
1478 return $self->_tls_error ($tmp)
1479 if $tmp != $ERROR_WANT_READ
1480 && ($tmp != $ERROR_SYSCALL || $!);
1481 }
1482
1483 while (defined ($tmp = Net::SSLeay::read ($self->{tls}))) {
1484 unless (length $tmp) {
1485 $self->{_on_starttls}
1486 and (delete $self->{_on_starttls})->($self, undef, "EOF during handshake"); # ???
1487 &_freetls;
1488
1489 if ($self->{on_stoptls}) {
1490 $self->{on_stoptls}($self);
1491 return;
1492 } else {
1493 # let's treat SSL-eof as we treat normal EOF
1494 delete $self->{_rw};
1495 $self->{_eof} = 1;
1496 }
1497 }
1498
1499 $self->{_tls_rbuf} .= $tmp;
1500 $self->_drain_rbuf unless $self->{_in_drain};
1501 $self->{tls} or return; # tls session might have gone away in callback
1502 }
1503
1504 $tmp = Net::SSLeay::get_error ($self->{tls}, -1);
1505 return $self->_tls_error ($tmp)
1506 if $tmp != $ERROR_WANT_READ
1507 && ($tmp != $ERROR_SYSCALL || $!);
1508
1270 if (length ($buf = Net::SSLeay::BIO_read ($self->{_wbio}))) { 1509 while (length ($tmp = Net::SSLeay::BIO_read ($self->{_wbio}))) {
1271 $self->{wbuf} .= $buf; 1510 $self->{wbuf} .= $tmp;
1272 $self->_drain_wbuf; 1511 $self->_drain_wbuf;
1273 } 1512 }
1274 1513
1275 while (defined ($buf = Net::SSLeay::read ($self->{tls}))) { 1514 $self->{_on_starttls}
1276 if (length $buf) { 1515 and Net::SSLeay::state ($self->{tls}) == Net::SSLeay::ST_OK ()
1277 $self->{rbuf} .= $buf; 1516 and (delete $self->{_on_starttls})->($self, 1, "TLS/SSL connection established");
1278 $self->_drain_rbuf unless $self->{_in_drain};
1279 } else {
1280 # let's treat SSL-eof as we treat normal EOF
1281 $self->{_eof} = 1;
1282 $self->_shutdown;
1283 return;
1284 }
1285 }
1286
1287 my $err = Net::SSLeay::get_error ($self->{tls}, -1);
1288
1289 if ($err!= Net::SSLeay::ERROR_WANT_READ ()) {
1290 if ($err == Net::SSLeay::ERROR_SYSCALL ()) {
1291 return $self->_error ($!, 1);
1292 } elsif ($err == Net::SSLeay::ERROR_SSL ()) {
1293 return $self->_error (&Errno::EIO, 1);
1294 }
1295
1296 # all others are fine for our purposes
1297 }
1298} 1517}
1299 1518
1300=item $handle->starttls ($tls[, $tls_ctx]) 1519=item $handle->starttls ($tls[, $tls_ctx])
1301 1520
1302Instead of starting TLS negotiation immediately when the AnyEvent::Handle 1521Instead of starting TLS negotiation immediately when the AnyEvent::Handle
1304C<starttls>. 1523C<starttls>.
1305 1524
1306The first argument is the same as the C<tls> constructor argument (either 1525The first argument is the same as the C<tls> constructor argument (either
1307C<"connect">, C<"accept"> or an existing Net::SSLeay object). 1526C<"connect">, C<"accept"> or an existing Net::SSLeay object).
1308 1527
1309The second argument is the optional C<Net::SSLeay::CTX> object that is 1528The second argument is the optional C<AnyEvent::TLS> object that is used
1310used when AnyEvent::Handle has to create its own TLS connection object. 1529when AnyEvent::Handle has to create its own TLS connection object, or
1530a hash reference with C<< key => value >> pairs that will be used to
1531construct a new context.
1311 1532
1312The TLS connection object will end up in C<< $handle->{tls} >> after this 1533The TLS connection object will end up in C<< $handle->{tls} >>, the TLS
1313call and can be used or changed to your liking. Note that the handshake 1534context in C<< $handle->{tls_ctx} >> after this call and can be used or
1314might have already started when this function returns. 1535changed to your liking. Note that the handshake might have already started
1536when this function returns.
1315 1537
1538If it an error to start a TLS handshake more than once per
1539AnyEvent::Handle object (this is due to bugs in OpenSSL).
1540
1316=cut 1541=cut
1542
1543our %TLS_CACHE; #TODO not yet documented, should we?
1317 1544
1318sub starttls { 1545sub starttls {
1319 my ($self, $ssl, $ctx) = @_; 1546 my ($self, $ssl, $ctx) = @_;
1320 1547
1321 $self->stoptls; 1548 require Net::SSLeay;
1322 1549
1323 if ($ssl eq "accept") { 1550 Carp::croak "it is an error to call starttls more than once on an AnyEvent::Handle object"
1324 $ssl = Net::SSLeay::new ($ctx || TLS_CTX ()); 1551 if $self->{tls};
1325 Net::SSLeay::set_accept_state ($ssl); 1552
1326 } elsif ($ssl eq "connect") { 1553 $ERROR_SYSCALL = Net::SSLeay::ERROR_SYSCALL ();
1327 $ssl = Net::SSLeay::new ($ctx || TLS_CTX ()); 1554 $ERROR_WANT_READ = Net::SSLeay::ERROR_WANT_READ ();
1328 Net::SSLeay::set_connect_state ($ssl); 1555
1556 $ctx ||= $self->{tls_ctx};
1557
1558 if ("HASH" eq ref $ctx) {
1559 require AnyEvent::TLS;
1560
1561 local $Carp::CarpLevel = 1; # skip ourselves when creating a new context
1562
1563 if ($ctx->{cache}) {
1564 my $key = $ctx+0;
1565 $ctx = $TLS_CACHE{$key} ||= new AnyEvent::TLS %$ctx;
1566 } else {
1567 $ctx = new AnyEvent::TLS %$ctx;
1568 }
1569 }
1329 } 1570
1330 1571 $self->{tls_ctx} = $ctx || TLS_CTX ();
1331 $self->{tls} = $ssl; 1572 $self->{tls} = $ssl = $self->{tls_ctx}->_get_session ($ssl, $self, $self->{peername});
1332 1573
1333 # basically, this is deep magic (because SSL_read should have the same issues) 1574 # basically, this is deep magic (because SSL_read should have the same issues)
1334 # but the openssl maintainers basically said: "trust us, it just works". 1575 # but the openssl maintainers basically said: "trust us, it just works".
1335 # (unfortunately, we have to hardcode constants because the abysmally misdesigned 1576 # (unfortunately, we have to hardcode constants because the abysmally misdesigned
1336 # and mismaintained ssleay-module doesn't even offer them). 1577 # and mismaintained ssleay-module doesn't even offer them).
1337 # http://www.mail-archive.com/openssl-dev@openssl.org/msg22420.html 1578 # http://www.mail-archive.com/openssl-dev@openssl.org/msg22420.html
1579 #
1580 # in short: this is a mess.
1581 #
1582 # note that we do not try to keep the length constant between writes as we are required to do.
1583 # we assume that most (but not all) of this insanity only applies to non-blocking cases,
1584 # and we drive openssl fully in blocking mode here. Or maybe we don't - openssl seems to
1585 # have identity issues in that area.
1338 Net::SSLeay::CTX_set_mode ($self->{tls}, 1586# Net::SSLeay::CTX_set_mode ($ssl,
1339 (eval { local $SIG{__DIE__}; Net::SSLeay::MODE_ENABLE_PARTIAL_WRITE () } || 1) 1587# (eval { local $SIG{__DIE__}; Net::SSLeay::MODE_ENABLE_PARTIAL_WRITE () } || 1)
1340 | (eval { local $SIG{__DIE__}; Net::SSLeay::MODE_ACCEPT_MOVING_WRITE_BUFFER () } || 2)); 1588# | (eval { local $SIG{__DIE__}; Net::SSLeay::MODE_ACCEPT_MOVING_WRITE_BUFFER () } || 2));
1589 Net::SSLeay::CTX_set_mode ($ssl, 1|2);
1341 1590
1342 $self->{_rbio} = Net::SSLeay::BIO_new (Net::SSLeay::BIO_s_mem ()); 1591 $self->{_rbio} = Net::SSLeay::BIO_new (Net::SSLeay::BIO_s_mem ());
1343 $self->{_wbio} = Net::SSLeay::BIO_new (Net::SSLeay::BIO_s_mem ()); 1592 $self->{_wbio} = Net::SSLeay::BIO_new (Net::SSLeay::BIO_s_mem ());
1344 1593
1345 Net::SSLeay::set_bio ($ssl, $self->{_rbio}, $self->{_wbio}); 1594 Net::SSLeay::set_bio ($ssl, $self->{_rbio}, $self->{_wbio});
1346 1595
1347 $self->{filter_w} = sub { 1596 $self->{_on_starttls} = sub { $_[0]{on_starttls}(@_) }
1348 $_[0]{_tls_wbuf} .= ${$_[1]}; 1597 if $self->{on_starttls};
1349 &_dotls; 1598
1350 }; 1599 &_dotls; # need to trigger the initial handshake
1351 $self->{filter_r} = sub { 1600 $self->start_read; # make sure we actually do read
1352 Net::SSLeay::BIO_write ($_[0]{_rbio}, ${$_[1]});
1353 &_dotls;
1354 };
1355} 1601}
1356 1602
1357=item $handle->stoptls 1603=item $handle->stoptls
1358 1604
1359Destroys the SSL connection, if any. Partial read or write data will be 1605Shuts down the SSL connection - this makes a proper EOF handshake by
1360lost. 1606sending a close notify to the other side, but since OpenSSL doesn't
1607support non-blocking shut downs, it is not possible to re-use the stream
1608afterwards.
1361 1609
1362=cut 1610=cut
1363 1611
1364sub stoptls { 1612sub stoptls {
1365 my ($self) = @_; 1613 my ($self) = @_;
1366 1614
1367 Net::SSLeay::free (delete $self->{tls}) if $self->{tls}; 1615 if ($self->{tls}) {
1616 Net::SSLeay::shutdown ($self->{tls});
1368 1617
1369 delete $self->{_rbio}; 1618 &_dotls;
1370 delete $self->{_wbio}; 1619
1371 delete $self->{_tls_wbuf}; 1620# # we don't give a shit. no, we do, but we can't. no...#d#
1372 delete $self->{filter_r}; 1621# # we, we... have to use openssl :/#d#
1373 delete $self->{filter_w}; 1622# &_freetls;#d#
1623 }
1624}
1625
1626sub _freetls {
1627 my ($self) = @_;
1628
1629 return unless $self->{tls};
1630
1631 $self->{tls_ctx}->_put_session (delete $self->{tls});
1632
1633 delete @$self{qw(_rbio _wbio _tls_wbuf _on_starttls)};
1374} 1634}
1375 1635
1376sub DESTROY { 1636sub DESTROY {
1377 my $self = shift; 1637 my ($self) = @_;
1378 1638
1379 $self->stoptls; 1639 &_freetls;
1380 1640
1381 my $linger = exists $self->{linger} ? $self->{linger} : 3600; 1641 my $linger = exists $self->{linger} ? $self->{linger} : 3600;
1382 1642
1383 if ($linger && length $self->{wbuf}) { 1643 if ($linger && length $self->{wbuf}) {
1384 my $fh = delete $self->{fh}; 1644 my $fh = delete $self->{fh};
1399 @linger = (); 1659 @linger = ();
1400 }); 1660 });
1401 } 1661 }
1402} 1662}
1403 1663
1664=item $handle->destroy
1665
1666Shuts down the handle object as much as possible - this call ensures that
1667no further callbacks will be invoked and as many resources as possible
1668will be freed. You must not call any methods on the object afterwards.
1669
1670Normally, you can just "forget" any references to an AnyEvent::Handle
1671object and it will simply shut down. This works in fatal error and EOF
1672callbacks, as well as code outside. It does I<NOT> work in a read or write
1673callback, so when you want to destroy the AnyEvent::Handle object from
1674within such an callback. You I<MUST> call C<< ->destroy >> explicitly in
1675that case.
1676
1677Destroying the handle object in this way has the advantage that callbacks
1678will be removed as well, so if those are the only reference holders (as
1679is common), then one doesn't need to do anything special to break any
1680reference cycles.
1681
1682The handle might still linger in the background and write out remaining
1683data, as specified by the C<linger> option, however.
1684
1685=cut
1686
1687sub destroy {
1688 my ($self) = @_;
1689
1690 $self->DESTROY;
1691 %$self = ();
1692}
1693
1404=item AnyEvent::Handle::TLS_CTX 1694=item AnyEvent::Handle::TLS_CTX
1405 1695
1406This function creates and returns the Net::SSLeay::CTX object used by 1696This function creates and returns the AnyEvent::TLS object used by default
1407default for TLS mode. 1697for TLS mode.
1408 1698
1409The context is created like this: 1699The context is created by calling L<AnyEvent::TLS> without any arguments.
1410
1411 Net::SSLeay::load_error_strings;
1412 Net::SSLeay::SSLeay_add_ssl_algorithms;
1413 Net::SSLeay::randomize;
1414
1415 my $CTX = Net::SSLeay::CTX_new;
1416
1417 Net::SSLeay::CTX_set_options $CTX, Net::SSLeay::OP_ALL
1418 1700
1419=cut 1701=cut
1420 1702
1421our $TLS_CTX; 1703our $TLS_CTX;
1422 1704
1423sub TLS_CTX() { 1705sub TLS_CTX() {
1424 $TLS_CTX || do { 1706 $TLS_CTX ||= do {
1425 require Net::SSLeay; 1707 require AnyEvent::TLS;
1426 1708
1427 Net::SSLeay::load_error_strings (); 1709 new AnyEvent::TLS
1428 Net::SSLeay::SSLeay_add_ssl_algorithms ();
1429 Net::SSLeay::randomize ();
1430
1431 $TLS_CTX = Net::SSLeay::CTX_new ();
1432
1433 Net::SSLeay::CTX_set_options ($TLS_CTX, Net::SSLeay::OP_ALL ());
1434
1435 $TLS_CTX
1436 } 1710 }
1437} 1711}
1438 1712
1439=back 1713=back
1714
1715
1716=head1 NONFREQUENTLY ASKED QUESTIONS
1717
1718=over 4
1719
1720=item I C<undef> the AnyEvent::Handle reference inside my callback and
1721still get further invocations!
1722
1723That's because AnyEvent::Handle keeps a reference to itself when handling
1724read or write callbacks.
1725
1726It is only safe to "forget" the reference inside EOF or error callbacks,
1727from within all other callbacks, you need to explicitly call the C<<
1728->destroy >> method.
1729
1730=item I get different callback invocations in TLS mode/Why can't I pause
1731reading?
1732
1733Unlike, say, TCP, TLS connections do not consist of two independent
1734communication channels, one for each direction. Or put differently. The
1735read and write directions are not independent of each other: you cannot
1736write data unless you are also prepared to read, and vice versa.
1737
1738This can mean than, in TLS mode, you might get C<on_error> or C<on_eof>
1739callback invocations when you are not expecting any read data - the reason
1740is that AnyEvent::Handle always reads in TLS mode.
1741
1742During the connection, you have to make sure that you always have a
1743non-empty read-queue, or an C<on_read> watcher. At the end of the
1744connection (or when you no longer want to use it) you can call the
1745C<destroy> method.
1746
1747=item How do I read data until the other side closes the connection?
1748
1749If you just want to read your data into a perl scalar, the easiest way
1750to achieve this is by setting an C<on_read> callback that does nothing,
1751clearing the C<on_eof> callback and in the C<on_error> callback, the data
1752will be in C<$_[0]{rbuf}>:
1753
1754 $handle->on_read (sub { });
1755 $handle->on_eof (undef);
1756 $handle->on_error (sub {
1757 my $data = delete $_[0]{rbuf};
1758 });
1759
1760The reason to use C<on_error> is that TCP connections, due to latencies
1761and packets loss, might get closed quite violently with an error, when in
1762fact, all data has been received.
1763
1764It is usually better to use acknowledgements when transferring data,
1765to make sure the other side hasn't just died and you got the data
1766intact. This is also one reason why so many internet protocols have an
1767explicit QUIT command.
1768
1769=item I don't want to destroy the handle too early - how do I wait until
1770all data has been written?
1771
1772After writing your last bits of data, set the C<on_drain> callback
1773and destroy the handle in there - with the default setting of
1774C<low_water_mark> this will be called precisely when all data has been
1775written to the socket:
1776
1777 $handle->push_write (...);
1778 $handle->on_drain (sub {
1779 warn "all data submitted to the kernel\n";
1780 undef $handle;
1781 });
1782
1783If you just want to queue some data and then signal EOF to the other side,
1784consider using C<< ->push_shutdown >> instead.
1785
1786=item I want to contact a TLS/SSL server, I don't care about security.
1787
1788If your TLS server is a pure TLS server (e.g. HTTPS) that only speaks TLS,
1789simply connect to it and then create the AnyEvent::Handle with the C<tls>
1790parameter:
1791
1792 tcp_connect $host, $port, sub {
1793 my ($fh) = @_;
1794
1795 my $handle = new AnyEvent::Handle
1796 fh => $fh,
1797 tls => "connect",
1798 on_error => sub { ... };
1799
1800 $handle->push_write (...);
1801 };
1802
1803=item I want to contact a TLS/SSL server, I do care about security.
1804
1805Then you should additionally enable certificate verification, including
1806peername verification, if the protocol you use supports it (see
1807L<AnyEvent::TLS>, C<verify_peername>).
1808
1809E.g. for HTTPS:
1810
1811 tcp_connect $host, $port, sub {
1812 my ($fh) = @_;
1813
1814 my $handle = new AnyEvent::Handle
1815 fh => $fh,
1816 peername => $host,
1817 tls => "connect",
1818 tls_ctx => { verify => 1, verify_peername => "https" },
1819 ...
1820
1821Note that you must specify the hostname you connected to (or whatever
1822"peername" the protocol needs) as the C<peername> argument, otherwise no
1823peername verification will be done.
1824
1825The above will use the system-dependent default set of trusted CA
1826certificates. If you want to check against a specific CA, add the
1827C<ca_file> (or C<ca_cert>) arguments to C<tls_ctx>:
1828
1829 tls_ctx => {
1830 verify => 1,
1831 verify_peername => "https",
1832 ca_file => "my-ca-cert.pem",
1833 },
1834
1835=item I want to create a TLS/SSL server, how do I do that?
1836
1837Well, you first need to get a server certificate and key. You have
1838three options: a) ask a CA (buy one, use cacert.org etc.) b) create a
1839self-signed certificate (cheap. check the search engine of your choice,
1840there are many tutorials on the net) or c) make your own CA (tinyca2 is a
1841nice program for that purpose).
1842
1843Then create a file with your private key (in PEM format, see
1844L<AnyEvent::TLS>), followed by the certificate (also in PEM format). The
1845file should then look like this:
1846
1847 -----BEGIN RSA PRIVATE KEY-----
1848 ...header data
1849 ... lots of base64'y-stuff
1850 -----END RSA PRIVATE KEY-----
1851
1852 -----BEGIN CERTIFICATE-----
1853 ... lots of base64'y-stuff
1854 -----END CERTIFICATE-----
1855
1856The important bits are the "PRIVATE KEY" and "CERTIFICATE" parts. Then
1857specify this file as C<cert_file>:
1858
1859 tcp_server undef, $port, sub {
1860 my ($fh) = @_;
1861
1862 my $handle = new AnyEvent::Handle
1863 fh => $fh,
1864 tls => "accept",
1865 tls_ctx => { cert_file => "my-server-keycert.pem" },
1866 ...
1867
1868When you have intermediate CA certificates that your clients might not
1869know about, just append them to the C<cert_file>.
1870
1871=back
1872
1440 1873
1441=head1 SUBCLASSING AnyEvent::Handle 1874=head1 SUBCLASSING AnyEvent::Handle
1442 1875
1443In many cases, you might want to subclass AnyEvent::Handle. 1876In many cases, you might want to subclass AnyEvent::Handle.
1444 1877
1448=over 4 1881=over 4
1449 1882
1450=item * all constructor arguments become object members. 1883=item * all constructor arguments become object members.
1451 1884
1452At least initially, when you pass a C<tls>-argument to the constructor it 1885At least initially, when you pass a C<tls>-argument to the constructor it
1453will end up in C<< $handle->{tls} >>. Those members might be changes or 1886will end up in C<< $handle->{tls} >>. Those members might be changed or
1454mutated later on (for example C<tls> will hold the TLS connection object). 1887mutated later on (for example C<tls> will hold the TLS connection object).
1455 1888
1456=item * other object member names are prefixed with an C<_>. 1889=item * other object member names are prefixed with an C<_>.
1457 1890
1458All object members not explicitly documented (internal use) are prefixed 1891All object members not explicitly documented (internal use) are prefixed

Diff Legend

Removed lines
+ Added lines
< Changed lines
> Changed lines