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.107 by root, Wed Nov 26 06:40:47 2008 UTC vs.
Revision 1.181 by root, Tue Sep 1 10:40:05 2009 UTC

1package AnyEvent::Handle;
2
3no warnings;
4use strict qw(subs vars);
5
6use AnyEvent ();
7use AnyEvent::Util qw(WSAEWOULDBLOCK);
8use Scalar::Util ();
9use Carp ();
10use Fcntl ();
11use Errno qw(EAGAIN EINTR);
12
13=head1 NAME 1=head1 NAME
14 2
15AnyEvent::Handle - non-blocking I/O on file handles via AnyEvent 3AnyEvent::Handle - non-blocking I/O on file handles via AnyEvent
16
17=cut
18
19our $VERSION = 4.33;
20 4
21=head1 SYNOPSIS 5=head1 SYNOPSIS
22 6
23 use AnyEvent; 7 use AnyEvent;
24 use AnyEvent::Handle; 8 use AnyEvent::Handle;
25 9
26 my $cv = AnyEvent->condvar; 10 my $cv = AnyEvent->condvar;
27 11
28 my $handle = 12 my $hdl; $hdl = new AnyEvent::Handle
29 AnyEvent::Handle->new (
30 fh => \*STDIN, 13 fh => \*STDIN,
31 on_eof => sub { 14 on_error => sub {
15 my ($hdl, $fatal, $msg) = @_;
16 warn "got error $msg\n";
17 $hdl->destroy;
32 $cv->send; 18 $cv->send;
33 },
34 ); 19 );
35 20
36 # send some request line 21 # send some request line
37 $handle->push_write ("getinfo\015\012"); 22 $hdl->push_write ("getinfo\015\012");
38 23
39 # read the response line 24 # read the response line
40 $handle->push_read (line => sub { 25 $hdl->push_read (line => sub {
41 my ($handle, $line) = @_; 26 my ($hdl, $line) = @_;
42 warn "read line <$line>\n"; 27 warn "got line <$line>\n";
43 $cv->send; 28 $cv->send;
44 }); 29 });
45 30
46 $cv->recv; 31 $cv->recv;
47 32
48=head1 DESCRIPTION 33=head1 DESCRIPTION
49 34
50This module is a helper module to make it easier to do event-based I/O on 35This 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 36filehandles.
52on sockets see L<AnyEvent::Util>.
53 37
54The L<AnyEvent::Intro> tutorial contains some well-documented 38The L<AnyEvent::Intro> tutorial contains some well-documented
55AnyEvent::Handle examples. 39AnyEvent::Handle examples.
56 40
57In the following, when the documentation refers to of "bytes" then this 41In the following, when the documentation refers to of "bytes" then this
58means characters. As sysread and syswrite are used for all I/O, their 42means characters. As sysread and syswrite are used for all I/O, their
59treatment of characters applies to this module as well. 43treatment of characters applies to this module as well.
60 44
45At the very minimum, you should specify C<fh> or C<connect>, and the
46C<on_error> callback.
47
61All callbacks will be invoked with the handle object as their first 48All callbacks will be invoked with the handle object as their first
62argument. 49argument.
63 50
51=cut
52
53package AnyEvent::Handle;
54
55use Scalar::Util ();
56use List::Util ();
57use Carp ();
58use Errno qw(EAGAIN EINTR);
59
60use AnyEvent (); BEGIN { AnyEvent::common_sense }
61use AnyEvent::Util qw(WSAEWOULDBLOCK);
62
63our $VERSION = $AnyEvent::VERSION;
64
64=head1 METHODS 65=head1 METHODS
65 66
66=over 4 67=over 4
67 68
68=item B<new (%args)> 69=item $handle = B<new> AnyEvent::TLS fh => $filehandle, key => value...
69 70
70The constructor supports these arguments (all as key => value pairs). 71The constructor supports these arguments (all as C<< key => value >> pairs).
71 72
72=over 4 73=over 4
73 74
74=item fh => $filehandle [MANDATORY] 75=item fh => $filehandle [C<fh> or C<connect> MANDATORY]
75 76
76The filehandle this L<AnyEvent::Handle> object will operate on. 77The filehandle this L<AnyEvent::Handle> object will operate on.
77
78NOTE: The filehandle will be set to non-blocking mode (using 78NOTE: The filehandle will be set to non-blocking mode (using
79C<AnyEvent::Util::fh_nonblocking>) by the constructor and needs to stay in 79C<AnyEvent::Util::fh_nonblocking>) by the constructor and needs to stay in
80that mode. 80that mode.
81 81
82=item connect => [$host, $service] [C<fh> or C<connect> MANDATORY]
83
84Try to connect to the specified host and service (port), using
85C<AnyEvent::Socket::tcp_connect>. The C<$host> additionally becomes the
86default C<peername>.
87
88You have to specify either this parameter, or C<fh>, above.
89
90It is possible to push requests on the read and write queues, and modify
91properties of the stream, even while AnyEvent::Handle is connecting.
92
93When this parameter is specified, then the C<on_prepare>,
94C<on_connect_error> and C<on_connect> callbacks will be called under the
95appropriate circumstances:
96
97=over 4
98
99=item on_prepare => $cb->($handle)
100
101This (rarely used) callback is called before a new connection is
102attempted, but after the file handle has been created. It could be used to
103prepare the file handle with parameters required for the actual connect
104(as opposed to settings that can be changed when the connection is already
105established).
106
107The return value of this callback should be the connect timeout value in
108seconds (or C<0>, or C<undef>, or the empty list, to indicate the default
109timeout is to be used).
110
111=item on_connect => $cb->($handle, $host, $port, $retry->())
112
113This callback is called when a connection has been successfully established.
114
115The actual numeric host and port (the socket peername) are passed as
116parameters, together with a retry callback.
117
118When, for some reason, the handle is not acceptable, then calling
119C<$retry> will continue with the next conenction target (in case of
120multi-homed hosts or SRV records there can be multiple connection
121endpoints). When it is called then the read and write queues, eof status,
122tls status and similar properties of the handle are being reset.
123
124In most cases, ignoring the C<$retry> parameter is the way to go.
125
126=item on_connect_error => $cb->($handle, $message)
127
128This callback is called when the conenction could not be
129established. C<$!> will contain the relevant error code, and C<$message> a
130message describing it (usually the same as C<"$!">).
131
132If this callback isn't specified, then C<on_error> will be called with a
133fatal error instead.
134
135=back
136
137=item on_error => $cb->($handle, $fatal, $message)
138
139This is the error callback, which is called when, well, some error
140occured, such as not being able to resolve the hostname, failure to
141connect or a read error.
142
143Some errors are fatal (which is indicated by C<$fatal> being true). On
144fatal errors the handle object will be destroyed (by a call to C<< ->
145destroy >>) after invoking the error callback (which means you are free to
146examine the handle object). Examples of fatal errors are an EOF condition
147with active (but unsatisifable) read watchers (C<EPIPE>) or I/O errors. In
148cases where the other side can close the connection at their will it is
149often easiest to not report C<EPIPE> errors in this callback.
150
151AnyEvent::Handle tries to find an appropriate error code for you to check
152against, but in some cases (TLS errors), this does not work well. It is
153recommended to always output the C<$message> argument in human-readable
154error messages (it's usually the same as C<"$!">).
155
156Non-fatal errors can be retried by simply returning, but it is recommended
157to simply ignore this parameter and instead abondon the handle object
158when this callback is invoked. Examples of non-fatal errors are timeouts
159C<ETIMEDOUT>) or badly-formatted data (C<EBADMSG>).
160
161On callback entrance, the value of C<$!> contains the operating system
162error code (or C<ENOSPC>, C<EPIPE>, C<ETIMEDOUT>, C<EBADMSG> or
163C<EPROTO>).
164
165While not mandatory, it is I<highly> recommended to set this callback, as
166you will not be notified of errors otherwise. The default simply calls
167C<croak>.
168
169=item on_read => $cb->($handle)
170
171This sets the default read callback, which is called when data arrives
172and no read request is in the queue (unlike read queue callbacks, this
173callback will only be called when at least one octet of data is in the
174read buffer).
175
176To access (and remove data from) the read buffer, use the C<< ->rbuf >>
177method or access the C<< $handle->{rbuf} >> member directly. Note that you
178must not enlarge or modify the read buffer, you can only remove data at
179the beginning from it.
180
181When an EOF condition is detected then AnyEvent::Handle will first try to
182feed all the remaining data to the queued callbacks and C<on_read> before
183calling the C<on_eof> callback. If no progress can be made, then a fatal
184error will be raised (with C<$!> set to C<EPIPE>).
185
186Note that, unlike requests in the read queue, an C<on_read> callback
187doesn't mean you I<require> some data: if there is an EOF and there
188are outstanding read requests then an error will be flagged. With an
189C<on_read> callback, the C<on_eof> callback will be invoked.
190
82=item on_eof => $cb->($handle) 191=item on_eof => $cb->($handle)
83 192
84Set the callback to be called when an end-of-file condition is detected, 193Set the callback to be called when an end-of-file condition is detected,
85i.e. in the case of a socket, when the other side has closed the 194i.e. in the case of a socket, when the other side has closed the
86connection cleanly. 195connection cleanly, and there are no outstanding read requests in the
196queue (if there are read requests, then an EOF counts as an unexpected
197connection close and will be flagged as an error).
87 198
88For sockets, this just means that the other side has stopped sending data, 199For sockets, this just means that the other side has stopped sending data,
89you can still try to write data, and, in fact, one can return from the EOF 200you can still try to write data, and, in fact, one can return from the EOF
90callback and continue writing data, as only the read part has been shut 201callback and continue writing data, as only the read part has been shut
91down. 202down.
92 203
93While not mandatory, it is I<highly> recommended to set an EOF callback,
94otherwise you might end up with a closed socket while you are still
95waiting for data.
96
97If an EOF condition has been detected but no C<on_eof> callback has been 204If an EOF condition has been detected but no C<on_eof> callback has been
98set, then a fatal error will be raised with C<$!> set to <0>. 205set, then a fatal error will be raised with C<$!> set to <0>.
99
100=item on_error => $cb->($handle, $fatal)
101
102This is the error callback, which is called when, well, some error
103occured, such as not being able to resolve the hostname, failure to
104connect or a read error.
105
106Some errors are fatal (which is indicated by C<$fatal> being true). On
107fatal errors the handle object will be shut down and will not be usable
108(but you are free to look at the current C<< ->rbuf >>). Examples of fatal
109errors are an EOF condition with active (but unsatisifable) read watchers
110(C<EPIPE>) or I/O errors.
111
112Non-fatal errors can be retried by simply returning, but it is recommended
113to simply ignore this parameter and instead abondon the handle object
114when this callback is invoked. Examples of non-fatal errors are timeouts
115C<ETIMEDOUT>) or badly-formatted data (C<EBADMSG>).
116
117On callback entrance, the value of C<$!> contains the operating system
118error (or C<ENOSPC>, C<EPIPE>, C<ETIMEDOUT> or C<EBADMSG>).
119
120While not mandatory, it is I<highly> recommended to set this callback, as
121you will not be notified of errors otherwise. The default simply calls
122C<croak>.
123
124=item on_read => $cb->($handle)
125
126This sets the default read callback, which is called when data arrives
127and no read request is in the queue (unlike read queue callbacks, this
128callback will only be called when at least one octet of data is in the
129read buffer).
130
131To access (and remove data from) the read buffer, use the C<< ->rbuf >>
132method or access the C<$handle->{rbuf}> member directly.
133
134When an EOF condition is detected then AnyEvent::Handle will first try to
135feed all the remaining data to the queued callbacks and C<on_read> before
136calling the C<on_eof> callback. If no progress can be made, then a fatal
137error will be raised (with C<$!> set to C<EPIPE>).
138 206
139=item on_drain => $cb->($handle) 207=item on_drain => $cb->($handle)
140 208
141This sets the callback that is called when the write buffer becomes empty 209This sets the callback that is called when the write buffer becomes empty
142(or when the callback is set and the buffer is empty already). 210(or when the callback is set and the buffer is empty already).
149memory and push it into the queue, but instead only read more data from 217memory and push it into the queue, but instead only read more data from
150the file when the write queue becomes empty. 218the file when the write queue becomes empty.
151 219
152=item timeout => $fractional_seconds 220=item timeout => $fractional_seconds
153 221
222=item rtimeout => $fractional_seconds
223
224=item wtimeout => $fractional_seconds
225
154If non-zero, then this enables an "inactivity" timeout: whenever this many 226If non-zero, then these enables an "inactivity" timeout: whenever this
155seconds pass without a successful read or write on the underlying file 227many seconds pass without a successful read or write on the underlying
156handle, the C<on_timeout> callback will be invoked (and if that one is 228file handle (or a call to C<timeout_reset>), the C<on_timeout> callback
157missing, a non-fatal C<ETIMEDOUT> error will be raised). 229will be invoked (and if that one is missing, a non-fatal C<ETIMEDOUT>
230error will be raised).
231
232There are three variants of the timeouts that work fully independent
233of each other, for both read and write, just read, and just write:
234C<timeout>, C<rtimeout> and C<wtimeout>, with corresponding callbacks
235C<on_timeout>, C<on_rtimeout> and C<on_wtimeout>, and reset functions
236C<timeout_reset>, C<rtimeout_reset>, and C<wtimeout_reset>.
158 237
159Note that timeout processing is also active when you currently do not have 238Note that timeout processing is also active when you currently do not have
160any outstanding read or write requests: If you plan to keep the connection 239any outstanding read or write requests: If you plan to keep the connection
161idle then you should disable the timout temporarily or ignore the timeout 240idle then you should disable the timout temporarily or ignore the timeout
162in the C<on_timeout> callback, in which case AnyEvent::Handle will simply 241in the C<on_timeout> callback, in which case AnyEvent::Handle will simply
235 314
236This will not work for partial TLS data that could not be encoded 315This will not work for partial TLS data that could not be encoded
237yet. This data will be lost. Calling the C<stoptls> method in time might 316yet. This data will be lost. Calling the C<stoptls> method in time might
238help. 317help.
239 318
319=item peername => $string
320
321A string used to identify the remote site - usually the DNS hostname
322(I<not> IDN!) used to create the connection, rarely the IP address.
323
324Apart from being useful in error messages, this string is also used in TLS
325peername verification (see C<verify_peername> in L<AnyEvent::TLS>). This
326verification will be skipped when C<peername> is not specified or
327C<undef>.
328
240=item tls => "accept" | "connect" | Net::SSLeay::SSL object 329=item tls => "accept" | "connect" | Net::SSLeay::SSL object
241 330
242When this parameter is given, it enables TLS (SSL) mode, that means 331When this parameter is given, it enables TLS (SSL) mode, that means
243AnyEvent will start a TLS handshake as soon as the conenction has been 332AnyEvent will start a TLS handshake as soon as the conenction has been
244established and will transparently encrypt/decrypt data afterwards. 333established and will transparently encrypt/decrypt data afterwards.
334
335All TLS protocol errors will be signalled as C<EPROTO>, with an
336appropriate error message.
245 337
246TLS mode requires Net::SSLeay to be installed (it will be loaded 338TLS mode requires Net::SSLeay to be installed (it will be loaded
247automatically when you try to create a TLS handle): this module doesn't 339automatically when you try to create a TLS handle): this module doesn't
248have a dependency on that module, so if your module requires it, you have 340have a dependency on that module, so if your module requires it, you have
249to add the dependency yourself. 341to add the dependency yourself.
253mode. 345mode.
254 346
255You can also provide your own TLS connection object, but you have 347You can also provide your own TLS connection object, but you have
256to make sure that you call either C<Net::SSLeay::set_connect_state> 348to make sure that you call either C<Net::SSLeay::set_connect_state>
257or C<Net::SSLeay::set_accept_state> on it before you pass it to 349or C<Net::SSLeay::set_accept_state> on it before you pass it to
258AnyEvent::Handle. 350AnyEvent::Handle. Also, this module will take ownership of this connection
351object.
352
353At some future point, AnyEvent::Handle might switch to another TLS
354implementation, then the option to use your own session object will go
355away.
356
357B<IMPORTANT:> since Net::SSLeay "objects" are really only integers,
358passing in the wrong integer will lead to certain crash. This most often
359happens when one uses a stylish C<< tls => 1 >> and is surprised about the
360segmentation fault.
259 361
260See the C<< ->starttls >> method for when need to start TLS negotiation later. 362See the C<< ->starttls >> method for when need to start TLS negotiation later.
261 363
262=item tls_ctx => $ssl_ctx 364=item tls_ctx => $anyevent_tls
263 365
264Use the given C<Net::SSLeay::CTX> object to create the new TLS connection 366Use the given C<AnyEvent::TLS> object to create the new TLS connection
265(unless a connection object was specified directly). If this parameter is 367(unless a connection object was specified directly). If this parameter is
266missing, then AnyEvent::Handle will use C<AnyEvent::Handle::TLS_CTX>. 368missing, then AnyEvent::Handle will use C<AnyEvent::Handle::TLS_CTX>.
369
370Instead of an object, you can also specify a hash reference with C<< key
371=> value >> pairs. Those will be passed to L<AnyEvent::TLS> to create a
372new TLS context object.
373
374=item on_starttls => $cb->($handle, $success[, $error_message])
375
376This callback will be invoked when the TLS/SSL handshake has finished. If
377C<$success> is true, then the TLS handshake succeeded, otherwise it failed
378(C<on_stoptls> will not be called in this case).
379
380The session in C<< $handle->{tls} >> can still be examined in this
381callback, even when the handshake was not successful.
382
383TLS handshake failures will not cause C<on_error> to be invoked when this
384callback is in effect, instead, the error message will be passed to C<on_starttls>.
385
386Without this callback, handshake failures lead to C<on_error> being
387called, as normal.
388
389Note that you cannot call C<starttls> right again in this callback. If you
390need to do that, start an zero-second timer instead whose callback can
391then call C<< ->starttls >> again.
392
393=item on_stoptls => $cb->($handle)
394
395When a SSLv3/TLS shutdown/close notify/EOF is detected and this callback is
396set, then it will be invoked after freeing the TLS session. If it is not,
397then a TLS shutdown condition will be treated like a normal EOF condition
398on the handle.
399
400The session in C<< $handle->{tls} >> can still be examined in this
401callback.
402
403This callback will only be called on TLS shutdowns, not when the
404underlying handle signals EOF.
267 405
268=item json => JSON or JSON::XS object 406=item json => JSON or JSON::XS object
269 407
270This is the json coder object used by the C<json> read and write types. 408This is the json coder object used by the C<json> read and write types.
271 409
280 418
281=cut 419=cut
282 420
283sub new { 421sub new {
284 my $class = shift; 422 my $class = shift;
285
286 my $self = bless { @_ }, $class; 423 my $self = bless { @_ }, $class;
287 424
288 $self->{fh} or Carp::croak "mandatory argument fh is missing"; 425 if ($self->{fh}) {
426 $self->_start;
427 return unless $self->{fh}; # could be gone by now
428
429 } elsif ($self->{connect}) {
430 require AnyEvent::Socket;
431
432 $self->{peername} = $self->{connect}[0]
433 unless exists $self->{peername};
434
435 $self->{_skip_drain_rbuf} = 1;
436
437 {
438 Scalar::Util::weaken (my $self = $self);
439
440 $self->{_connect} =
441 AnyEvent::Socket::tcp_connect (
442 $self->{connect}[0],
443 $self->{connect}[1],
444 sub {
445 my ($fh, $host, $port, $retry) = @_;
446
447 if ($fh) {
448 $self->{fh} = $fh;
449
450 delete $self->{_skip_drain_rbuf};
451 $self->_start;
452
453 $self->{on_connect}
454 and $self->{on_connect}($self, $host, $port, sub {
455 delete @$self{qw(fh _tw _rtw _wtw _ww _rw _eof _queue rbuf _wbuf tls _tls_rbuf _tls_wbuf)};
456 $self->{_skip_drain_rbuf} = 1;
457 &$retry;
458 });
459
460 } else {
461 if ($self->{on_connect_error}) {
462 $self->{on_connect_error}($self, "$!");
463 $self->destroy;
464 } else {
465 $self->_error ($!, 1);
466 }
467 }
468 },
469 sub {
470 local $self->{fh} = $_[0];
471
472 $self->{on_prepare}
473 ? $self->{on_prepare}->($self)
474 : ()
475 }
476 );
477 }
478
479 } else {
480 Carp::croak "AnyEvent::Handle: either an existing fh or the connect parameter must be specified";
481 }
482
483 $self
484}
485
486sub _start {
487 my ($self) = @_;
289 488
290 AnyEvent::Util::fh_nonblocking $self->{fh}, 1; 489 AnyEvent::Util::fh_nonblocking $self->{fh}, 1;
490
491 $self->{_activity} =
492 $self->{_ractivity} =
493 $self->{_wactivity} = AE::now;
494
495 $self->timeout (delete $self->{timeout} ) if $self->{timeout};
496 $self->rtimeout (delete $self->{rtimeout}) if $self->{rtimeout};
497 $self->wtimeout (delete $self->{wtimeout}) if $self->{wtimeout};
498
499 $self->no_delay (delete $self->{no_delay}) if exists $self->{no_delay};
291 500
292 $self->starttls (delete $self->{tls}, delete $self->{tls_ctx}) 501 $self->starttls (delete $self->{tls}, delete $self->{tls_ctx})
293 if $self->{tls}; 502 if $self->{tls};
294 503
295 $self->{_activity} = AnyEvent->now;
296 $self->_timeout;
297
298 $self->on_drain (delete $self->{on_drain}) if exists $self->{on_drain}; 504 $self->on_drain (delete $self->{on_drain}) if $self->{on_drain};
299 $self->no_delay (delete $self->{no_delay}) if exists $self->{no_delay};
300 505
301 $self->start_read 506 $self->start_read
302 if $self->{on_read}; 507 if $self->{on_read} || @{ $self->{_queue} };
303 508
304 $self 509 $self->_drain_wbuf;
305}
306
307sub _shutdown {
308 my ($self) = @_;
309
310 delete $self->{_tw};
311 delete $self->{_rw};
312 delete $self->{_ww};
313 delete $self->{fh};
314
315 &_freetls;
316
317 delete $self->{on_read};
318 delete $self->{_queue};
319} 510}
320 511
321sub _error { 512sub _error {
322 my ($self, $errno, $fatal) = @_; 513 my ($self, $errno, $fatal, $message) = @_;
323
324 $self->_shutdown
325 if $fatal;
326 514
327 $! = $errno; 515 $! = $errno;
516 $message ||= "$!";
328 517
329 if ($self->{on_error}) { 518 if ($self->{on_error}) {
330 $self->{on_error}($self, $fatal); 519 $self->{on_error}($self, $fatal, $message);
520 $self->destroy if $fatal;
331 } elsif ($self->{fh}) { 521 } elsif ($self->{fh}) {
522 $self->destroy;
332 Carp::croak "AnyEvent::Handle uncaught error: $!"; 523 Carp::croak "AnyEvent::Handle uncaught error: $message";
333 } 524 }
334} 525}
335 526
336=item $fh = $handle->fh 527=item $fh = $handle->fh
337 528
361 $_[0]{on_eof} = $_[1]; 552 $_[0]{on_eof} = $_[1];
362} 553}
363 554
364=item $handle->on_timeout ($cb) 555=item $handle->on_timeout ($cb)
365 556
366Replace the current C<on_timeout> callback, or disables the callback (but 557=item $handle->on_rtimeout ($cb)
367not the timeout) if C<$cb> = C<undef>. See the C<timeout> constructor
368argument and method.
369 558
370=cut 559=item $handle->on_wtimeout ($cb)
371 560
372sub on_timeout { 561Replace the current C<on_timeout>, C<on_rtimeout> or C<on_wtimeout>
373 $_[0]{on_timeout} = $_[1]; 562callback, or disables the callback (but not the timeout) if C<$cb> =
374} 563C<undef>. See the C<timeout> constructor argument and method.
564
565=cut
566
567# see below
375 568
376=item $handle->autocork ($boolean) 569=item $handle->autocork ($boolean)
377 570
378Enables or disables the current autocork behaviour (see C<autocork> 571Enables or disables the current autocork behaviour (see C<autocork>
379constructor argument). Changes will only take effect on the next write. 572constructor argument). Changes will only take effect on the next write.
394sub no_delay { 587sub no_delay {
395 $_[0]{no_delay} = $_[1]; 588 $_[0]{no_delay} = $_[1];
396 589
397 eval { 590 eval {
398 local $SIG{__DIE__}; 591 local $SIG{__DIE__};
399 setsockopt $_[0]{fh}, &Socket::IPPROTO_TCP, &Socket::TCP_NODELAY, int $_[1]; 592 setsockopt $_[0]{fh}, &Socket::IPPROTO_TCP, &Socket::TCP_NODELAY, int $_[1]
593 if $_[0]{fh};
400 }; 594 };
401} 595}
402 596
597=item $handle->on_starttls ($cb)
598
599Replace the current C<on_starttls> callback (see the C<on_starttls> constructor argument).
600
601=cut
602
603sub on_starttls {
604 $_[0]{on_starttls} = $_[1];
605}
606
607=item $handle->on_stoptls ($cb)
608
609Replace the current C<on_stoptls> callback (see the C<on_stoptls> constructor argument).
610
611=cut
612
613sub on_starttls {
614 $_[0]{on_stoptls} = $_[1];
615}
616
617=item $handle->rbuf_max ($max_octets)
618
619Configures the C<rbuf_max> setting (C<undef> disables it).
620
621=cut
622
623sub rbuf_max {
624 $_[0]{rbuf_max} = $_[1];
625}
626
403############################################################################# 627#############################################################################
404 628
405=item $handle->timeout ($seconds) 629=item $handle->timeout ($seconds)
406 630
631=item $handle->rtimeout ($seconds)
632
633=item $handle->wtimeout ($seconds)
634
407Configures (or disables) the inactivity timeout. 635Configures (or disables) the inactivity timeout.
408 636
409=cut 637=item $handle->timeout_reset
410 638
411sub timeout { 639=item $handle->rtimeout_reset
640
641=item $handle->wtimeout_reset
642
643Reset the activity timeout, as if data was received or sent.
644
645These methods are cheap to call.
646
647=cut
648
649for my $dir ("", "r", "w") {
650 my $timeout = "${dir}timeout";
651 my $tw = "_${dir}tw";
652 my $on_timeout = "on_${dir}timeout";
653 my $activity = "_${dir}activity";
654 my $cb;
655
656 *$on_timeout = sub {
657 $_[0]{$on_timeout} = $_[1];
658 };
659
660 *$timeout = sub {
412 my ($self, $timeout) = @_; 661 my ($self, $new_value) = @_;
413 662
414 $self->{timeout} = $timeout; 663 $self->{$timeout} = $new_value;
415 $self->_timeout; 664 delete $self->{$tw}; &$cb;
416} 665 };
417 666
667 *{"${dir}timeout_reset"} = sub {
668 $_[0]{$activity} = AE::now;
669 };
670
671 # main workhorse:
418# reset the timeout watcher, as neccessary 672 # reset the timeout watcher, as neccessary
419# also check for time-outs 673 # also check for time-outs
420sub _timeout { 674 $cb = sub {
421 my ($self) = @_; 675 my ($self) = @_;
422 676
423 if ($self->{timeout}) { 677 if ($self->{$timeout} && $self->{fh}) {
424 my $NOW = AnyEvent->now; 678 my $NOW = AE::now;
425 679
426 # when would the timeout trigger? 680 # when would the timeout trigger?
427 my $after = $self->{_activity} + $self->{timeout} - $NOW; 681 my $after = $self->{$activity} + $self->{$timeout} - $NOW;
428 682
429 # now or in the past already? 683 # now or in the past already?
430 if ($after <= 0) { 684 if ($after <= 0) {
431 $self->{_activity} = $NOW; 685 $self->{$activity} = $NOW;
432 686
433 if ($self->{on_timeout}) { 687 if ($self->{$on_timeout}) {
434 $self->{on_timeout}($self); 688 $self->{$on_timeout}($self);
435 } else { 689 } else {
436 $self->_error (&Errno::ETIMEDOUT); 690 $self->_error (Errno::ETIMEDOUT);
691 }
692
693 # callback could have changed timeout value, optimise
694 return unless $self->{$timeout};
695
696 # calculate new after
697 $after = $self->{$timeout};
437 } 698 }
438 699
439 # callback could have changed timeout value, optimise 700 Scalar::Util::weaken $self;
440 return unless $self->{timeout}; 701 return unless $self; # ->error could have destroyed $self
441 702
442 # calculate new after 703 $self->{$tw} ||= AE::timer $after, 0, sub {
443 $after = $self->{timeout}; 704 delete $self->{$tw};
705 $cb->($self);
706 };
707 } else {
708 delete $self->{$tw};
444 } 709 }
445
446 Scalar::Util::weaken $self;
447 return unless $self; # ->error could have destroyed $self
448
449 $self->{_tw} ||= AnyEvent->timer (after => $after, cb => sub {
450 delete $self->{_tw};
451 $self->_timeout;
452 });
453 } else {
454 delete $self->{_tw};
455 } 710 }
456} 711}
457 712
458############################################################################# 713#############################################################################
459 714
504 Scalar::Util::weaken $self; 759 Scalar::Util::weaken $self;
505 760
506 my $cb = sub { 761 my $cb = sub {
507 my $len = syswrite $self->{fh}, $self->{wbuf}; 762 my $len = syswrite $self->{fh}, $self->{wbuf};
508 763
509 if ($len >= 0) { 764 if (defined $len) {
510 substr $self->{wbuf}, 0, $len, ""; 765 substr $self->{wbuf}, 0, $len, "";
511 766
512 $self->{_activity} = AnyEvent->now; 767 $self->{_activity} = $self->{_wactivity} = AE::now;
513 768
514 $self->{on_drain}($self) 769 $self->{on_drain}($self)
515 if $self->{low_water_mark} >= (length $self->{wbuf}) + (length $self->{_tls_wbuf}) 770 if $self->{low_water_mark} >= (length $self->{wbuf}) + (length $self->{_tls_wbuf})
516 && $self->{on_drain}; 771 && $self->{on_drain};
517 772
523 778
524 # try to write data immediately 779 # try to write data immediately
525 $cb->() unless $self->{autocork}; 780 $cb->() unless $self->{autocork};
526 781
527 # if still data left in wbuf, we need to poll 782 # if still data left in wbuf, we need to poll
528 $self->{_ww} = AnyEvent->io (fh => $self->{fh}, poll => "w", cb => $cb) 783 $self->{_ww} = AE::io $self->{fh}, 1, $cb
529 if length $self->{wbuf}; 784 if length $self->{wbuf};
530 }; 785 };
531} 786}
532 787
533our %WH; 788our %WH;
546 ->($self, @_); 801 ->($self, @_);
547 } 802 }
548 803
549 if ($self->{tls}) { 804 if ($self->{tls}) {
550 $self->{_tls_wbuf} .= $_[0]; 805 $self->{_tls_wbuf} .= $_[0];
551 806 &_dotls ($self) if $self->{fh};
552 &_dotls ($self);
553 } else { 807 } else {
554 $self->{wbuf} .= $_[0]; 808 $self->{wbuf} .= $_[0];
555 $self->_drain_wbuf; 809 $self->_drain_wbuf if $self->{fh};
556 } 810 }
557} 811}
558 812
559=item $handle->push_write (type => @args) 813=item $handle->push_write (type => @args)
560 814
624Other languages could read single lines terminated by a newline and pass 878Other languages could read single lines terminated by a newline and pass
625this line into their JSON decoder of choice. 879this line into their JSON decoder of choice.
626 880
627=cut 881=cut
628 882
883sub json_coder() {
884 eval { require JSON::XS; JSON::XS->new->utf8 }
885 || do { require JSON; JSON->new->utf8 }
886}
887
629register_write_type json => sub { 888register_write_type json => sub {
630 my ($self, $ref) = @_; 889 my ($self, $ref) = @_;
631 890
632 require JSON; 891 my $json = $self->{json} ||= json_coder;
633 892
634 $self->{json} ? $self->{json}->encode ($ref) 893 $json->encode ($ref)
635 : JSON::encode_json ($ref)
636}; 894};
637 895
638=item storable => $reference 896=item storable => $reference
639 897
640Freezes the given reference using L<Storable> and writes it to the 898Freezes the given reference using L<Storable> and writes it to the
649 907
650 pack "w/a*", Storable::nfreeze ($ref) 908 pack "w/a*", Storable::nfreeze ($ref)
651}; 909};
652 910
653=back 911=back
912
913=item $handle->push_shutdown
914
915Sometimes you know you want to close the socket after writing your data
916before it was actually written. One way to do that is to replace your
917C<on_drain> handler by a callback that shuts down the socket (and set
918C<low_water_mark> to C<0>). This method is a shorthand for just that, and
919replaces the C<on_drain> callback with:
920
921 sub { shutdown $_[0]{fh}, 1 } # for push_shutdown
922
923This simply shuts down the write side and signals an EOF condition to the
924the peer.
925
926You can rely on the normal read queue and C<on_eof> handling
927afterwards. This is the cleanest way to close a connection.
928
929=cut
930
931sub push_shutdown {
932 my ($self) = @_;
933
934 delete $self->{low_water_mark};
935 $self->on_drain (sub { shutdown $_[0]{fh}, 1 });
936}
654 937
655=item AnyEvent::Handle::register_write_type type => $coderef->($handle, @args) 938=item AnyEvent::Handle::register_write_type type => $coderef->($handle, @args)
656 939
657This function (not method) lets you add your own types to C<push_write>. 940This function (not method) lets you add your own types to C<push_write>.
658Whenever the given C<type> is used, C<push_write> will invoke the code 941Whenever the given C<type> is used, C<push_write> will invoke the code
752=cut 1035=cut
753 1036
754sub _drain_rbuf { 1037sub _drain_rbuf {
755 my ($self) = @_; 1038 my ($self) = @_;
756 1039
1040 # avoid recursion
1041 return if $self->{_skip_drain_rbuf};
757 local $self->{_in_drain} = 1; 1042 local $self->{_skip_drain_rbuf} = 1;
758
759 if (
760 defined $self->{rbuf_max}
761 && $self->{rbuf_max} < length $self->{rbuf}
762 ) {
763 $self->_error (&Errno::ENOSPC, 1), return;
764 }
765 1043
766 while () { 1044 while () {
1045 # we need to use a separate tls read buffer, as we must not receive data while
1046 # we are draining the buffer, and this can only happen with TLS.
1047 $self->{rbuf} .= delete $self->{_tls_rbuf}
1048 if exists $self->{_tls_rbuf};
1049
767 my $len = length $self->{rbuf}; 1050 my $len = length $self->{rbuf};
768 1051
769 if (my $cb = shift @{ $self->{_queue} }) { 1052 if (my $cb = shift @{ $self->{_queue} }) {
770 unless ($cb->($self)) { 1053 unless ($cb->($self)) {
771 if ($self->{_eof}) { 1054 # no progress can be made
772 # no progress can be made (not enough data and no data forthcoming) 1055 # (not enough data and no data forthcoming)
773 $self->_error (&Errno::EPIPE, 1), return; 1056 $self->_error (Errno::EPIPE, 1), return
774 } 1057 if $self->{_eof};
775 1058
776 unshift @{ $self->{_queue} }, $cb; 1059 unshift @{ $self->{_queue} }, $cb;
777 last; 1060 last;
778 } 1061 }
779 } elsif ($self->{on_read}) { 1062 } elsif ($self->{on_read}) {
786 && !@{ $self->{_queue} } # and the queue is still empty 1069 && !@{ $self->{_queue} } # and the queue is still empty
787 && $self->{on_read} # but we still have on_read 1070 && $self->{on_read} # but we still have on_read
788 ) { 1071 ) {
789 # no further data will arrive 1072 # no further data will arrive
790 # so no progress can be made 1073 # so no progress can be made
791 $self->_error (&Errno::EPIPE, 1), return 1074 $self->_error (Errno::EPIPE, 1), return
792 if $self->{_eof}; 1075 if $self->{_eof};
793 1076
794 last; # more data might arrive 1077 last; # more data might arrive
795 } 1078 }
796 } else { 1079 } else {
799 last; 1082 last;
800 } 1083 }
801 } 1084 }
802 1085
803 if ($self->{_eof}) { 1086 if ($self->{_eof}) {
804 if ($self->{on_eof}) { 1087 $self->{on_eof}
805 $self->{on_eof}($self) 1088 ? $self->{on_eof}($self)
806 } else { 1089 : $self->_error (0, 1, "Unexpected end-of-file");
807 $self->_error (0, 1); 1090
808 } 1091 return;
1092 }
1093
1094 if (
1095 defined $self->{rbuf_max}
1096 && $self->{rbuf_max} < length $self->{rbuf}
1097 ) {
1098 $self->_error (Errno::ENOSPC, 1), return;
809 } 1099 }
810 1100
811 # may need to restart read watcher 1101 # may need to restart read watcher
812 unless ($self->{_rw}) { 1102 unless ($self->{_rw}) {
813 $self->start_read 1103 $self->start_read
825 1115
826sub on_read { 1116sub on_read {
827 my ($self, $cb) = @_; 1117 my ($self, $cb) = @_;
828 1118
829 $self->{on_read} = $cb; 1119 $self->{on_read} = $cb;
830 $self->_drain_rbuf if $cb && !$self->{_in_drain}; 1120 $self->_drain_rbuf if $cb;
831} 1121}
832 1122
833=item $handle->rbuf 1123=item $handle->rbuf
834 1124
835Returns the read buffer (as a modifiable lvalue). 1125Returns the read buffer (as a modifiable lvalue).
836 1126
837You can access the read buffer directly as the C<< ->{rbuf} >> member, if 1127You can access the read buffer directly as the C<< ->{rbuf} >>
838you want. 1128member, if you want. However, the only operation allowed on the
1129read buffer (apart from looking at it) is removing data from its
1130beginning. Otherwise modifying or appending to it is not allowed and will
1131lead to hard-to-track-down bugs.
839 1132
840NOTE: The read buffer should only be used or modified if the C<on_read>, 1133NOTE: The read buffer should only be used or modified if the C<on_read>,
841C<push_read> or C<unshift_read> methods are used. The other read methods 1134C<push_read> or C<unshift_read> methods are used. The other read methods
842automatically manage the read buffer. 1135automatically manage the read buffer.
843 1136
884 $cb = ($RH{$type} or Carp::croak "unsupported type passed to AnyEvent::Handle::push_read") 1177 $cb = ($RH{$type} or Carp::croak "unsupported type passed to AnyEvent::Handle::push_read")
885 ->($self, $cb, @_); 1178 ->($self, $cb, @_);
886 } 1179 }
887 1180
888 push @{ $self->{_queue} }, $cb; 1181 push @{ $self->{_queue} }, $cb;
889 $self->_drain_rbuf unless $self->{_in_drain}; 1182 $self->_drain_rbuf;
890} 1183}
891 1184
892sub unshift_read { 1185sub unshift_read {
893 my $self = shift; 1186 my $self = shift;
894 my $cb = pop; 1187 my $cb = pop;
898 1191
899 $cb = ($RH{$type} or Carp::croak "unsupported type passed to AnyEvent::Handle::unshift_read") 1192 $cb = ($RH{$type} or Carp::croak "unsupported type passed to AnyEvent::Handle::unshift_read")
900 ->($self, $cb, @_); 1193 ->($self, $cb, @_);
901 } 1194 }
902 1195
903
904 unshift @{ $self->{_queue} }, $cb; 1196 unshift @{ $self->{_queue} }, $cb;
905 $self->_drain_rbuf unless $self->{_in_drain}; 1197 $self->_drain_rbuf;
906} 1198}
907 1199
908=item $handle->push_read (type => @args, $cb) 1200=item $handle->push_read (type => @args, $cb)
909 1201
910=item $handle->unshift_read (type => @args, $cb) 1202=item $handle->unshift_read (type => @args, $cb)
1043 return 1; 1335 return 1;
1044 } 1336 }
1045 1337
1046 # reject 1338 # reject
1047 if ($reject && $$rbuf =~ $reject) { 1339 if ($reject && $$rbuf =~ $reject) {
1048 $self->_error (&Errno::EBADMSG); 1340 $self->_error (Errno::EBADMSG);
1049 } 1341 }
1050 1342
1051 # skip 1343 # skip
1052 if ($skip && $$rbuf =~ $skip) { 1344 if ($skip && $$rbuf =~ $skip) {
1053 $data .= substr $$rbuf, 0, $+[0], ""; 1345 $data .= substr $$rbuf, 0, $+[0], "";
1069 my ($self, $cb) = @_; 1361 my ($self, $cb) = @_;
1070 1362
1071 sub { 1363 sub {
1072 unless ($_[0]{rbuf} =~ s/^(0|[1-9][0-9]*)://) { 1364 unless ($_[0]{rbuf} =~ s/^(0|[1-9][0-9]*)://) {
1073 if ($_[0]{rbuf} =~ /[^0-9]/) { 1365 if ($_[0]{rbuf} =~ /[^0-9]/) {
1074 $self->_error (&Errno::EBADMSG); 1366 $self->_error (Errno::EBADMSG);
1075 } 1367 }
1076 return; 1368 return;
1077 } 1369 }
1078 1370
1079 my $len = $1; 1371 my $len = $1;
1082 my $string = $_[1]; 1374 my $string = $_[1];
1083 $_[0]->unshift_read (chunk => 1, sub { 1375 $_[0]->unshift_read (chunk => 1, sub {
1084 if ($_[1] eq ",") { 1376 if ($_[1] eq ",") {
1085 $cb->($_[0], $string); 1377 $cb->($_[0], $string);
1086 } else { 1378 } else {
1087 $self->_error (&Errno::EBADMSG); 1379 $self->_error (Errno::EBADMSG);
1088 } 1380 }
1089 }); 1381 });
1090 }); 1382 });
1091 1383
1092 1 1384 1
1139 } 1431 }
1140}; 1432};
1141 1433
1142=item json => $cb->($handle, $hash_or_arrayref) 1434=item json => $cb->($handle, $hash_or_arrayref)
1143 1435
1144Reads a JSON object or array, decodes it and passes it to the callback. 1436Reads a JSON object or array, decodes it and passes it to the
1437callback. When a parse error occurs, an C<EBADMSG> error will be raised.
1145 1438
1146If a C<json> object was passed to the constructor, then that will be used 1439If a C<json> object was passed to the constructor, then that will be used
1147for the final decode, otherwise it will create a JSON coder expecting UTF-8. 1440for the final decode, otherwise it will create a JSON coder expecting UTF-8.
1148 1441
1149This read type uses the incremental parser available with JSON version 1442This read type uses the incremental parser available with JSON version
1158=cut 1451=cut
1159 1452
1160register_read_type json => sub { 1453register_read_type json => sub {
1161 my ($self, $cb) = @_; 1454 my ($self, $cb) = @_;
1162 1455
1163 require JSON; 1456 my $json = $self->{json} ||= json_coder;
1164 1457
1165 my $data; 1458 my $data;
1166 my $rbuf = \$self->{rbuf}; 1459 my $rbuf = \$self->{rbuf};
1167 1460
1168 my $json = $self->{json} ||= JSON->new->utf8;
1169
1170 sub { 1461 sub {
1171 my $ref = $json->incr_parse ($self->{rbuf}); 1462 my $ref = eval { $json->incr_parse ($self->{rbuf}) };
1172 1463
1173 if ($ref) { 1464 if ($ref) {
1174 $self->{rbuf} = $json->incr_text; 1465 $self->{rbuf} = $json->incr_text;
1175 $json->incr_text = ""; 1466 $json->incr_text = "";
1176 $cb->($self, $ref); 1467 $cb->($self, $ref);
1177 1468
1178 1 1469 1
1470 } elsif ($@) {
1471 # error case
1472 $json->incr_skip;
1473
1474 $self->{rbuf} = $json->incr_text;
1475 $json->incr_text = "";
1476
1477 $self->_error (Errno::EBADMSG);
1478
1479 ()
1179 } else { 1480 } else {
1180 $self->{rbuf} = ""; 1481 $self->{rbuf} = "";
1482
1181 () 1483 ()
1182 } 1484 }
1183 } 1485 }
1184}; 1486};
1185 1487
1217 # read remaining chunk 1519 # read remaining chunk
1218 $_[0]->unshift_read (chunk => $len, sub { 1520 $_[0]->unshift_read (chunk => $len, sub {
1219 if (my $ref = eval { Storable::thaw ($_[1]) }) { 1521 if (my $ref = eval { Storable::thaw ($_[1]) }) {
1220 $cb->($_[0], $ref); 1522 $cb->($_[0], $ref);
1221 } else { 1523 } else {
1222 $self->_error (&Errno::EBADMSG); 1524 $self->_error (Errno::EBADMSG);
1223 } 1525 }
1224 }); 1526 });
1225 } 1527 }
1226 1528
1227 1 1529 1
1279 my ($self) = @_; 1581 my ($self) = @_;
1280 1582
1281 unless ($self->{_rw} || $self->{_eof}) { 1583 unless ($self->{_rw} || $self->{_eof}) {
1282 Scalar::Util::weaken $self; 1584 Scalar::Util::weaken $self;
1283 1585
1284 $self->{_rw} = AnyEvent->io (fh => $self->{fh}, poll => "r", cb => sub { 1586 $self->{_rw} = AE::io $self->{fh}, 0, sub {
1285 my $rbuf = \($self->{tls} ? my $buf : $self->{rbuf}); 1587 my $rbuf = \($self->{tls} ? my $buf : $self->{rbuf});
1286 my $len = sysread $self->{fh}, $$rbuf, $self->{read_size} || 8192, length $$rbuf; 1588 my $len = sysread $self->{fh}, $$rbuf, $self->{read_size} || 8192, length $$rbuf;
1287 1589
1288 if ($len > 0) { 1590 if ($len > 0) {
1289 $self->{_activity} = AnyEvent->now; 1591 $self->{_activity} = $self->{_ractivity} = AE::now;
1290 1592
1291 if ($self->{tls}) { 1593 if ($self->{tls}) {
1292 Net::SSLeay::BIO_write ($self->{_rbio}, $$rbuf); 1594 Net::SSLeay::BIO_write ($self->{_rbio}, $$rbuf);
1293 1595
1294 &_dotls ($self); 1596 &_dotls ($self);
1295 } else { 1597 } else {
1296 $self->_drain_rbuf unless $self->{_in_drain}; 1598 $self->_drain_rbuf;
1297 } 1599 }
1298 1600
1299 } elsif (defined $len) { 1601 } elsif (defined $len) {
1300 delete $self->{_rw}; 1602 delete $self->{_rw};
1301 $self->{_eof} = 1; 1603 $self->{_eof} = 1;
1302 $self->_drain_rbuf unless $self->{_in_drain}; 1604 $self->_drain_rbuf;
1303 1605
1304 } elsif ($! != EAGAIN && $! != EINTR && $! != WSAEWOULDBLOCK) { 1606 } elsif ($! != EAGAIN && $! != EINTR && $! != WSAEWOULDBLOCK) {
1305 return $self->_error ($!, 1); 1607 return $self->_error ($!, 1);
1306 } 1608 }
1307 }); 1609 };
1610 }
1611}
1612
1613our $ERROR_SYSCALL;
1614our $ERROR_WANT_READ;
1615
1616sub _tls_error {
1617 my ($self, $err) = @_;
1618
1619 return $self->_error ($!, 1)
1620 if $err == Net::SSLeay::ERROR_SYSCALL ();
1621
1622 my $err =Net::SSLeay::ERR_error_string (Net::SSLeay::ERR_get_error ());
1623
1624 # reduce error string to look less scary
1625 $err =~ s/^error:[0-9a-fA-F]{8}:[^:]+:([^:]+):/\L$1: /;
1626
1627 if ($self->{_on_starttls}) {
1628 (delete $self->{_on_starttls})->($self, undef, $err);
1629 &_freetls;
1630 } else {
1631 &_freetls;
1632 $self->_error (Errno::EPROTO, 1, $err);
1308 } 1633 }
1309} 1634}
1310 1635
1311# poll the write BIO and send the data if applicable 1636# poll the write BIO and send the data if applicable
1637# also decode read data if possible
1638# this is basiclaly our TLS state machine
1639# more efficient implementations are possible with openssl,
1640# but not with the buggy and incomplete Net::SSLeay.
1312sub _dotls { 1641sub _dotls {
1313 my ($self) = @_; 1642 my ($self) = @_;
1314 1643
1315 my $tmp; 1644 my $tmp;
1316 1645
1317 if (length $self->{_tls_wbuf}) { 1646 if (length $self->{_tls_wbuf}) {
1318 while (($tmp = Net::SSLeay::write ($self->{tls}, $self->{_tls_wbuf})) > 0) { 1647 while (($tmp = Net::SSLeay::write ($self->{tls}, $self->{_tls_wbuf})) > 0) {
1319 substr $self->{_tls_wbuf}, 0, $tmp, ""; 1648 substr $self->{_tls_wbuf}, 0, $tmp, "";
1320 } 1649 }
1650
1651 $tmp = Net::SSLeay::get_error ($self->{tls}, $tmp);
1652 return $self->_tls_error ($tmp)
1653 if $tmp != $ERROR_WANT_READ
1654 && ($tmp != $ERROR_SYSCALL || $!);
1321 } 1655 }
1322 1656
1323 while (defined ($tmp = Net::SSLeay::read ($self->{tls}))) { 1657 while (defined ($tmp = Net::SSLeay::read ($self->{tls}))) {
1324 unless (length $tmp) { 1658 unless (length $tmp) {
1325 # let's treat SSL-eof as we treat normal EOF 1659 $self->{_on_starttls}
1326 delete $self->{_rw}; 1660 and (delete $self->{_on_starttls})->($self, undef, "EOF during handshake"); # ???
1327 $self->{_eof} = 1;
1328 &_freetls; 1661 &_freetls;
1662
1663 if ($self->{on_stoptls}) {
1664 $self->{on_stoptls}($self);
1665 return;
1666 } else {
1667 # let's treat SSL-eof as we treat normal EOF
1668 delete $self->{_rw};
1669 $self->{_eof} = 1;
1670 }
1329 } 1671 }
1330 1672
1331 $self->{rbuf} .= $tmp; 1673 $self->{_tls_rbuf} .= $tmp;
1332 $self->_drain_rbuf unless $self->{_in_drain}; 1674 $self->_drain_rbuf;
1333 $self->{tls} or return; # tls session might have gone away in callback 1675 $self->{tls} or return; # tls session might have gone away in callback
1334 } 1676 }
1335 1677
1336 $tmp = Net::SSLeay::get_error ($self->{tls}, -1); 1678 $tmp = Net::SSLeay::get_error ($self->{tls}, -1);
1337
1338 if ($tmp != Net::SSLeay::ERROR_WANT_READ ()) {
1339 if ($tmp == Net::SSLeay::ERROR_SYSCALL ()) {
1340 return $self->_error ($!, 1); 1679 return $self->_tls_error ($tmp)
1341 } elsif ($tmp == Net::SSLeay::ERROR_SSL ()) { 1680 if $tmp != $ERROR_WANT_READ
1342 return $self->_error (&Errno::EIO, 1); 1681 && ($tmp != $ERROR_SYSCALL || $!);
1343 }
1344
1345 # all other errors are fine for our purposes
1346 }
1347 1682
1348 while (length ($tmp = Net::SSLeay::BIO_read ($self->{_wbio}))) { 1683 while (length ($tmp = Net::SSLeay::BIO_read ($self->{_wbio}))) {
1349 $self->{wbuf} .= $tmp; 1684 $self->{wbuf} .= $tmp;
1350 $self->_drain_wbuf; 1685 $self->_drain_wbuf;
1351 } 1686 }
1687
1688 $self->{_on_starttls}
1689 and Net::SSLeay::state ($self->{tls}) == Net::SSLeay::ST_OK ()
1690 and (delete $self->{_on_starttls})->($self, 1, "TLS/SSL connection established");
1352} 1691}
1353 1692
1354=item $handle->starttls ($tls[, $tls_ctx]) 1693=item $handle->starttls ($tls[, $tls_ctx])
1355 1694
1356Instead of starting TLS negotiation immediately when the AnyEvent::Handle 1695Instead of starting TLS negotiation immediately when the AnyEvent::Handle
1357object is created, you can also do that at a later time by calling 1696object is created, you can also do that at a later time by calling
1358C<starttls>. 1697C<starttls>.
1359 1698
1699Starting TLS is currently an asynchronous operation - when you push some
1700write data and then call C<< ->starttls >> then TLS negotiation will start
1701immediately, after which the queued write data is then sent.
1702
1360The first argument is the same as the C<tls> constructor argument (either 1703The first argument is the same as the C<tls> constructor argument (either
1361C<"connect">, C<"accept"> or an existing Net::SSLeay object). 1704C<"connect">, C<"accept"> or an existing Net::SSLeay object).
1362 1705
1363The second argument is the optional C<Net::SSLeay::CTX> object that is 1706The second argument is the optional C<AnyEvent::TLS> object that is used
1364used when AnyEvent::Handle has to create its own TLS connection object. 1707when AnyEvent::Handle has to create its own TLS connection object, or
1708a hash reference with C<< key => value >> pairs that will be used to
1709construct a new context.
1365 1710
1366The TLS connection object will end up in C<< $handle->{tls} >> after this 1711The TLS connection object will end up in C<< $handle->{tls} >>, the TLS
1367call and can be used or changed to your liking. Note that the handshake 1712context in C<< $handle->{tls_ctx} >> after this call and can be used or
1368might have already started when this function returns. 1713changed to your liking. Note that the handshake might have already started
1714when this function returns.
1369 1715
1370If it an error to start a TLS handshake more than once per 1716Due to bugs in OpenSSL, it might or might not be possible to do multiple
1371AnyEvent::Handle object (this is due to bugs in OpenSSL). 1717handshakes on the same stream. Best do not attempt to use the stream after
1718stopping TLS.
1372 1719
1373=cut 1720=cut
1721
1722our %TLS_CACHE; #TODO not yet documented, should we?
1374 1723
1375sub starttls { 1724sub starttls {
1376 my ($self, $ssl, $ctx) = @_; 1725 my ($self, $tls, $ctx) = @_;
1726
1727 Carp::croak "It is an error to call starttls on an AnyEvent::Handle object while TLS is already active, caught"
1728 if $self->{tls};
1729
1730 $self->{tls} = $tls;
1731 $self->{tls_ctx} = $ctx if @_ > 2;
1732
1733 return unless $self->{fh};
1377 1734
1378 require Net::SSLeay; 1735 require Net::SSLeay;
1379 1736
1380 Carp::croak "it is an error to call starttls more than once on an AnyEvent::Handle object" 1737 $ERROR_SYSCALL = Net::SSLeay::ERROR_SYSCALL ();
1381 if $self->{tls}; 1738 $ERROR_WANT_READ = Net::SSLeay::ERROR_WANT_READ ();
1739
1740 $tls = delete $self->{tls};
1741 $ctx = $self->{tls_ctx};
1742
1743 local $Carp::CarpLevel = 1; # skip ourselves when creating a new context or session
1744
1745 if ("HASH" eq ref $ctx) {
1746 require AnyEvent::TLS;
1747
1748 if ($ctx->{cache}) {
1749 my $key = $ctx+0;
1750 $ctx = $TLS_CACHE{$key} ||= new AnyEvent::TLS %$ctx;
1751 } else {
1752 $ctx = new AnyEvent::TLS %$ctx;
1753 }
1754 }
1382 1755
1383 if ($ssl eq "accept") { 1756 $self->{tls_ctx} = $ctx || TLS_CTX ();
1384 $ssl = Net::SSLeay::new ($ctx || TLS_CTX ()); 1757 $self->{tls} = $tls = $self->{tls_ctx}->_get_session ($tls, $self, $self->{peername});
1385 Net::SSLeay::set_accept_state ($ssl);
1386 } elsif ($ssl eq "connect") {
1387 $ssl = Net::SSLeay::new ($ctx || TLS_CTX ());
1388 Net::SSLeay::set_connect_state ($ssl);
1389 }
1390
1391 $self->{tls} = $ssl;
1392 1758
1393 # basically, this is deep magic (because SSL_read should have the same issues) 1759 # basically, this is deep magic (because SSL_read should have the same issues)
1394 # but the openssl maintainers basically said: "trust us, it just works". 1760 # but the openssl maintainers basically said: "trust us, it just works".
1395 # (unfortunately, we have to hardcode constants because the abysmally misdesigned 1761 # (unfortunately, we have to hardcode constants because the abysmally misdesigned
1396 # and mismaintained ssleay-module doesn't even offer them). 1762 # and mismaintained ssleay-module doesn't even offer them).
1400 # 1766 #
1401 # note that we do not try to keep the length constant between writes as we are required to do. 1767 # note that we do not try to keep the length constant between writes as we are required to do.
1402 # we assume that most (but not all) of this insanity only applies to non-blocking cases, 1768 # we assume that most (but not all) of this insanity only applies to non-blocking cases,
1403 # and we drive openssl fully in blocking mode here. Or maybe we don't - openssl seems to 1769 # and we drive openssl fully in blocking mode here. Or maybe we don't - openssl seems to
1404 # have identity issues in that area. 1770 # have identity issues in that area.
1405 Net::SSLeay::CTX_set_mode ($self->{tls}, 1771# Net::SSLeay::CTX_set_mode ($ssl,
1406 (eval { local $SIG{__DIE__}; Net::SSLeay::MODE_ENABLE_PARTIAL_WRITE () } || 1) 1772# (eval { local $SIG{__DIE__}; Net::SSLeay::MODE_ENABLE_PARTIAL_WRITE () } || 1)
1407 | (eval { local $SIG{__DIE__}; Net::SSLeay::MODE_ACCEPT_MOVING_WRITE_BUFFER () } || 2)); 1773# | (eval { local $SIG{__DIE__}; Net::SSLeay::MODE_ACCEPT_MOVING_WRITE_BUFFER () } || 2));
1774 Net::SSLeay::CTX_set_mode ($tls, 1|2);
1408 1775
1409 $self->{_rbio} = Net::SSLeay::BIO_new (Net::SSLeay::BIO_s_mem ()); 1776 $self->{_rbio} = Net::SSLeay::BIO_new (Net::SSLeay::BIO_s_mem ());
1410 $self->{_wbio} = Net::SSLeay::BIO_new (Net::SSLeay::BIO_s_mem ()); 1777 $self->{_wbio} = Net::SSLeay::BIO_new (Net::SSLeay::BIO_s_mem ());
1411 1778
1779 Net::SSLeay::BIO_write ($self->{_rbio}, delete $self->{rbuf});
1780
1412 Net::SSLeay::set_bio ($ssl, $self->{_rbio}, $self->{_wbio}); 1781 Net::SSLeay::set_bio ($tls, $self->{_rbio}, $self->{_wbio});
1782
1783 $self->{_on_starttls} = sub { $_[0]{on_starttls}(@_) }
1784 if $self->{on_starttls};
1413 1785
1414 &_dotls; # need to trigger the initial handshake 1786 &_dotls; # need to trigger the initial handshake
1415 $self->start_read; # make sure we actually do read 1787 $self->start_read; # make sure we actually do read
1416} 1788}
1417 1789
1418=item $handle->stoptls 1790=item $handle->stoptls
1419 1791
1420Shuts down the SSL connection - this makes a proper EOF handshake by 1792Shuts down the SSL connection - this makes a proper EOF handshake by
1421sending a close notify to the other side, but since OpenSSL doesn't 1793sending a close notify to the other side, but since OpenSSL doesn't
1422support non-blocking shut downs, it is not possible to re-use the stream 1794support non-blocking shut downs, it is not guarenteed that you can re-use
1423afterwards. 1795the stream afterwards.
1424 1796
1425=cut 1797=cut
1426 1798
1427sub stoptls { 1799sub stoptls {
1428 my ($self) = @_; 1800 my ($self) = @_;
1430 if ($self->{tls}) { 1802 if ($self->{tls}) {
1431 Net::SSLeay::shutdown ($self->{tls}); 1803 Net::SSLeay::shutdown ($self->{tls});
1432 1804
1433 &_dotls; 1805 &_dotls;
1434 1806
1435 # we don't give a shit. no, we do, but we can't. no... 1807# # we don't give a shit. no, we do, but we can't. no...#d#
1436 # we, we... have to use openssl :/ 1808# # we, we... have to use openssl :/#d#
1437 &_freetls; 1809# &_freetls;#d#
1438 } 1810 }
1439} 1811}
1440 1812
1441sub _freetls { 1813sub _freetls {
1442 my ($self) = @_; 1814 my ($self) = @_;
1443 1815
1444 return unless $self->{tls}; 1816 return unless $self->{tls};
1445 1817
1446 Net::SSLeay::free (delete $self->{tls}); 1818 $self->{tls_ctx}->_put_session (delete $self->{tls})
1819 if $self->{tls} > 0;
1447 1820
1448 delete @$self{qw(_rbio _wbio _tls_wbuf)}; 1821 delete @$self{qw(_rbio _wbio _tls_wbuf _on_starttls)};
1449} 1822}
1450 1823
1451sub DESTROY { 1824sub DESTROY {
1452 my $self = shift; 1825 my ($self) = @_;
1453 1826
1454 &_freetls; 1827 &_freetls;
1455 1828
1456 my $linger = exists $self->{linger} ? $self->{linger} : 3600; 1829 my $linger = exists $self->{linger} ? $self->{linger} : 3600;
1457 1830
1458 if ($linger && length $self->{wbuf}) { 1831 if ($linger && length $self->{wbuf} && $self->{fh}) {
1459 my $fh = delete $self->{fh}; 1832 my $fh = delete $self->{fh};
1460 my $wbuf = delete $self->{wbuf}; 1833 my $wbuf = delete $self->{wbuf};
1461 1834
1462 my @linger; 1835 my @linger;
1463 1836
1464 push @linger, AnyEvent->io (fh => $fh, poll => "w", cb => sub { 1837 push @linger, AE::io $fh, 1, sub {
1465 my $len = syswrite $fh, $wbuf, length $wbuf; 1838 my $len = syswrite $fh, $wbuf, length $wbuf;
1466 1839
1467 if ($len > 0) { 1840 if ($len > 0) {
1468 substr $wbuf, 0, $len, ""; 1841 substr $wbuf, 0, $len, "";
1469 } else { 1842 } else {
1470 @linger = (); # end 1843 @linger = (); # end
1471 } 1844 }
1472 }); 1845 };
1473 push @linger, AnyEvent->timer (after => $linger, cb => sub { 1846 push @linger, AE::timer $linger, 0, sub {
1474 @linger = (); 1847 @linger = ();
1475 }); 1848 };
1476 } 1849 }
1477} 1850}
1478 1851
1479=item $handle->destroy 1852=item $handle->destroy
1480 1853
1481Shuts down the handle object as much as possible - this call ensures that 1854Shuts down the handle object as much as possible - this call ensures that
1482no further callbacks will be invoked and resources will be freed as much 1855no further callbacks will be invoked and as many resources as possible
1483as possible. You must not call any methods on the object afterwards. 1856will be freed. Any method you will call on the handle object after
1857destroying it in this way will be silently ignored (and it will return the
1858empty list).
1484 1859
1485Normally, you can just "forget" any references to an AnyEvent::Handle 1860Normally, you can just "forget" any references to an AnyEvent::Handle
1486object and it will simply shut down. This works in fatal error and EOF 1861object and it will simply shut down. This works in fatal error and EOF
1487callbacks, as well as code outside. It does I<NOT> work in a read or write 1862callbacks, as well as code outside. It does I<NOT> work in a read or write
1488callback, so when you want to destroy the AnyEvent::Handle object from 1863callback, so when you want to destroy the AnyEvent::Handle object from
1489within such an callback. You I<MUST> call C<< ->destroy >> explicitly in 1864within such an callback. You I<MUST> call C<< ->destroy >> explicitly in
1490that case. 1865that case.
1491 1866
1867Destroying the handle object in this way has the advantage that callbacks
1868will be removed as well, so if those are the only reference holders (as
1869is common), then one doesn't need to do anything special to break any
1870reference cycles.
1871
1492The handle might still linger in the background and write out remaining 1872The handle might still linger in the background and write out remaining
1493data, as specified by the C<linger> option, however. 1873data, as specified by the C<linger> option, however.
1494 1874
1495=cut 1875=cut
1496 1876
1497sub destroy { 1877sub destroy {
1498 my ($self) = @_; 1878 my ($self) = @_;
1499 1879
1500 $self->DESTROY; 1880 $self->DESTROY;
1501 %$self = (); 1881 %$self = ();
1882 bless $self, "AnyEvent::Handle::destroyed";
1883}
1884
1885sub AnyEvent::Handle::destroyed::AUTOLOAD {
1886 #nop
1502} 1887}
1503 1888
1504=item AnyEvent::Handle::TLS_CTX 1889=item AnyEvent::Handle::TLS_CTX
1505 1890
1506This function creates and returns the Net::SSLeay::CTX object used by 1891This function creates and returns the AnyEvent::TLS object used by default
1507default for TLS mode. 1892for TLS mode.
1508 1893
1509The context is created like this: 1894The context is created by calling L<AnyEvent::TLS> without any arguments.
1510
1511 Net::SSLeay::load_error_strings;
1512 Net::SSLeay::SSLeay_add_ssl_algorithms;
1513 Net::SSLeay::randomize;
1514
1515 my $CTX = Net::SSLeay::CTX_new;
1516
1517 Net::SSLeay::CTX_set_options $CTX, Net::SSLeay::OP_ALL
1518 1895
1519=cut 1896=cut
1520 1897
1521our $TLS_CTX; 1898our $TLS_CTX;
1522 1899
1523sub TLS_CTX() { 1900sub TLS_CTX() {
1524 $TLS_CTX || do { 1901 $TLS_CTX ||= do {
1525 require Net::SSLeay; 1902 require AnyEvent::TLS;
1526 1903
1527 Net::SSLeay::load_error_strings (); 1904 new AnyEvent::TLS
1528 Net::SSLeay::SSLeay_add_ssl_algorithms ();
1529 Net::SSLeay::randomize ();
1530
1531 $TLS_CTX = Net::SSLeay::CTX_new ();
1532
1533 Net::SSLeay::CTX_set_options ($TLS_CTX, Net::SSLeay::OP_ALL ());
1534
1535 $TLS_CTX
1536 } 1905 }
1537} 1906}
1538 1907
1539=back 1908=back
1540 1909
1579 1948
1580 $handle->on_read (sub { }); 1949 $handle->on_read (sub { });
1581 $handle->on_eof (undef); 1950 $handle->on_eof (undef);
1582 $handle->on_error (sub { 1951 $handle->on_error (sub {
1583 my $data = delete $_[0]{rbuf}; 1952 my $data = delete $_[0]{rbuf};
1584 undef $handle;
1585 }); 1953 });
1586 1954
1587The reason to use C<on_error> is that TCP connections, due to latencies 1955The reason to use C<on_error> is that TCP connections, due to latencies
1588and packets loss, might get closed quite violently with an error, when in 1956and packets loss, might get closed quite violently with an error, when in
1589fact, all data has been received. 1957fact, all data has been received.
1605 $handle->on_drain (sub { 1973 $handle->on_drain (sub {
1606 warn "all data submitted to the kernel\n"; 1974 warn "all data submitted to the kernel\n";
1607 undef $handle; 1975 undef $handle;
1608 }); 1976 });
1609 1977
1978If you just want to queue some data and then signal EOF to the other side,
1979consider using C<< ->push_shutdown >> instead.
1980
1981=item I want to contact a TLS/SSL server, I don't care about security.
1982
1983If your TLS server is a pure TLS server (e.g. HTTPS) that only speaks TLS,
1984simply connect to it and then create the AnyEvent::Handle with the C<tls>
1985parameter:
1986
1987 tcp_connect $host, $port, sub {
1988 my ($fh) = @_;
1989
1990 my $handle = new AnyEvent::Handle
1991 fh => $fh,
1992 tls => "connect",
1993 on_error => sub { ... };
1994
1995 $handle->push_write (...);
1996 };
1997
1998=item I want to contact a TLS/SSL server, I do care about security.
1999
2000Then you should additionally enable certificate verification, including
2001peername verification, if the protocol you use supports it (see
2002L<AnyEvent::TLS>, C<verify_peername>).
2003
2004E.g. for HTTPS:
2005
2006 tcp_connect $host, $port, sub {
2007 my ($fh) = @_;
2008
2009 my $handle = new AnyEvent::Handle
2010 fh => $fh,
2011 peername => $host,
2012 tls => "connect",
2013 tls_ctx => { verify => 1, verify_peername => "https" },
2014 ...
2015
2016Note that you must specify the hostname you connected to (or whatever
2017"peername" the protocol needs) as the C<peername> argument, otherwise no
2018peername verification will be done.
2019
2020The above will use the system-dependent default set of trusted CA
2021certificates. If you want to check against a specific CA, add the
2022C<ca_file> (or C<ca_cert>) arguments to C<tls_ctx>:
2023
2024 tls_ctx => {
2025 verify => 1,
2026 verify_peername => "https",
2027 ca_file => "my-ca-cert.pem",
2028 },
2029
2030=item I want to create a TLS/SSL server, how do I do that?
2031
2032Well, you first need to get a server certificate and key. You have
2033three options: a) ask a CA (buy one, use cacert.org etc.) b) create a
2034self-signed certificate (cheap. check the search engine of your choice,
2035there are many tutorials on the net) or c) make your own CA (tinyca2 is a
2036nice program for that purpose).
2037
2038Then create a file with your private key (in PEM format, see
2039L<AnyEvent::TLS>), followed by the certificate (also in PEM format). The
2040file should then look like this:
2041
2042 -----BEGIN RSA PRIVATE KEY-----
2043 ...header data
2044 ... lots of base64'y-stuff
2045 -----END RSA PRIVATE KEY-----
2046
2047 -----BEGIN CERTIFICATE-----
2048 ... lots of base64'y-stuff
2049 -----END CERTIFICATE-----
2050
2051The important bits are the "PRIVATE KEY" and "CERTIFICATE" parts. Then
2052specify this file as C<cert_file>:
2053
2054 tcp_server undef, $port, sub {
2055 my ($fh) = @_;
2056
2057 my $handle = new AnyEvent::Handle
2058 fh => $fh,
2059 tls => "accept",
2060 tls_ctx => { cert_file => "my-server-keycert.pem" },
2061 ...
2062
2063When you have intermediate CA certificates that your clients might not
2064know about, just append them to the C<cert_file>.
2065
1610=back 2066=back
1611 2067
1612 2068
1613=head1 SUBCLASSING AnyEvent::Handle 2069=head1 SUBCLASSING AnyEvent::Handle
1614 2070

Diff Legend

Removed lines
+ Added lines
< Changed lines
> Changed lines