File Coverage

blib/lib/AnyEvent/Handle.pm
Criterion Covered Total %
statement 227 315 72.0
branch 106 190 55.7
condition 41 128 32.0
subroutine 32 59 54.2
pod 26 30 86.6
total 432 722 59.8


line stmt bran cond sub pod time code
1             =head1 NAME
2              
3             AnyEvent::Handle - non-blocking I/O on streaming handles via AnyEvent
4              
5             =head1 SYNOPSIS
6              
7             use AnyEvent;
8             use AnyEvent::Handle;
9              
10             my $cv = AnyEvent->condvar;
11              
12             my $hdl; $hdl = new AnyEvent::Handle
13             fh => \*STDIN,
14             on_error => sub {
15             my ($hdl, $fatal, $msg) = @_;
16             AE::log error => $msg;
17             $hdl->destroy;
18             $cv->send;
19             };
20              
21             # send some request line
22             $hdl->push_write ("getinfo\015\012");
23              
24             # read the response line
25             $hdl->push_read (line => sub {
26             my ($hdl, $line) = @_;
27             say "got line <$line>";
28             $cv->send;
29             });
30              
31             $cv->recv;
32              
33             =head1 DESCRIPTION
34              
35             This is a helper module to make it easier to do event-based I/O
36             on stream-based filehandles (sockets, pipes, and other stream
37             things). Specifically, it doesn't work as expected on files, packet-based
38             sockets or similar things.
39              
40             The L tutorial contains some well-documented
41             AnyEvent::Handle examples.
42              
43             In the following, where the documentation refers to "bytes", it means
44             characters. As sysread and syswrite are used for all I/O, their
45             treatment of characters applies to this module as well.
46              
47             At the very minimum, you should specify C or C, and the
48             C callback.
49              
50             All callbacks will be invoked with the handle object as their first
51             argument.
52              
53             =cut
54              
55             package AnyEvent::Handle;
56              
57 7     7   5113 use Scalar::Util ();
  7         16  
  7         152  
58 7     7   31 use List::Util ();
  7         13  
  7         78  
59 7     7   28 use Carp ();
  7         12  
  7         117  
60 7     7   29 use Errno qw(EAGAIN EWOULDBLOCK EINTR);
  7         41  
  7         848  
61              
62 7     7   40 use AnyEvent (); BEGIN { AnyEvent::common_sense }
  7     7   11  
  7         150  
  7         36  
63 7     7   39 use AnyEvent::Util qw(WSAEWOULDBLOCK);
  7         10  
  7         44803  
64              
65             our $VERSION = $AnyEvent::VERSION;
66              
67             sub _load_func($) {
68 0     0   0 my $func = $_[0];
69              
70 0 0       0 unless (defined &$func) {
71 0         0 my $pkg = $func;
72 0         0 do {
73 0 0       0 $pkg =~ s/::[^:]+$//
74             or return;
75 0         0 eval "require $pkg";
76             } until defined &$func;
77             }
78              
79 0         0 \&$func
80             }
81              
82             sub MAX_READ_SIZE() { 131072 }
83              
84             =head1 METHODS
85              
86             =over 4
87              
88             =item $handle = B AnyEvent::Handle fh => $filehandle, key => value...
89              
90             The constructor supports these arguments (all as C<< key => value >> pairs).
91              
92             =over 4
93              
94             =item fh => $filehandle [C or C MANDATORY]
95              
96             The filehandle this L object will operate on.
97             NOTE: The filehandle will be set to non-blocking mode (using
98             C) by the constructor and needs to stay in
99             that mode.
100              
101             =item connect => [$host, $service] [C or C MANDATORY]
102              
103             Try to connect to the specified host and service (port), using
104             C. The C<$host> additionally becomes the
105             default C.
106              
107             You have to specify either this parameter, or C, above.
108              
109             It is possible to push requests on the read and write queues, and modify
110             properties of the stream, even while AnyEvent::Handle is connecting.
111              
112             When this parameter is specified, then the C,
113             C and C callbacks will be called under the
114             appropriate circumstances:
115              
116             =over 4
117              
118             =item on_prepare => $cb->($handle)
119              
120             This (rarely used) callback is called before a new connection is
121             attempted, but after the file handle has been created (you can access that
122             file handle via C<< $handle->{fh} >>). It could be used to prepare the
123             file handle with parameters required for the actual connect (as opposed to
124             settings that can be changed when the connection is already established).
125              
126             The return value of this callback should be the connect timeout value in
127             seconds (or C<0>, or C, or the empty list, to indicate that the
128             default timeout is to be used).
129              
130             =item on_connect => $cb->($handle, $host, $port, $retry->())
131              
132             This callback is called when a connection has been successfully established.
133              
134             The peer's numeric host and port (the socket peername) are passed as
135             parameters, together with a retry callback. At the time it is called the
136             read and write queues, EOF status, TLS status and similar properties of
137             the handle will have been reset.
138              
139             If, for some reason, the handle is not acceptable, calling C<$retry> will
140             continue with the next connection target (in case of multi-homed hosts or
141             SRV records there can be multiple connection endpoints). The C<$retry>
142             callback can be invoked after the connect callback returns, i.e. one can
143             start a handshake and then decide to retry with the next host if the
144             handshake fails.
145              
146             In most cases, you should ignore the C<$retry> parameter.
147              
148             =item on_connect_error => $cb->($handle, $message)
149              
150             This callback is called when the connection could not be
151             established. C<$!> will contain the relevant error code, and C<$message> a
152             message describing it (usually the same as C<"$!">).
153              
154             If this callback isn't specified, then C will be called with a
155             fatal error instead.
156              
157             =back
158              
159             =item on_error => $cb->($handle, $fatal, $message)
160              
161             This is the error callback, which is called when, well, some error
162             occured, such as not being able to resolve the hostname, failure to
163             connect, or a read error.
164              
165             Some errors are fatal (which is indicated by C<$fatal> being true). On
166             fatal errors the handle object will be destroyed (by a call to C<< ->
167             destroy >>) after invoking the error callback (which means you are free to
168             examine the handle object). Examples of fatal errors are an EOF condition
169             with active (but unsatisfiable) read watchers (C) or I/O errors. In
170             cases where the other side can close the connection at will, it is
171             often easiest to not report C errors in this callback.
172              
173             AnyEvent::Handle tries to find an appropriate error code for you to check
174             against, but in some cases (TLS errors), this does not work well.
175              
176             If you report the error to the user, it is recommended to always output
177             the C<$message> argument in human-readable error messages (you don't need
178             to report C<"$!"> if you report C<$message>).
179              
180             If you want to react programmatically to the error, then looking at C<$!>
181             and comparing it against some of the documented C values is usually
182             better than looking at the C<$message>.
183              
184             Non-fatal errors can be retried by returning, but it is recommended
185             to simply ignore this parameter and instead abondon the handle object
186             when this callback is invoked. Examples of non-fatal errors are timeouts
187             C) or badly-formatted data (C).
188              
189             On entry to the callback, the value of C<$!> contains the operating
190             system error code (or C, C, C, C or
191             C).
192              
193             While not mandatory, it is I recommended to set this callback, as
194             you will not be notified of errors otherwise. The default just calls
195             C.
196              
197             =item on_read => $cb->($handle)
198              
199             This sets the default read callback, which is called when data arrives
200             and no read request is in the queue (unlike read queue callbacks, this
201             callback will only be called when at least one octet of data is in the
202             read buffer).
203              
204             To access (and remove data from) the read buffer, use the C<< ->rbuf >>
205             method or access the C<< $handle->{rbuf} >> member directly. Note that you
206             must not enlarge or modify the read buffer, you can only remove data at
207             the beginning from it.
208              
209             You can also call C<< ->push_read (...) >> or any other function that
210             modifies the read queue. Or do both. Or ...
211              
212             When an EOF condition is detected, AnyEvent::Handle will first try to
213             feed all the remaining data to the queued callbacks and C before
214             calling the C callback. If no progress can be made, then a fatal
215             error will be raised (with C<$!> set to C).
216              
217             Note that, unlike requests in the read queue, an C callback
218             doesn't mean you I some data: if there is an EOF and there
219             are outstanding read requests then an error will be flagged. With an
220             C callback, the C callback will be invoked.
221              
222             =item on_eof => $cb->($handle)
223              
224             Set the callback to be called when an end-of-file condition is detected,
225             i.e. in the case of a socket, when the other side has closed the
226             connection cleanly, and there are no outstanding read requests in the
227             queue (if there are read requests, then an EOF counts as an unexpected
228             connection close and will be flagged as an error).
229              
230             For sockets, this just means that the other side has stopped sending data,
231             you can still try to write data, and, in fact, one can return from the EOF
232             callback and continue writing data, as only the read part has been shut
233             down.
234              
235             If an EOF condition has been detected but no C callback has been
236             set, then a fatal error will be raised with C<$!> set to <0>.
237              
238             =item on_drain => $cb->($handle)
239              
240             This sets the callback that is called once when the write buffer becomes
241             empty (and immediately when the handle object is created).
242              
243             To append to the write buffer, use the C<< ->push_write >> method.
244              
245             This callback is useful when you don't want to put all of your write data
246             into the queue at once, for example, when you want to write the contents
247             of some file to the socket you might not want to read the whole file into
248             memory and push it into the queue, but instead only read more data from
249             the file when the write queue becomes empty.
250              
251             =item timeout => $fractional_seconds
252              
253             =item rtimeout => $fractional_seconds
254              
255             =item wtimeout => $fractional_seconds
256              
257             If non-zero, then these enables an "inactivity" timeout: whenever this
258             many seconds pass without a successful read or write on the underlying
259             file handle (or a call to C), the C callback
260             will be invoked (and if that one is missing, a non-fatal C
261             error will be raised).
262              
263             There are three variants of the timeouts that work independently of each
264             other, for both read and write (triggered when nothing was read I
265             written), just read (triggered when nothing was read), and just write:
266             C, C and C, with corresponding callbacks
267             C, C and C, and reset functions
268             C, C, and C.
269              
270             Note that timeout processing is active even when you do not have any
271             outstanding read or write requests: If you plan to keep the connection
272             idle then you should disable the timeout temporarily or ignore the
273             timeout in the corresponding C callback, in which case
274             AnyEvent::Handle will simply restart the timeout.
275              
276             Zero (the default) disables the corresponding timeout.
277              
278             =item on_timeout => $cb->($handle)
279              
280             =item on_rtimeout => $cb->($handle)
281              
282             =item on_wtimeout => $cb->($handle)
283              
284             Called whenever the inactivity timeout passes. If you return from this
285             callback, then the timeout will be reset as if some activity had happened,
286             so this condition is not fatal in any way.
287              
288             =item rbuf_max =>
289              
290             If defined, then a fatal error will be raised (with C<$!> set to C)
291             when the read buffer ever (strictly) exceeds this size. This is useful to
292             avoid some forms of denial-of-service attacks.
293              
294             For example, a server accepting connections from untrusted sources should
295             be configured to accept only so-and-so much data that it cannot act on
296             (for example, when expecting a line, an attacker could send an unlimited
297             amount of data without a callback ever being called as long as the line
298             isn't finished).
299              
300             =item wbuf_max =>
301              
302             If defined, then a fatal error will be raised (with C<$!> set to C)
303             when the write buffer ever (strictly) exceeds this size. This is useful to
304             avoid some forms of denial-of-service attacks.
305              
306             Although the units of this parameter is bytes, this is the I number
307             of bytes not yet accepted by the kernel. This can make a difference when
308             you e.g. use TLS, as TLS typically makes your write data larger (but it
309             can also make it smaller due to compression).
310              
311             As an example of when this limit is useful, take a chat server that sends
312             chat messages to a client. If the client does not read those in a timely
313             manner then the send buffer in the server would grow unbounded.
314              
315             =item autocork =>
316              
317             When disabled (the default), C will try to immediately
318             write the data to the handle if possible. This avoids having to register
319             a write watcher and wait for the next event loop iteration, but can
320             be inefficient if you write multiple small chunks (on the wire, this
321             disadvantage is usually avoided by your kernel's nagle algorithm, see
322             C, but this option can save costly syscalls).
323              
324             When enabled, writes will always be queued till the next event loop
325             iteration. This is efficient when you do many small writes per iteration,
326             but less efficient when you do a single write only per iteration (or when
327             the write buffer often is full). It also increases write latency.
328              
329             =item no_delay =>
330              
331             When doing small writes on sockets, your operating system kernel might
332             wait a bit for more data before actually sending it out. This is called
333             the Nagle algorithm, and usually it is beneficial.
334              
335             In some situations you want as low a delay as possible, which can be
336             accomplishd by setting this option to a true value.
337              
338             The default is your operating system's default behaviour (most likely
339             enabled). This option explicitly enables or disables it, if possible.
340              
341             =item keepalive =>
342              
343             Enables (default disable) the SO_KEEPALIVE option on the stream socket:
344             normally, TCP connections have no time-out once established, so TCP
345             connections, once established, can stay alive forever even when the other
346             side has long gone. TCP keepalives are a cheap way to take down long-lived
347             TCP connections when the other side becomes unreachable. While the default
348             is OS-dependent, TCP keepalives usually kick in after around two hours,
349             and, if the other side doesn't reply, take down the TCP connection some 10
350             to 15 minutes later.
351              
352             It is harmless to specify this option for file handles that do not support
353             keepalives, and enabling it on connections that are potentially long-lived
354             is usually a good idea.
355              
356             =item oobinline =>
357              
358             BSD majorly fucked up the implementation of TCP urgent data. The result
359             is that almost no OS implements TCP according to the specs, and every OS
360             implements it slightly differently.
361              
362             If you want to handle TCP urgent data, then setting this flag (the default
363             is enabled) gives you the most portable way of getting urgent data, by
364             putting it into the stream.
365              
366             Since BSD emulation of OOB data on top of TCP's urgent data can have
367             security implications, AnyEvent::Handle sets this flag automatically
368             unless explicitly specified. Note that setting this flag after
369             establishing a connection I be a bit too late (data loss could
370             already have occured on BSD systems), but at least it will protect you
371             from most attacks.
372              
373             =item read_size =>
374              
375             The initial read block size, the number of bytes this module will try
376             to read during each loop iteration. Each handle object will consume
377             at least this amount of memory for the read buffer as well, so when
378             handling many connections watch out for memory requirements). See also
379             C. Default: C<2048>.
380              
381             =item max_read_size =>
382              
383             The maximum read buffer size used by the dynamic adjustment
384             algorithm: Each time AnyEvent::Handle can read C bytes in
385             one go it will double C up to the maximum given by this
386             option. Default: C<131072> or C, whichever is higher.
387              
388             =item low_water_mark =>
389              
390             Sets the number of bytes (default: C<0>) that make up an "empty" write
391             buffer: If the buffer reaches this size or gets even samller it is
392             considered empty.
393              
394             Sometimes it can be beneficial (for performance reasons) to add data to
395             the write buffer before it is fully drained, but this is a rare case, as
396             the operating system kernel usually buffers data as well, so the default
397             is good in almost all cases.
398              
399             =item linger =>
400              
401             If this is non-zero (default: C<3600>), the destructor of the
402             AnyEvent::Handle object will check whether there is still outstanding
403             write data and will install a watcher that will write this data to the
404             socket. No errors will be reported (this mostly matches how the operating
405             system treats outstanding data at socket close time).
406              
407             This will not work for partial TLS data that could not be encoded
408             yet. This data will be lost. Calling the C method in time might
409             help.
410              
411             =item peername => $string
412              
413             A string used to identify the remote site - usually the DNS hostname
414             (I IDN!) used to create the connection, rarely the IP address.
415              
416             Apart from being useful in error messages, this string is also used in TLS
417             peername verification (see C in L). This
418             verification will be skipped when C is not specified or is
419             C.
420              
421             =item tls => "accept" | "connect" | Net::SSLeay::SSL object
422              
423             When this parameter is given, it enables TLS (SSL) mode, that means
424             AnyEvent will start a TLS handshake as soon as the connection has been
425             established and will transparently encrypt/decrypt data afterwards.
426              
427             All TLS protocol errors will be signalled as C, with an
428             appropriate error message.
429              
430             TLS mode requires Net::SSLeay to be installed (it will be loaded
431             automatically when you try to create a TLS handle): this module doesn't
432             have a dependency on that module, so if your module requires it, you have
433             to add the dependency yourself. If Net::SSLeay cannot be loaded or is too
434             old, you get an C error.
435              
436             Unlike TCP, TLS has a server and client side: for the TLS server side, use
437             C, and for the TLS client side of a connection, use C
438             mode.
439              
440             You can also provide your own TLS connection object, but you have
441             to make sure that you call either C
442             or C on it before you pass it to
443             AnyEvent::Handle. Also, this module will take ownership of this connection
444             object.
445              
446             At some future point, AnyEvent::Handle might switch to another TLS
447             implementation, then the option to use your own session object will go
448             away.
449              
450             B since Net::SSLeay "objects" are really only integers,
451             passing in the wrong integer will lead to certain crash. This most often
452             happens when one uses a stylish C<< tls => 1 >> and is surprised about the
453             segmentation fault.
454              
455             Use the C<< ->starttls >> method if you need to start TLS negotiation later.
456              
457             =item tls_ctx => $anyevent_tls
458              
459             Use the given C object to create the new TLS connection
460             (unless a connection object was specified directly). If this
461             parameter is missing (or C), then AnyEvent::Handle will use
462             C.
463              
464             Instead of an object, you can also specify a hash reference with C<< key
465             => value >> pairs. Those will be passed to L to create a
466             new TLS context object.
467              
468             =item on_starttls => $cb->($handle, $success[, $error_message])
469              
470             This callback will be invoked when the TLS/SSL handshake has finished. If
471             C<$success> is true, then the TLS handshake succeeded, otherwise it failed
472             (C will not be called in this case).
473              
474             The session in C<< $handle->{tls} >> can still be examined in this
475             callback, even when the handshake was not successful.
476              
477             TLS handshake failures will not cause C to be invoked when this
478             callback is in effect, instead, the error message will be passed to C.
479              
480             Without this callback, handshake failures lead to C being
481             called as usual.
482              
483             Note that you cannot just call C again in this callback. If you
484             need to do that, start an zero-second timer instead whose callback can
485             then call C<< ->starttls >> again.
486              
487             =item on_stoptls => $cb->($handle)
488              
489             When a SSLv3/TLS shutdown/close notify/EOF is detected and this callback is
490             set, then it will be invoked after freeing the TLS session. If it is not,
491             then a TLS shutdown condition will be treated like a normal EOF condition
492             on the handle.
493              
494             The session in C<< $handle->{tls} >> can still be examined in this
495             callback.
496              
497             This callback will only be called on TLS shutdowns, not when the
498             underlying handle signals EOF.
499              
500             =item json => L, L or L object
501              
502             This is the json coder object used by the C read and write types.
503              
504             If you don't supply it, then AnyEvent::Handle will create and use a
505             suitable one (on demand), which will write and expect UTF-8 encoded
506             JSON texts (either using L or L). The written texts are
507             guaranteed not to contain any newline character.
508              
509             For security reasons, this encoder will likely I handle numbers and
510             strings, only arrays and objects/hashes. The reason is that originally
511             JSON was self-delimited, but Dougles Crockford thought it was a splendid
512             idea to redefine JSON incompatibly, so this is no longer true.
513              
514             For protocols that used back-to-back JSON texts, this might lead to
515             run-ins, where two or more JSON texts will be interpreted as one JSON
516             text.
517              
518             For this reason, if the default encoder uses L, it will default
519             to not allowing anything but arrays and objects/hashes, at least for the
520             forseeable future (it will change at some point). This might or might not
521             be true for the L module, so this might cause a security issue.
522              
523             If you depend on either behaviour, you should create your own json object
524             and pass it in explicitly.
525              
526             =item cbor => L object
527              
528             This is the cbor coder object used by the C read and write types.
529              
530             If you don't supply it, then AnyEvent::Handle will create and use a
531             suitable one (on demand), which will write CBOR without using extensions,
532             if possible.
533              
534             Note that you are responsible to depend on the L module if you
535             want to use this functionality, as AnyEvent does not have a dependency on
536             it itself.
537              
538             =back
539              
540             =cut
541              
542             sub new {
543 17     17 1 1965 my $class = shift;
544 17         83 my $self = bless { @_ }, $class;
545              
546 17 100       67 if ($self->{fh}) {
    50          
547 11         36 $self->_start;
548 11 50       37 return unless $self->{fh}; # could be gone by now
549              
550             } elsif ($self->{connect}) {
551 6         51 require AnyEvent::Socket;
552              
553             $self->{peername} = $self->{connect}[0]
554 6 50       26 unless exists $self->{peername};
555              
556 6         12 $self->{_skip_drain_rbuf} = 1;
557              
558             {
559 6         10 Scalar::Util::weaken (my $self = $self);
  6         25  
560              
561             $self->{_connect} =
562             AnyEvent::Socket::tcp_connect (
563             $self->{connect}[0],
564             $self->{connect}[1],
565             sub {
566 6     6   18 my ($fh, $host, $port, $retry) = @_;
567              
568 6         42 delete $self->{_connect}; # no longer needed
569              
570 6 50       17 if ($fh) {
571 6         14 $self->{fh} = $fh;
572              
573 6         9 delete $self->{_skip_drain_rbuf};
574 6         21 $self->_start;
575              
576             $self->{on_connect}
577             and $self->{on_connect}($self, $host, $port, sub {
578 0         0 delete @$self{qw(fh _tw _rtw _wtw _ww _rw _eof _queue rbuf _wbuf tls _tls_rbuf _tls_wbuf)};
579 0         0 $self->{_skip_drain_rbuf} = 1;
580 0         0 &$retry;
581 6 100       38 });
582              
583             } else {
584 0 0       0 if ($self->{on_connect_error}) {
585 0         0 $self->{on_connect_error}($self, "$!");
586 0 0       0 $self->destroy if $self;
587             } else {
588 0         0 $self->_error ($!, 1);
589             }
590             }
591             },
592             sub {
593 6     6   31 local $self->{fh} = $_[0];
594              
595             $self->{on_prepare}
596 6 50       36 ? $self->{on_prepare}->($self)
597             : ()
598             }
599 6         102 );
600             }
601              
602             } else {
603 0         0 Carp::croak "AnyEvent::Handle: either an existing fh or the connect parameter must be specified";
604             }
605              
606 17         44 $self
607             }
608              
609             sub _start {
610 17     17   38 my ($self) = @_;
611              
612             # too many clueless people try to use udp and similar sockets
613             # with AnyEvent::Handle, do them a favour.
614 17         156 my $type = getsockopt $self->{fh}, Socket::SOL_SOCKET (), Socket::SO_TYPE ();
615 17 50 33     98 Carp::croak "AnyEvent::Handle: only stream sockets supported, anything else will NOT work!"
616             if Socket::SOCK_STREAM () != (unpack "I", $type) && defined $type;
617              
618 17         88 AnyEvent::fh_unblock $self->{fh};
619              
620             $self->{_activity} =
621             $self->{_ractivity} =
622 17         84 $self->{_wactivity} = AE::now;
623              
624 17   50     84 $self->{read_size} ||= 2048;
625             $self->{max_read_size} = $self->{read_size}
626 17 50 50     71 if $self->{read_size} > ($self->{max_read_size} || MAX_READ_SIZE);
627              
628 17 100       60 $self->timeout (delete $self->{timeout} ) if $self->{timeout};
629 17 50       43 $self->rtimeout (delete $self->{rtimeout} ) if $self->{rtimeout};
630 17 50       34 $self->wtimeout (delete $self->{wtimeout} ) if $self->{wtimeout};
631              
632 17 0 33     39 $self->no_delay (delete $self->{no_delay} ) if exists $self->{no_delay} && $self->{no_delay};
633 17 0 33     36 $self->keepalive (delete $self->{keepalive}) if exists $self->{keepalive} && $self->{keepalive};
634              
635 17 50       71 $self->oobinline (exists $self->{oobinline} ? delete $self->{oobinline} : 1);
636              
637             $self->starttls (delete $self->{tls}, delete $self->{tls_ctx})
638 17 100       78 if $self->{tls};
639              
640 17 100       45 $self->on_drain (delete $self->{on_drain} ) if $self->{on_drain};
641              
642             $self->start_read
643 17 100 100     60 if $self->{on_read} || @{ $self->{_queue} };
  16         65  
644              
645 17         815 $self->_drain_wbuf;
646             }
647              
648             sub _error {
649 1     1   5 my ($self, $errno, $fatal, $message) = @_;
650              
651 1         3 $! = $errno;
652 1   33     23 $message ||= "$!";
653              
654 1 50 0     4 if ($self->{on_error}) {
    0          
655 1         5 $self->{on_error}($self, $fatal, $message);
656 1 50       6 $self->destroy if $fatal;
657             } elsif ($self->{fh} || $self->{connect}) {
658 0         0 $self->destroy;
659 0         0 Carp::croak "AnyEvent::Handle uncaught error: $message";
660             }
661             }
662              
663             =item $fh = $handle->fh
664              
665             This method returns the file handle used to create the L object.
666              
667             =cut
668              
669 0     0 1 0 sub fh { $_[0]{fh} }
670              
671             =item $handle->on_error ($cb)
672              
673             Replace the current C callback (see the C constructor argument).
674              
675             =cut
676              
677             sub on_error {
678 0     0 1 0 $_[0]{on_error} = $_[1];
679             }
680              
681             =item $handle->on_eof ($cb)
682              
683             Replace the current C callback (see the C constructor argument).
684              
685             =cut
686              
687             sub on_eof {
688 0     0 1 0 $_[0]{on_eof} = $_[1];
689             }
690              
691             =item $handle->on_timeout ($cb)
692              
693             =item $handle->on_rtimeout ($cb)
694              
695             =item $handle->on_wtimeout ($cb)
696              
697             Replace the current C, C or C
698             callback, or disables the callback (but not the timeout) if C<$cb> =
699             C. See the C constructor argument and method.
700              
701             =cut
702              
703             # see below
704              
705             =item $handle->autocork ($boolean)
706              
707             Enables or disables the current autocork behaviour (see C
708             constructor argument). Changes will only take effect on the next write.
709              
710             =cut
711              
712             sub autocork {
713 0     0 1 0 $_[0]{autocork} = $_[1];
714             }
715              
716             =item $handle->no_delay ($boolean)
717              
718             Enables or disables the C setting (see constructor argument of
719             the same name for details).
720              
721             =cut
722              
723             sub no_delay {
724 0     0 1 0 $_[0]{no_delay} = $_[1];
725              
726             setsockopt $_[0]{fh}, Socket::IPPROTO_TCP (), Socket::TCP_NODELAY (), int $_[1]
727 0 0       0 if $_[0]{fh};
728             }
729              
730             =item $handle->keepalive ($boolean)
731              
732             Enables or disables the C setting (see constructor argument of
733             the same name for details).
734              
735             =cut
736              
737             sub keepalive {
738 0     0 1 0 $_[0]{keepalive} = $_[1];
739              
740 0         0 eval {
741 0         0 local $SIG{__DIE__};
742             setsockopt $_[0]{fh}, Socket::SOL_SOCKET (), Socket::SO_KEEPALIVE (), int $_[1]
743 0 0       0 if $_[0]{fh};
744             };
745             }
746              
747             =item $handle->oobinline ($boolean)
748              
749             Enables or disables the C setting (see constructor argument of
750             the same name for details).
751              
752             =cut
753              
754             sub oobinline {
755 17     17 1 38 $_[0]{oobinline} = $_[1];
756              
757 17         26 eval {
758 17         60 local $SIG{__DIE__};
759             setsockopt $_[0]{fh}, Socket::SOL_SOCKET (), Socket::SO_OOBINLINE (), int $_[1]
760 17 50       196 if $_[0]{fh};
761             };
762             }
763              
764             =item $handle->on_starttls ($cb)
765              
766             Replace the current C callback (see the C constructor argument).
767              
768             =cut
769              
770             sub on_starttls {
771 0     0 1 0 $_[0]{on_starttls} = $_[1];
772             }
773              
774             =item $handle->on_stoptls ($cb)
775              
776             Replace the current C callback (see the C constructor argument).
777              
778             =cut
779              
780             sub on_stoptls {
781 0     0 1 0 $_[0]{on_stoptls} = $_[1];
782             }
783              
784             =item $handle->rbuf_max ($max_octets)
785              
786             Configures the C setting (C disables it).
787              
788             =item $handle->wbuf_max ($max_octets)
789              
790             Configures the C setting (C disables it).
791              
792             =cut
793              
794             sub rbuf_max {
795 0     0 1 0 $_[0]{rbuf_max} = $_[1];
796             }
797              
798             sub wbuf_max {
799 0     0 1 0 $_[0]{wbuf_max} = $_[1];
800             }
801              
802             #############################################################################
803              
804             =item $handle->timeout ($seconds)
805              
806             =item $handle->rtimeout ($seconds)
807              
808             =item $handle->wtimeout ($seconds)
809              
810             Configures (or disables) the inactivity timeout.
811              
812             The timeout will be checked instantly, so this method might destroy the
813             handle before it returns.
814              
815             =item $handle->timeout_reset
816              
817             =item $handle->rtimeout_reset
818              
819             =item $handle->wtimeout_reset
820              
821             Reset the activity timeout, as if data was received or sent.
822              
823             These methods are cheap to call.
824              
825             =cut
826              
827             for my $dir ("", "r", "w") {
828             my $timeout = "${dir}timeout";
829             my $tw = "_${dir}tw";
830             my $on_timeout = "on_${dir}timeout";
831             my $activity = "_${dir}activity";
832             my $cb;
833              
834             *$on_timeout = sub {
835 0     0   0 $_[0]{$on_timeout} = $_[1];
836             };
837              
838             *$timeout = sub {
839 10     10   17 my ($self, $new_value) = @_;
840              
841 10 50       22 $new_value >= 0
842             or Carp::croak "AnyEvent::Handle->$timeout called with negative timeout ($new_value), caught";
843              
844 10         17 $self->{$timeout} = $new_value;
845 10         16 delete $self->{$tw}; &$cb;
  10         25  
846             };
847              
848             *{"${dir}timeout_reset"} = sub {
849 0     0   0 $_[0]{$activity} = AE::now;
850             };
851              
852             # main workhorse:
853             # reset the timeout watcher, as neccessary
854             # also check for time-outs
855             $cb = sub {
856             my ($self) = @_;
857              
858             if ($self->{$timeout} && $self->{fh}) {
859             my $NOW = AE::now;
860              
861             # when would the timeout trigger?
862             my $after = $self->{$activity} + $self->{$timeout} - $NOW;
863              
864             # now or in the past already?
865             if ($after <= 0) {
866             $self->{$activity} = $NOW;
867              
868             if ($self->{$on_timeout}) {
869             $self->{$on_timeout}($self);
870             } else {
871             $self->_error (Errno::ETIMEDOUT);
872             }
873              
874             # callback could have changed timeout value, optimise
875             return unless $self->{$timeout};
876              
877             # calculate new after
878             $after = $self->{$timeout};
879             }
880              
881             Scalar::Util::weaken $self;
882             return unless $self; # ->error could have destroyed $self
883              
884             $self->{$tw} ||= AE::timer $after, 0, sub {
885             delete $self->{$tw};
886             $cb->($self);
887             };
888             } else {
889             delete $self->{$tw};
890             }
891             }
892             }
893              
894             #############################################################################
895              
896             =back
897              
898             =head2 WRITE QUEUE
899              
900             AnyEvent::Handle manages two queues per handle, one for writing and one
901             for reading.
902              
903             The write queue is very simple: you can add data to its end, and
904             AnyEvent::Handle will automatically try to get rid of it for you.
905              
906             When data could be written and the write buffer is shorter then the low
907             water mark, the C callback will be invoked once.
908              
909             =over 4
910              
911             =item $handle->on_drain ($cb)
912              
913             Sets the C callback or clears it (see the description of
914             C in the constructor).
915              
916             This method may invoke callbacks (and therefore the handle might be
917             destroyed after it returns).
918              
919             =cut
920              
921             sub on_drain {
922 13     13 1 81 my ($self, $cb) = @_;
923              
924 13         21 $self->{on_drain} = $cb;
925              
926             $cb->($self)
927 13 100 100     84 if $cb && $self->{low_water_mark} >= (length $self->{wbuf}) + (length $self->{_tls_wbuf});
928             }
929              
930             =item $handle->push_write ($data)
931              
932             Queues the given scalar to be written. You can push as much data as
933             you want (only limited by the available memory and C), as
934             C buffers it independently of the kernel.
935              
936             This method may invoke callbacks (and therefore the handle might be
937             destroyed after it returns).
938              
939             =cut
940              
941             sub _drain_wbuf {
942 361     361   808 my ($self) = @_;
943              
944 361 100 100     2004 if (!$self->{_ww} && length $self->{wbuf}) {
945              
946 344         1133 Scalar::Util::weaken $self;
947              
948             my $cb = sub {
949 344     344   11680 my $len = syswrite $self->{fh}, $self->{wbuf};
950              
951 344 50 0     1345 if (defined $len) {
    0 0        
      0        
952 344         835 substr $self->{wbuf}, 0, $len, "";
953              
954 344         1292 $self->{_activity} = $self->{_wactivity} = AE::now;
955              
956             $self->{on_drain}($self)
957             if $self->{low_water_mark} >= (length $self->{wbuf}) + (length $self->{_tls_wbuf})
958 344 100 100     2186 && $self->{on_drain};
959              
960 344 100       1056 delete $self->{_ww} unless length $self->{wbuf};
961             } elsif ($! != EAGAIN && $! != EINTR && $! != EWOULDBLOCK && $! != WSAEWOULDBLOCK) {
962 0         0 $self->_error ($!, 1);
963             }
964 344         2086 };
965              
966             # try to write data immediately
967 344 50       1414 $cb->() unless $self->{autocork};
968              
969             # if still data left in wbuf, we need to poll
970             $self->{_ww} = AE::io $self->{fh}, 1, $cb
971 344 100       681 if length $self->{wbuf};
972              
973 344 50 33     3075 if (
974             defined $self->{wbuf_max}
975             && $self->{wbuf_max} < length $self->{wbuf}
976             ) {
977 0         0 $self->_error (Errno::ENOSPC, 1), return;
978             }
979             };
980             }
981              
982             our %WH;
983              
984             # deprecated
985             sub register_write_type($$) {
986 35     35 0 65 $WH{$_[0]} = $_[1];
987             }
988              
989             sub push_write {
990 274     274 1 131422 my $self = shift;
991              
992 274 100       1026 if (@_ > 1) {
993 132         253 my $type = shift;
994              
995 132   33     1057 @_ = ($WH{$type} ||= _load_func "$type\::anyevent_write_type"
996             or Carp::croak "unsupported/unloadable type '$type' passed to AnyEvent::Handle::push_write")
997             ->($self, @_);
998             }
999              
1000             # we downgrade here to avoid hard-to-track-down bugs,
1001             # and diagnose the problem earlier and better.
1002              
1003 274 100       1005 if ($self->{tls}) {
1004 262         3030 utf8::downgrade $self->{_tls_wbuf} .= $_[0];
1005 262 100       972 &_dotls ($self) if $self->{fh};
1006             } else {
1007 12         682 utf8::downgrade $self->{wbuf} .= $_[0];
1008 12 100       98 $self->_drain_wbuf if $self->{fh};
1009             }
1010             }
1011              
1012             =item $handle->push_write (type => @args)
1013              
1014             Instead of formatting your data yourself, you can also let this module
1015             do the job by specifying a type and type-specific arguments. You
1016             can also specify the (fully qualified) name of a package, in which
1017             case AnyEvent tries to load the package and then expects to find the
1018             C function inside (see "custom write types", below).
1019              
1020             Predefined types are (if you have ideas for additional types, feel free to
1021             drop by and tell us):
1022              
1023             =over 4
1024              
1025             =item netstring => $string
1026              
1027             Formats the given value as netstring
1028             (http://cr.yp.to/proto/netstrings.txt, this is not a recommendation to use them).
1029              
1030             =cut
1031              
1032             register_write_type netstring => sub {
1033             my ($self, $string) = @_;
1034              
1035             (length $string) . ":$string,"
1036             };
1037              
1038             =item packstring => $format, $data
1039              
1040             An octet string prefixed with an encoded length. The encoding C<$format>
1041             uses the same format as a Perl C format, but must specify a single
1042             integer only (only one of C is allowed, plus an
1043             optional C, C<< < >> or C<< > >> modifier).
1044              
1045             =cut
1046              
1047             register_write_type packstring => sub {
1048             my ($self, $format, $string) = @_;
1049              
1050             pack "$format/a*", $string
1051             };
1052              
1053             =item json => $array_or_hashref
1054              
1055             Encodes the given hash or array reference into a JSON object. Unless you
1056             provide your own JSON object, this means it will be encoded to JSON text
1057             in UTF-8.
1058              
1059             The default encoder might or might not handle every type of JSON value -
1060             it might be limited to arrays and objects for security reasons. See the
1061             C constructor attribute for more details.
1062              
1063             JSON objects (and arrays) are self-delimiting, so if you only use arrays
1064             and hashes, you can write JSON at one end of a handle and read them at the
1065             other end without using any additional framing.
1066              
1067             The JSON text generated by the default encoder is guaranteed not to
1068             contain any newlines: While this module doesn't need delimiters after or
1069             between JSON texts to be able to read them, many other languages depend on
1070             them.
1071              
1072             A simple RPC protocol that interoperates easily with other languages is
1073             to send JSON arrays (or objects, although arrays are usually the better
1074             choice as they mimic how function argument passing works) and a newline
1075             after each JSON text:
1076              
1077             $handle->push_write (json => ["method", "arg1", "arg2"]); # whatever
1078             $handle->push_write ("\012");
1079            
1080             An AnyEvent::Handle receiver would simply use the C read type and
1081             rely on the fact that the newline will be skipped as leading whitespace:
1082              
1083             $handle->push_read (json => sub { my $array = $_[1]; ... });
1084              
1085             Other languages could read single lines terminated by a newline and pass
1086             this line into their JSON decoder of choice.
1087              
1088             =item cbor => $perl_scalar
1089              
1090             Encodes the given scalar into a CBOR value. Unless you provide your own
1091             L object, this means it will be encoded to a CBOR string not
1092             using any extensions, if possible.
1093              
1094             CBOR values are self-delimiting, so you can write CBOR at one end of
1095             a handle and read them at the other end without using any additional
1096             framing.
1097              
1098             A simple nd very very fast RPC protocol that interoperates with
1099             other languages is to send CBOR and receive CBOR values (arrays are
1100             recommended):
1101              
1102             $handle->push_write (cbor => ["method", "arg1", "arg2"]); # whatever
1103            
1104             An AnyEvent::Handle receiver would simply use the C read type:
1105              
1106             $handle->push_read (cbor => sub { my $array = $_[1]; ... });
1107              
1108             =cut
1109              
1110             sub json_coder() {
1111 0         0 eval { require JSON::XS; JSON::XS->new->utf8 }
  0         0  
1112 0 0   0 0 0 || do { require JSON::PP; JSON::PP->new->utf8 }
  0         0  
  0         0  
1113             }
1114              
1115             register_write_type json => sub {
1116             my ($self, $ref) = @_;
1117              
1118             ($self->{json} ||= json_coder)
1119             ->encode ($ref)
1120             };
1121              
1122             sub cbor_coder() {
1123 0     0 0 0 require CBOR::XS;
1124 0         0 CBOR::XS->new
1125             }
1126              
1127             register_write_type cbor => sub {
1128             my ($self, $scalar) = @_;
1129              
1130             ($self->{cbor} ||= cbor_coder)
1131             ->encode ($scalar)
1132             };
1133              
1134             =item storable => $reference
1135              
1136             Freezes the given reference using L and writes it to the
1137             handle. Uses the C format.
1138              
1139             =cut
1140              
1141             register_write_type storable => sub {
1142             my ($self, $ref) = @_;
1143              
1144             require Storable unless $Storable::VERSION;
1145              
1146             pack "w/a*", Storable::nfreeze ($ref)
1147             };
1148              
1149             =back
1150              
1151             =item $handle->push_shutdown
1152              
1153             Sometimes you know you want to close the socket after writing your data
1154             before it was actually written. One way to do that is to replace your
1155             C handler by a callback that shuts down the socket (and set
1156             C to C<0>). This method is a shorthand for just that, and
1157             replaces the C callback with:
1158              
1159             sub { shutdown $_[0]{fh}, 1 }
1160              
1161             This simply shuts down the write side and signals an EOF condition to the
1162             the peer.
1163              
1164             You can rely on the normal read queue and C handling
1165             afterwards. This is the cleanest way to close a connection.
1166              
1167             This method may invoke callbacks (and therefore the handle might be
1168             destroyed after it returns).
1169              
1170             =cut
1171              
1172             sub push_shutdown {
1173 0     0 1 0 my ($self) = @_;
1174              
1175 0         0 delete $self->{low_water_mark};
1176 0     0   0 $self->on_drain (sub { shutdown $_[0]{fh}, 1 });
  0         0  
1177             }
1178              
1179             =item custom write types - Package::anyevent_write_type $handle, @args
1180              
1181             Instead of one of the predefined types, you can also specify the name of
1182             a package. AnyEvent will try to load the package and then expects to find
1183             a function named C inside. If it isn't found, it
1184             progressively tries to load the parent package until it either finds the
1185             function (good) or runs out of packages (bad).
1186              
1187             Whenever the given C is used, C will the function with
1188             the handle object and the remaining arguments.
1189              
1190             The function is supposed to return a single octet string that will be
1191             appended to the write buffer, so you can mentally treat this function as a
1192             "arguments to on-the-wire-format" converter.
1193              
1194             Example: implement a custom write type C that joins the remaining
1195             arguments using the first one.
1196              
1197             $handle->push_write (My::Type => " ", 1,2,3);
1198              
1199             # uses the following package, which can be defined in the "My::Type" or in
1200             # the "My" modules to be auto-loaded, or just about anywhere when the
1201             # My::Type::anyevent_write_type is defined before invoking it.
1202              
1203             package My::Type;
1204              
1205             sub anyevent_write_type {
1206             my ($handle, $delim, @args) = @_;
1207              
1208             join $delim, @args
1209             }
1210              
1211             =cut
1212              
1213             #############################################################################
1214              
1215             =back
1216              
1217             =head2 READ QUEUE
1218              
1219             AnyEvent::Handle manages two queues per handle, one for writing and one
1220             for reading.
1221              
1222             The read queue is more complex than the write queue. It can be used in two
1223             ways, the "simple" way, using only C and the "complex" way, using
1224             a queue.
1225              
1226             In the simple case, you just install an C callback and whenever
1227             new data arrives, it will be called. You can then remove some data (if
1228             enough is there) from the read buffer (C<< $handle->rbuf >>). Or you can
1229             leave the data there if you want to accumulate more (e.g. when only a
1230             partial message has been received so far), or change the read queue with
1231             e.g. C.
1232              
1233             In the more complex case, you want to queue multiple callbacks. In this
1234             case, AnyEvent::Handle will call the first queued callback each time new
1235             data arrives (also the first time it is queued) and remove it when it has
1236             done its job (see C, below).
1237              
1238             This way you can, for example, push three line-reads, followed by reading
1239             a chunk of data, and AnyEvent::Handle will execute them in order.
1240              
1241             Example 1: EPP protocol parser. EPP sends 4 byte length info, followed by
1242             the specified number of bytes which give an XML datagram.
1243              
1244             # in the default state, expect some header bytes
1245             $handle->on_read (sub {
1246             # some data is here, now queue the length-header-read (4 octets)
1247             shift->unshift_read (chunk => 4, sub {
1248             # header arrived, decode
1249             my $len = unpack "N", $_[1];
1250              
1251             # now read the payload
1252             shift->unshift_read (chunk => $len, sub {
1253             my $xml = $_[1];
1254             # handle xml
1255             });
1256             });
1257             });
1258              
1259             Example 2: Implement a client for a protocol that replies either with "OK"
1260             and another line or "ERROR" for the first request that is sent, and 64
1261             bytes for the second request. Due to the availability of a queue, we can
1262             just pipeline sending both requests and manipulate the queue as necessary
1263             in the callbacks.
1264              
1265             When the first callback is called and sees an "OK" response, it will
1266             C another line-read. This line-read will be queued I the
1267             64-byte chunk callback.
1268              
1269             # request one, returns either "OK + extra line" or "ERROR"
1270             $handle->push_write ("request 1\015\012");
1271              
1272             # we expect "ERROR" or "OK" as response, so push a line read
1273             $handle->push_read (line => sub {
1274             # if we got an "OK", we have to _prepend_ another line,
1275             # so it will be read before the second request reads its 64 bytes
1276             # which are already in the queue when this callback is called
1277             # we don't do this in case we got an error
1278             if ($_[1] eq "OK") {
1279             $_[0]->unshift_read (line => sub {
1280             my $response = $_[1];
1281             ...
1282             });
1283             }
1284             });
1285              
1286             # request two, simply returns 64 octets
1287             $handle->push_write ("request 2\015\012");
1288              
1289             # simply read 64 bytes, always
1290             $handle->push_read (chunk => 64, sub {
1291             my $response = $_[1];
1292             ...
1293             });
1294              
1295             =over 4
1296              
1297             =cut
1298              
1299             sub _drain_rbuf {
1300 708     708   1229 my ($self) = @_;
1301              
1302             # avoid recursion
1303 708 100       1776 return if $self->{_skip_drain_rbuf};
1304 402         1098 local $self->{_skip_drain_rbuf} = 1;
1305              
1306 402         519 while () {
1307             # we need to use a separate tls read buffer, as we must not receive data while
1308             # we are draining the buffer, and this can only happen with TLS.
1309             $self->{rbuf} .= delete $self->{_tls_rbuf}
1310 786 100       3610 if exists $self->{_tls_rbuf};
1311              
1312 786         1292 my $len = length $self->{rbuf};
1313              
1314 786 100       1062 if (my $cb = shift @{ $self->{_queue} }) {
  786 100       2768  
1315 635 100       1501 unless ($cb->($self)) {
1316             # no progress can be made
1317             # (not enough data and no data forthcoming)
1318             $self->_error (Errno::EPIPE, 1), return
1319 320 100       740 if $self->{_eof};
1320              
1321 319         410 unshift @{ $self->{_queue} }, $cb;
  319         577  
1322 319         659 last;
1323             }
1324             } elsif ($self->{on_read}) {
1325 137 100       392 last unless $len;
1326              
1327 69         293 $self->{on_read}($self);
1328              
1329 69 0 33     352 if (
      33        
1330             $len == length $self->{rbuf} # if no data has been consumed
1331 69         294 && !@{ $self->{_queue} } # and the queue is still empty
1332             && $self->{on_read} # but we still have on_read
1333             ) {
1334             # no further data will arrive
1335             # so no progress can be made
1336             $self->_error (Errno::EPIPE, 1), return
1337 0 0       0 if $self->{_eof};
1338              
1339 0         0 last; # more data might arrive
1340             }
1341             } else {
1342             # read side becomes idle
1343 14 100       41 delete $self->{_rw} unless $self->{tls};
1344 14         25 last;
1345             }
1346             }
1347              
1348 401 100       884 if ($self->{_eof}) {
1349             $self->{on_eof}
1350 6 50       38 ? $self->{on_eof}($self)
1351             : $self->_error (0, 1, "Unexpected end-of-file");
1352              
1353 6         44 return;
1354             }
1355              
1356 395 50 33     919 if (
1357             defined $self->{rbuf_max}
1358             && $self->{rbuf_max} < length $self->{rbuf}
1359             ) {
1360 0         0 $self->_error (Errno::ENOSPC, 1), return;
1361             }
1362              
1363             # may need to restart read watcher
1364 395 100       1624 unless ($self->{_rw}) {
1365             $self->start_read
1366 6 100 66     19 if $self->{on_read} || @{ $self->{_queue} };
  6         25  
1367             }
1368             }
1369              
1370             =item $handle->on_read ($cb)
1371              
1372             This replaces the currently set C callback, or clears it (when
1373             the new callback is C). See the description of C in the
1374             constructor.
1375              
1376             This method may invoke callbacks (and therefore the handle might be
1377             destroyed after it returns).
1378              
1379             =cut
1380              
1381             sub on_read {
1382 1     1 1 14 my ($self, $cb) = @_;
1383              
1384 1         3 $self->{on_read} = $cb;
1385 1 50       5 $self->_drain_rbuf if $cb;
1386             }
1387              
1388             =item $handle->rbuf
1389              
1390             Returns the read buffer (as a modifiable lvalue). You can also access the
1391             read buffer directly as the C<< ->{rbuf} >> member, if you want (this is
1392             much faster, and no less clean).
1393              
1394             The only operation allowed on the read buffer (apart from looking at it)
1395             is removing data from its beginning. Otherwise modifying or appending to
1396             it is not allowed and will lead to hard-to-track-down bugs.
1397              
1398             NOTE: The read buffer should only be used or modified in the C
1399             callback or when C or C are used with a single
1400             callback (i.e. untyped). Typed C and C methods
1401             will manage the read buffer on their own.
1402              
1403             =cut
1404              
1405             sub rbuf : lvalue {
1406             $_[0]{rbuf}
1407 0     0 1 0 }
1408              
1409             =item $handle->push_read ($cb)
1410              
1411             =item $handle->unshift_read ($cb)
1412              
1413             Append the given callback to the end of the queue (C) or
1414             prepend it (C).
1415              
1416             The callback is called each time some additional read data arrives.
1417              
1418             It must check whether enough data is in the read buffer already.
1419              
1420             If not enough data is available, it must return the empty list or a false
1421             value, in which case it will be called repeatedly until enough data is
1422             available (or an error condition is detected).
1423              
1424             If enough data was available, then the callback must remove all data it is
1425             interested in (which can be none at all) and return a true value. After returning
1426             true, it will be removed from the queue.
1427              
1428             These methods may invoke callbacks (and therefore the handle might be
1429             destroyed after it returns).
1430              
1431             =cut
1432              
1433             our %RH;
1434              
1435             sub register_read_type($$) {
1436 70     70 0 137 $RH{$_[0]} = $_[1];
1437             }
1438              
1439             sub push_read {
1440 217     217 1 54982 my $self = shift;
1441 217         336 my $cb = pop;
1442              
1443 217 50       481 if (@_) {
1444 217         342 my $type = shift;
1445              
1446 217   33     994 $cb = ($RH{$type} ||= _load_func "$type\::anyevent_read_type"
1447             or Carp::croak "unsupported/unloadable type '$type' passed to AnyEvent::Handle::push_read")
1448             ->($self, $cb, @_);
1449             }
1450              
1451 217         315 push @{ $self->{_queue} }, $cb;
  217         430  
1452 217         455 $self->_drain_rbuf;
1453             }
1454              
1455             sub unshift_read {
1456 99     99 1 29427 my $self = shift;
1457 99         188 my $cb = pop;
1458              
1459 99 50       350 if (@_) {
1460 99         218 my $type = shift;
1461              
1462 99   33     692 $cb = ($RH{$type} ||= _load_func "$type\::anyevent_read_type"
1463             or Carp::croak "unsupported/unloadable type '$type' passed to AnyEvent::Handle::unshift_read")
1464             ->($self, $cb, @_);
1465             }
1466              
1467 99         241 unshift @{ $self->{_queue} }, $cb;
  99         535  
1468 99         269 $self->_drain_rbuf;
1469             }
1470              
1471             =item $handle->push_read (type => @args, $cb)
1472              
1473             =item $handle->unshift_read (type => @args, $cb)
1474              
1475             Instead of providing a callback that parses the data itself you can chose
1476             between a number of predefined parsing formats, for chunks of data, lines
1477             etc. You can also specify the (fully qualified) name of a package, in
1478             which case AnyEvent tries to load the package and then expects to find the
1479             C function inside (see "custom read types", below).
1480              
1481             Predefined types are (if you have ideas for additional types, feel free to
1482             drop by and tell us):
1483              
1484             =over 4
1485              
1486             =item chunk => $octets, $cb->($handle, $data)
1487              
1488             Invoke the callback only once C<$octets> bytes have been read. Pass the
1489             data read to the callback. The callback will never be called with less
1490             data.
1491              
1492             Example: read 2 bytes.
1493              
1494             $handle->push_read (chunk => 2, sub {
1495             say "yay " . unpack "H*", $_[1];
1496             });
1497              
1498             =cut
1499              
1500             register_read_type chunk => sub {
1501             my ($self, $cb, $len) = @_;
1502              
1503             sub {
1504             $len <= length $_[0]{rbuf} or return;
1505             $cb->($_[0], substr $_[0]{rbuf}, 0, $len, "");
1506             1
1507             }
1508             };
1509              
1510             =item line => [$eol, ]$cb->($handle, $line, $eol)
1511              
1512             The callback will be called only once a full line (including the end of
1513             line marker, C<$eol>) has been read. This line (excluding the end of line
1514             marker) will be passed to the callback as second argument (C<$line>), and
1515             the end of line marker as the third argument (C<$eol>).
1516              
1517             The end of line marker, C<$eol>, can be either a string, in which case it
1518             will be interpreted as a fixed record end marker, or it can be a regex
1519             object (e.g. created by C), in which case it is interpreted as a
1520             regular expression.
1521              
1522             The end of line marker argument C<$eol> is optional, if it is missing (NOT
1523             undef), then C is used (which is good for most internet
1524             protocols).
1525              
1526             Partial lines at the end of the stream will never be returned, as they are
1527             not marked by the end of line marker.
1528              
1529             =cut
1530              
1531             register_read_type line => sub {
1532             my ($self, $cb, $eol) = @_;
1533              
1534             if (@_ < 3) {
1535             # this is faster then the generic code below
1536             sub {
1537             (my $pos = index $_[0]{rbuf}, "\012") >= 0
1538             or return;
1539              
1540             (my $str = substr $_[0]{rbuf}, 0, $pos + 1, "") =~ s/(\015?\012)\Z// or die;
1541             $cb->($_[0], $str, "$1");
1542             1
1543             }
1544             } else {
1545             $eol = quotemeta $eol unless ref $eol;
1546             $eol = qr|^(.*?)($eol)|s;
1547              
1548             sub {
1549             $_[0]{rbuf} =~ s/$eol// or return;
1550              
1551             $cb->($_[0], "$1", "$2");
1552             1
1553             }
1554             }
1555             };
1556              
1557             =item regex => $accept[, $reject[, $skip], $cb->($handle, $data)
1558              
1559             Makes a regex match against the regex object C<$accept> and returns
1560             everything up to and including the match. All the usual regex variables
1561             ($1, %+ etc.) from the regex match are available in the callback.
1562              
1563             Example: read a single line terminated by '\n'.
1564              
1565             $handle->push_read (regex => qr<\n>, sub { ... });
1566              
1567             If C<$reject> is given and not undef, then it determines when the data is
1568             to be rejected: it is matched against the data when the C<$accept> regex
1569             does not match and generates an C error when it matches. This is
1570             useful to quickly reject wrong data (to avoid waiting for a timeout or a
1571             receive buffer overflow).
1572              
1573             Example: expect a single decimal number followed by whitespace, reject
1574             anything else (not the use of an anchor).
1575              
1576             $handle->push_read (regex => qr<^[0-9]+\s>, qr<[^0-9]>, sub { ... });
1577              
1578             If C<$skip> is given and not C, then it will be matched against
1579             the receive buffer when neither C<$accept> nor C<$reject> match,
1580             and everything preceding and including the match will be accepted
1581             unconditionally. This is useful to skip large amounts of data that you
1582             know cannot be matched, so that the C<$accept> or C<$reject> regex do not
1583             have to start matching from the beginning. This is purely an optimisation
1584             and is usually worth it only when you expect more than a few kilobytes.
1585              
1586             Example: expect a http header, which ends at C<\015\012\015\012>. Since we
1587             expect the header to be very large (it isn't in practice, but...), we use
1588             a skip regex to skip initial portions. The skip regex is tricky in that
1589             it only accepts something not ending in either \015 or \012, as these are
1590             required for the accept regex.
1591              
1592             $handle->push_read (regex =>
1593             qr<\015\012\015\012>,
1594             undef, # no reject
1595             qr<^.*[^\015\012]>,
1596             sub { ... });
1597              
1598             =cut
1599              
1600             register_read_type regex => sub {
1601             my ($self, $cb, $accept, $reject, $skip) = @_;
1602              
1603             my $data;
1604             my $rbuf = \$self->{rbuf};
1605              
1606             sub {
1607             # accept
1608             if ($$rbuf =~ $accept) {
1609             $data .= substr $$rbuf, 0, $+[0], "";
1610             $cb->($_[0], $data);
1611             return 1;
1612             }
1613            
1614             # reject
1615             if ($reject && $$rbuf =~ $reject) {
1616             $_[0]->_error (Errno::EBADMSG);
1617             }
1618              
1619             # skip
1620             if ($skip && $$rbuf =~ $skip) {
1621             $data .= substr $$rbuf, 0, $+[0], "";
1622             }
1623              
1624             ()
1625             }
1626             };
1627              
1628             =item netstring => $cb->($handle, $string)
1629              
1630             A netstring (http://cr.yp.to/proto/netstrings.txt, this is not an endorsement).
1631              
1632             Throws an error with C<$!> set to EBADMSG on format violations.
1633              
1634             =cut
1635              
1636             register_read_type netstring => sub {
1637             my ($self, $cb) = @_;
1638              
1639             sub {
1640             unless ($_[0]{rbuf} =~ s/^(0|[1-9][0-9]*)://) {
1641             if ($_[0]{rbuf} =~ /[^0-9]/) {
1642             $_[0]->_error (Errno::EBADMSG);
1643             }
1644             return;
1645             }
1646              
1647             my $len = $1;
1648              
1649             $_[0]->unshift_read (chunk => $len, sub {
1650             my $string = $_[1];
1651             $_[0]->unshift_read (chunk => 1, sub {
1652             if ($_[1] eq ",") {
1653             $cb->($_[0], $string);
1654             } else {
1655             $_[0]->_error (Errno::EBADMSG);
1656             }
1657             });
1658             });
1659              
1660             1
1661             }
1662             };
1663              
1664             =item packstring => $format, $cb->($handle, $string)
1665              
1666             An octet string prefixed with an encoded length. The encoding C<$format>
1667             uses the same format as a Perl C format, but must specify a single
1668             integer only (only one of C is allowed, plus an
1669             optional C, C<< < >> or C<< > >> modifier).
1670              
1671             For example, DNS over TCP uses a prefix of C (2 octet network order),
1672             EPP uses a prefix of C (4 octtes).
1673              
1674             Example: read a block of data prefixed by its length in BER-encoded
1675             format (very efficient).
1676              
1677             $handle->push_read (packstring => "w", sub {
1678             my ($handle, $data) = @_;
1679             });
1680              
1681             =cut
1682              
1683             register_read_type packstring => sub {
1684             my ($self, $cb, $format) = @_;
1685              
1686             sub {
1687             # when we can use 5.10 we can use ".", but for 5.8 we use the re-pack method
1688             defined (my $len = eval { unpack $format, $_[0]{rbuf} })
1689             or return;
1690              
1691             $format = length pack $format, $len;
1692              
1693             # bypass unshift if we already have the remaining chunk
1694             if ($format + $len <= length $_[0]{rbuf}) {
1695             my $data = substr $_[0]{rbuf}, $format, $len;
1696             substr $_[0]{rbuf}, 0, $format + $len, "";
1697             $cb->($_[0], $data);
1698             } else {
1699             # remove prefix
1700             substr $_[0]{rbuf}, 0, $format, "";
1701              
1702             # read remaining chunk
1703             $_[0]->unshift_read (chunk => $len, $cb);
1704             }
1705              
1706             1
1707             }
1708             };
1709              
1710             =item json => $cb->($handle, $hash_or_arrayref)
1711              
1712             Reads a JSON object or array, decodes it and passes it to the
1713             callback. When a parse error occurs, an C error will be raised.
1714              
1715             If a C object was passed to the constructor, then that will be
1716             used for the final decode, otherwise it will create a L or
1717             L coder object expecting UTF-8.
1718              
1719             This read type uses the incremental parser available with JSON version
1720             2.09 (and JSON::XS version 2.2) and above.
1721              
1722             Since JSON texts are fully self-delimiting, the C read and write
1723             types are an ideal simple RPC protocol: just exchange JSON datagrams. See
1724             the C write type description, above, for an actual example.
1725              
1726             =cut
1727              
1728             register_read_type json => sub {
1729             my ($self, $cb) = @_;
1730              
1731             my $json = $self->{json} ||= json_coder;
1732              
1733             my $data;
1734              
1735             sub {
1736             my $ref = eval { $json->incr_parse ($_[0]{rbuf}) };
1737              
1738             if ($ref) {
1739             $_[0]{rbuf} = $json->incr_text;
1740             $json->incr_text = "";
1741             $cb->($_[0], $ref);
1742              
1743             1
1744             } elsif ($@) {
1745             # error case
1746             $json->incr_skip;
1747              
1748             $_[0]{rbuf} = $json->incr_text;
1749             $json->incr_text = "";
1750              
1751             $_[0]->_error (Errno::EBADMSG);
1752              
1753             ()
1754             } else {
1755             $_[0]{rbuf} = "";
1756              
1757             ()
1758             }
1759             }
1760             };
1761              
1762             =item cbor => $cb->($handle, $scalar)
1763              
1764             Reads a CBOR value, decodes it and passes it to the callback. When a parse
1765             error occurs, an C error will be raised.
1766              
1767             If a L object was passed to the constructor, then that will be
1768             used for the final decode, otherwise it will create a CBOR coder without
1769             enabling any options.
1770              
1771             You have to provide a dependency to L on your own: this module
1772             will load the L module, but AnyEvent does not depend on it
1773             itself.
1774              
1775             Since CBOR values are fully self-delimiting, the C read and write
1776             types are an ideal simple RPC protocol: just exchange CBOR datagrams. See
1777             the C write type description, above, for an actual example.
1778              
1779             =cut
1780              
1781             register_read_type cbor => sub {
1782             my ($self, $cb) = @_;
1783              
1784             my $cbor = $self->{cbor} ||= cbor_coder;
1785              
1786             my $data;
1787              
1788             sub {
1789             my (@value) = eval { $cbor->incr_parse ($_[0]{rbuf}) };
1790              
1791             if (@value) {
1792             $cb->($_[0], @value);
1793              
1794             1
1795             } elsif ($@) {
1796             # error case
1797             $cbor->incr_reset;
1798              
1799             $_[0]->_error (Errno::EBADMSG);
1800              
1801             ()
1802             } else {
1803             ()
1804             }
1805             }
1806             };
1807              
1808             =item storable => $cb->($handle, $ref)
1809              
1810             Deserialises a L frozen representation as written by the
1811             C write type (BER-encoded length prefix followed by nfreeze'd
1812             data).
1813              
1814             Raises C error if the data could not be decoded.
1815              
1816             =cut
1817              
1818             register_read_type storable => sub {
1819             my ($self, $cb) = @_;
1820              
1821             require Storable unless $Storable::VERSION;
1822              
1823             sub {
1824             # when we can use 5.10 we can use ".", but for 5.8 we use the re-pack method
1825             defined (my $len = eval { unpack "w", $_[0]{rbuf} })
1826             or return;
1827              
1828             my $format = length pack "w", $len;
1829              
1830             # bypass unshift if we already have the remaining chunk
1831             if ($format + $len <= length $_[0]{rbuf}) {
1832             my $data = substr $_[0]{rbuf}, $format, $len;
1833             substr $_[0]{rbuf}, 0, $format + $len, "";
1834              
1835             eval { $cb->($_[0], Storable::thaw ($data)); 1 }
1836             or return $_[0]->_error (Errno::EBADMSG);
1837             } else {
1838             # remove prefix
1839             substr $_[0]{rbuf}, 0, $format, "";
1840              
1841             # read remaining chunk
1842             $_[0]->unshift_read (chunk => $len, sub {
1843             eval { $cb->($_[0], Storable::thaw ($_[1])); 1 }
1844             or $_[0]->_error (Errno::EBADMSG);
1845             });
1846             }
1847              
1848             1
1849             }
1850             };
1851              
1852             =item tls_detect => $cb->($handle, $detect, $major, $minor)
1853              
1854             Checks the input stream for a valid SSL or TLS handshake TLSPaintext
1855             record without consuming anything. Only SSL version 3 or higher
1856             is handled, up to the fictituous protocol 4.x (but both SSL3+ and
1857             SSL2-compatible framing is supported).
1858              
1859             If it detects that the input data is likely TLS, it calls the callback
1860             with a true value for C<$detect> and the (on-wire) TLS version as second
1861             and third argument (C<$major> is C<3>, and C<$minor> is 0..4 for SSL
1862             3.0, TLS 1.0, 1.1, 1.2 and 1.3, respectively). If it detects the input
1863             to be definitely not TLS, it calls the callback with a false value for
1864             C<$detect>.
1865              
1866             The callback could use this information to decide whether or not to start
1867             TLS negotiation.
1868              
1869             In all cases the data read so far is passed to the following read
1870             handlers.
1871              
1872             Usually you want to use the C read type instead.
1873              
1874             If you want to design a protocol that works in the presence of TLS
1875             dtection, make sure that any non-TLS data doesn't start with the octet 22
1876             (ASCII SYN, 16 hex) or 128-255 (i.e. highest bit set). The checks this
1877             read type does are a bit more strict, but might losen in the future to
1878             accomodate protocol changes.
1879              
1880             This read type does not rely on L (and thus, not on
1881             L).
1882              
1883             =item tls_autostart => [$tls_ctx, ]$tls
1884              
1885             Tries to detect a valid SSL or TLS handshake. If one is detected, it tries
1886             to start tls by calling C with the given arguments.
1887              
1888             In practise, C<$tls> must be C, or a Net::SSLeay context that has
1889             been configured to accept, as servers do not normally send a handshake on
1890             their own and ths cannot be detected in this way.
1891              
1892             See C above for more details.
1893              
1894             Example: give the client a chance to start TLS before accepting a text
1895             line.
1896              
1897             $hdl->push_read (tls_autostart => "accept");
1898             $hdl->push_read (line => sub {
1899             print "received ", ($_[0]{tls} ? "encrypted" : "cleartext"), " <$_[1]>\n";
1900             });
1901              
1902             =cut
1903              
1904             register_read_type tls_detect => sub {
1905             my ($self, $cb) = @_;
1906              
1907             sub {
1908             # this regex matches a full or partial tls record
1909             if (
1910             # ssl3+: type(22=handshake) major(=3) minor(any) length_hi
1911             $self->{rbuf} =~ /^(?:\z| \x16 (\z| [\x03\x04] (?:\z| . (?:\z| [\x00-\x40] ))))/xs
1912             # ssl2 comapatible: len_hi len_lo type(1) major minor dummy(forlength)
1913             or $self->{rbuf} =~ /^(?:\z| [\x80-\xff] (?:\z| . (?:\z| \x01 (\z| [\x03\x04] (?:\z| . (?:\z| . ))))))/xs
1914             ) {
1915             return if 3 != length $1; # partial match, can't decide yet
1916              
1917             # full match, valid TLS record
1918             my ($major, $minor) = unpack "CC", $1;
1919             $cb->($self, "accept", $major, $minor);
1920             } else {
1921             # mismatch == guaranteed not TLS
1922             $cb->($self, undef);
1923             }
1924              
1925             1
1926             }
1927             };
1928              
1929             register_read_type tls_autostart => sub {
1930             my ($self, @tls) = @_;
1931              
1932             $RH{tls_detect}($self, sub {
1933             return unless $_[1];
1934             $_[0]->starttls (@tls);
1935             })
1936             };
1937              
1938             =back
1939              
1940             =item custom read types - Package::anyevent_read_type $handle, $cb, @args
1941              
1942             Instead of one of the predefined types, you can also specify the name
1943             of a package. AnyEvent will try to load the package and then expects to
1944             find a function named C inside. If it isn't found, it
1945             progressively tries to load the parent package until it either finds the
1946             function (good) or runs out of packages (bad).
1947              
1948             Whenever this type is used, C will invoke the function with the
1949             handle object, the original callback and the remaining arguments.
1950              
1951             The function is supposed to return a callback (usually a closure) that
1952             works as a plain read callback (see C<< ->push_read ($cb) >>), so you can
1953             mentally treat the function as a "configurable read type to read callback"
1954             converter.
1955              
1956             It should invoke the original callback when it is done reading (remember
1957             to pass C<$handle> as first argument as all other callbacks do that,
1958             although there is no strict requirement on this).
1959              
1960             For examples, see the source of this module (F
1961             AnyEvent::Handle>, search for C)).
1962              
1963             =item $handle->stop_read
1964              
1965             =item $handle->start_read
1966              
1967             In rare cases you actually do not want to read anything from the
1968             socket. In this case you can call C. Neither C nor
1969             any queued callbacks will be executed then. To start reading again, call
1970             C.
1971              
1972             Note that AnyEvent::Handle will automatically C for you when
1973             you change the C callback or push/unshift a read callback, and it
1974             will automatically C for you when neither C is set nor
1975             there are any read requests in the queue.
1976              
1977             In older versions of this module (<= 5.3), these methods had no effect,
1978             as TLS does not support half-duplex connections. In current versions they
1979             work as expected, as this behaviour is required to avoid certain resource
1980             attacks, where the program would be forced to read (and buffer) arbitrary
1981             amounts of data before being able to send some data. The drawback is that
1982             some readings of the the SSL/TLS specifications basically require this
1983             attack to be working, as SSL/TLS implementations might stall sending data
1984             during a rehandshake.
1985              
1986             As a guideline, during the initial handshake, you should not stop reading,
1987             and as a client, it might cause problems, depending on your application.
1988              
1989             =cut
1990              
1991             sub stop_read {
1992 0     0 1 0 my ($self) = @_;
1993              
1994 0         0 delete $self->{_rw};
1995             }
1996              
1997             sub start_read {
1998 19     19 1 32 my ($self) = @_;
1999              
2000 19 50 66     110 unless ($self->{_rw} || $self->{_eof} || !$self->{fh}) {
      33        
2001 15         62 Scalar::Util::weaken $self;
2002              
2003             $self->{_rw} = AE::io $self->{fh}, 0, sub {
2004 317 100   317   3541 my $rbuf = \($self->{tls} ? my $buf : $self->{rbuf});
2005 317         10340 my $len = sysread $self->{fh}, $$rbuf, $self->{read_size}, length $$rbuf;
2006              
2007 317 100 0     1573 if ($len > 0) {
    50 0        
    0 0        
2008 310         1730 $self->{_activity} = $self->{_ractivity} = AE::now;
2009              
2010 310 100       712 if ($self->{tls}) {
2011 291         2953 Net::SSLeay::BIO_write ($self->{_rbio}, $$rbuf);
2012              
2013 291         1214 &_dotls ($self);
2014             } else {
2015 19         43 $self->_drain_rbuf;
2016             }
2017              
2018 310 100       4450307 if ($len == $self->{read_size}) {
2019 22         48 $self->{read_size} *= 2;
2020             $self->{read_size} = $self->{max_read_size} || MAX_READ_SIZE
2021 22 100 50     422 if $self->{read_size} > ($self->{max_read_size} || MAX_READ_SIZE);
      50        
2022             }
2023              
2024             } elsif (defined $len) {
2025 7         23 delete $self->{_rw};
2026 7         16 $self->{_eof} = 1;
2027 7         22 $self->_drain_rbuf;
2028              
2029             } elsif ($! != EAGAIN && $! != EINTR && $! != EWOULDBLOCK && $! != WSAEWOULDBLOCK) {
2030 0         0 return $self->_error ($!, 1);
2031             }
2032 15         128 };
2033             }
2034             }
2035              
2036             our $ERROR_SYSCALL;
2037             our $ERROR_WANT_READ;
2038              
2039             sub _tls_error {
2040 0     0   0 my ($self, $err) = @_;
2041              
2042 0 0       0 return $self->_error ($!, 1)
2043             if $err == Net::SSLeay::ERROR_SYSCALL ();
2044              
2045 0         0 my $err = Net::SSLeay::ERR_error_string (Net::SSLeay::ERR_get_error ());
2046              
2047             # reduce error string to look less scary
2048 0         0 $err =~ s/^error:[0-9a-fA-F]{8}:[^:]+:([^:]+):/\L$1: /;
2049              
2050 0 0       0 if ($self->{_on_starttls}) {
2051 0         0 (delete $self->{_on_starttls})->($self, undef, $err);
2052 0         0 &_freetls;
2053             } else {
2054 0         0 &_freetls;
2055 0         0 $self->_error (Errno::EPROTO, 1, $err);
2056             }
2057             }
2058              
2059             # poll the write BIO and send the data if applicable
2060             # also decode read data if possible
2061             # this is basiclaly our TLS state machine
2062             # more efficient implementations are possible with openssl,
2063             # but not with the buggy and incomplete Net::SSLeay.
2064             sub _dotls {
2065 559     559   1433 my ($self) = @_;
2066              
2067 559         726 my $tmp;
2068              
2069 559         1912 while (length $self->{_tls_wbuf}) {
2070 375 100       224032 if (($tmp = Net::SSLeay::write ($self->{tls}, $self->{_tls_wbuf})) <= 0) {
2071 10         96 $tmp = Net::SSLeay::get_error ($self->{tls}, $tmp);
2072              
2073 10 0 0     35 return $self->_tls_error ($tmp)
      33        
2074             if $tmp != $ERROR_WANT_READ
2075             && ($tmp != $ERROR_SYSCALL || $!);
2076              
2077 10         23 last;
2078             }
2079              
2080 365         1203 substr $self->{_tls_wbuf}, 0, $tmp, "";
2081             }
2082              
2083 559         205049 while (defined ($tmp = Net::SSLeay::read ($self->{tls}))) {
2084 365 50       1646 unless (length $tmp) {
2085             $self->{_on_starttls}
2086 0 0       0 and (delete $self->{_on_starttls})->($self, undef, "EOF during handshake"); # ???
2087 0         0 &_freetls;
2088              
2089 0 0       0 if ($self->{on_stoptls}) {
2090 0         0 $self->{on_stoptls}($self);
2091 0         0 return;
2092             } else {
2093             # let's treat SSL-eof as we treat normal EOF
2094 0         0 delete $self->{_rw};
2095 0         0 $self->{_eof} = 1;
2096             }
2097             }
2098              
2099 365         1919 $self->{_tls_rbuf} .= $tmp;
2100 365         1542 $self->_drain_rbuf;
2101 365 50       28781 $self->{tls} or return; # tls session might have gone away in callback
2102             }
2103              
2104 559         3125 $tmp = Net::SSLeay::get_error ($self->{tls}, -1); # -1 is not neccessarily correct, but Net::SSLeay doesn't tell us
2105 559 0 0     1301 return $self->_tls_error ($tmp)
      33        
2106             if $tmp != $ERROR_WANT_READ
2107             && ($tmp != $ERROR_SYSCALL || $!);
2108              
2109 559         3066 while (length ($tmp = Net::SSLeay::BIO_read ($self->{_wbio}))) {
2110 333         1338 $self->{wbuf} .= $tmp;
2111 333         1171 $self->_drain_wbuf;
2112 333 50       2240 $self->{tls} or return; # tls session might have gone away in callback
2113             }
2114              
2115             $self->{_on_starttls}
2116             and Net::SSLeay::state ($self->{tls}) == Net::SSLeay::ST_OK ()
2117 559 50 33     2101 and (delete $self->{_on_starttls})->($self, 1, "TLS/SSL connection established");
2118             }
2119              
2120             =item $handle->starttls ($tls[, $tls_ctx])
2121              
2122             Instead of starting TLS negotiation immediately when the AnyEvent::Handle
2123             object is created, you can also do that at a later time by calling
2124             C. See the C constructor argument for general info.
2125              
2126             Starting TLS is currently an asynchronous operation - when you push some
2127             write data and then call C<< ->starttls >> then TLS negotiation will start
2128             immediately, after which the queued write data is then sent. This might
2129             change in future versions, so best make sure you have no outstanding write
2130             data when calling this method.
2131              
2132             The first argument is the same as the C constructor argument (either
2133             C<"connect">, C<"accept"> or an existing Net::SSLeay object).
2134              
2135             The second argument is the optional C object that is used
2136             when AnyEvent::Handle has to create its own TLS connection object, or
2137             a hash reference with C<< key => value >> pairs that will be used to
2138             construct a new context.
2139              
2140             The TLS connection object will end up in C<< $handle->{tls} >>, the TLS
2141             context in C<< $handle->{tls_ctx} >> after this call and can be used or
2142             changed to your liking. Note that the handshake might have already started
2143             when this function returns.
2144              
2145             Due to bugs in OpenSSL, it might or might not be possible to do multiple
2146             handshakes on the same stream. It is best to not attempt to use the
2147             stream after stopping TLS.
2148              
2149             This method may invoke callbacks (and therefore the handle might be
2150             destroyed after it returns).
2151              
2152             =cut
2153              
2154             our %TLS_CACHE; #TODO not yet documented, should we?
2155              
2156             sub starttls {
2157 10     10 1 21 my ($self, $tls, $ctx) = @_;
2158              
2159             Carp::croak "It is an error to call starttls on an AnyEvent::Handle object while TLS is already active, caught"
2160 10 50       18 if $self->{tls};
2161              
2162 10 50       24 unless (defined $AnyEvent::TLS::VERSION) {
2163 0 0       0 eval {
2164 0         0 require Net::SSLeay;
2165 0         0 require AnyEvent::TLS;
2166 0         0 1
2167             } or return $self->_error (Errno::EPROTO, 1, "TLS support not available on this system");
2168             }
2169              
2170 10         19 $self->{tls} = $tls;
2171 10 50       25 $self->{tls_ctx} = $ctx if @_ > 2;
2172              
2173 10 50       20 return unless $self->{fh};
2174              
2175 10         221 $ERROR_SYSCALL = Net::SSLeay::ERROR_SYSCALL ();
2176 10         247 $ERROR_WANT_READ = Net::SSLeay::ERROR_WANT_READ ();
2177              
2178 10         102 $tls = delete $self->{tls};
2179 10         17 $ctx = $self->{tls_ctx};
2180              
2181 10         28 local $Carp::CarpLevel = 1; # skip ourselves when creating a new context or session
2182              
2183 10 50       28 if ("HASH" eq ref $ctx) {
2184 0 0       0 if ($ctx->{cache}) {
2185 0         0 my $key = $ctx+0;
2186 0   0     0 $ctx = $TLS_CACHE{$key} ||= new AnyEvent::TLS %$ctx;
2187             } else {
2188 0         0 $ctx = new AnyEvent::TLS %$ctx;
2189             }
2190             }
2191            
2192 10   33     23 $self->{tls_ctx} = $ctx || TLS_CTX ();
2193 10         42 $self->{tls} = $tls = $self->{tls_ctx}->_get_session ($tls, $self, $self->{peername});
2194              
2195             # basically, this is deep magic (because SSL_read should have the same issues)
2196             # but the openssl maintainers basically said: "trust us, it just works".
2197             # (unfortunately, we have to hardcode constants because the abysmally misdesigned
2198             # and mismaintained ssleay-module didn't offer them for a decade or so).
2199             # http://www.mail-archive.com/openssl-dev@openssl.org/msg22420.html
2200             #
2201             # in short: this is a mess.
2202             #
2203             # note that we do not try to keep the length constant between writes as we are required to do.
2204             # we assume that most (but not all) of this insanity only applies to non-blocking cases,
2205             # and we drive openssl fully in blocking mode here. Or maybe we don't - openssl seems to
2206             # have identity issues in that area.
2207             # Net::SSLeay::set_mode ($ssl,
2208             # (eval { local $SIG{__DIE__}; Net::SSLeay::MODE_ENABLE_PARTIAL_WRITE () } || 1)
2209             # | (eval { local $SIG{__DIE__}; Net::SSLeay::MODE_ACCEPT_MOVING_WRITE_BUFFER () } || 2));
2210 10         46 Net::SSLeay::set_mode ($tls, 1|2);
2211              
2212 10         42 $self->{_rbio} = Net::SSLeay::BIO_new (Net::SSLeay::BIO_s_mem ());
2213 10         28 $self->{_wbio} = Net::SSLeay::BIO_new (Net::SSLeay::BIO_s_mem ());
2214              
2215 10         44 Net::SSLeay::BIO_write ($self->{_rbio}, $self->{rbuf});
2216 10         20 $self->{rbuf} = "";
2217              
2218 10         29 Net::SSLeay::set_bio ($tls, $self->{_rbio}, $self->{_wbio});
2219              
2220 0     0   0 $self->{_on_starttls} = sub { $_[0]{on_starttls}(@_) }
2221 10 50       23 if $self->{on_starttls};
2222              
2223 10         22 &_dotls; # need to trigger the initial handshake
2224 10         31 $self->start_read; # make sure we actually do read
2225             }
2226              
2227             =item $handle->stoptls
2228              
2229             Shuts down the SSL connection - this makes a proper EOF handshake by
2230             sending a close notify to the other side, but since OpenSSL doesn't
2231             support non-blocking shut downs, it is not guaranteed that you can re-use
2232             the stream afterwards.
2233              
2234             This method may invoke callbacks (and therefore the handle might be
2235             destroyed after it returns).
2236              
2237             =cut
2238              
2239             sub stoptls {
2240 0     0 1 0 my ($self) = @_;
2241              
2242 0 0 0     0 if ($self->{tls} && $self->{fh}) {
2243 0         0 Net::SSLeay::shutdown ($self->{tls});
2244              
2245 0         0 &_dotls;
2246              
2247             # # we don't give a shit. no, we do, but we can't. no...#d#
2248             # # we, we... have to use openssl :/#d#
2249             # &_freetls;#d#
2250             }
2251             }
2252              
2253             sub _freetls {
2254 16     16   396 my ($self) = @_;
2255              
2256 16 100       46 return unless $self->{tls};
2257              
2258             $self->{tls_ctx}->_put_session (delete $self->{tls})
2259 10 50       64 if $self->{tls} > 0;
2260            
2261 10         206 delete @$self{qw(_rbio _wbio _tls_wbuf _on_starttls)};
2262             }
2263              
2264             =item $handle->resettls
2265              
2266             This rarely-used method simply resets and TLS state on the handle, usually
2267             causing data loss.
2268              
2269             One case where it may be useful is when you want to skip over the data in
2270             the stream but you are not interested in interpreting it, so data loss is
2271             no concern.
2272              
2273             =cut
2274              
2275             *resettls = \&_freetls;
2276              
2277             sub DESTROY {
2278 16     16   511 my ($self) = @_;
2279              
2280 16         50 &_freetls;
2281              
2282 16 50       49 my $linger = exists $self->{linger} ? $self->{linger} : 3600;
2283              
2284 16 50 66     1042 if ($linger && length $self->{wbuf} && $self->{fh}) {
      66        
2285 1         4 my $fh = delete $self->{fh};
2286 1         364 my $wbuf = delete $self->{wbuf};
2287              
2288 1         57 my @linger;
2289              
2290             push @linger, AE::io $fh, 1, sub {
2291 4     4   167 my $len = syswrite $fh, $wbuf, length $wbuf;
2292              
2293 4 100 0     59 if ($len > 0) {
    50 0        
      0        
      33        
2294 3         293 substr $wbuf, 0, $len, "";
2295             } elsif (defined $len || ($! != EAGAIN && $! != EINTR && $! != EWOULDBLOCK && $! != WSAEWOULDBLOCK)) {
2296 1         16 @linger = (); # end
2297             }
2298 1         13 };
2299             push @linger, AE::timer $linger, 0, sub {
2300 0     0   0 @linger = ();
2301 1         9 };
2302             }
2303             }
2304              
2305             =item $handle->destroy
2306              
2307             Shuts down the handle object as much as possible - this call ensures that
2308             no further callbacks will be invoked and as many resources as possible
2309             will be freed. Any method you will call on the handle object after
2310             destroying it in this way will be silently ignored (and it will return the
2311             empty list).
2312              
2313             Normally, you can just "forget" any references to an AnyEvent::Handle
2314             object and it will simply shut down. This works in fatal error and EOF
2315             callbacks, as well as code outside. It does I work in a read or write
2316             callback, so when you want to destroy the AnyEvent::Handle object from
2317             within such an callback. You I call C<< ->destroy >> explicitly in
2318             that case.
2319              
2320             Destroying the handle object in this way has the advantage that callbacks
2321             will be removed as well, so if those are the only reference holders (as
2322             is common), then one doesn't need to do anything special to break any
2323             reference cycles.
2324              
2325             The handle might still linger in the background and write out remaining
2326             data, as specified by the C option, however.
2327              
2328             =cut
2329              
2330             sub destroy {
2331 1     1 1 4 my ($self) = @_;
2332              
2333 1         5 $self->DESTROY;
2334 1         8 %$self = ();
2335 1         28 bless $self, "AnyEvent::Handle::destroyed";
2336             }
2337              
2338       0     sub AnyEvent::Handle::destroyed::AUTOLOAD {
2339             #nop
2340             }
2341              
2342             =item $handle->destroyed
2343              
2344             Returns false as long as the handle hasn't been destroyed by a call to C<<
2345             ->destroy >>, true otherwise.
2346              
2347             Can be useful to decide whether the handle is still valid after some
2348             callback possibly destroyed the handle. For example, C<< ->push_write >>,
2349             C<< ->starttls >> and other methods can call user callbacks, which in turn
2350             can destroy the handle, so work can be avoided by checking sometimes:
2351              
2352             $hdl->starttls ("accept");
2353             return if $hdl->destroyed;
2354             $hdl->push_write (...
2355              
2356             Note that the call to C will silently be ignored if the handle
2357             has been destroyed, so often you can just ignore the possibility of the
2358             handle being destroyed.
2359              
2360             =cut
2361              
2362 0     0 1   sub destroyed { 0 }
2363 0     0     sub AnyEvent::Handle::destroyed::destroyed { 1 }
2364              
2365             =item AnyEvent::Handle::TLS_CTX
2366              
2367             This function creates and returns the AnyEvent::TLS object used by default
2368             for TLS mode.
2369              
2370             The context is created by calling L without any arguments.
2371              
2372             =cut
2373              
2374             our $TLS_CTX;
2375              
2376             sub TLS_CTX() {
2377 0   0 0 1   $TLS_CTX ||= do {
2378 0           require AnyEvent::TLS;
2379              
2380 0           new AnyEvent::TLS
2381             }
2382             }
2383              
2384             =back
2385              
2386              
2387             =head1 NONFREQUENTLY ASKED QUESTIONS
2388              
2389             =over 4
2390              
2391             =item I C the AnyEvent::Handle reference inside my callback and
2392             still get further invocations!
2393              
2394             That's because AnyEvent::Handle keeps a reference to itself when handling
2395             read or write callbacks.
2396              
2397             It is only safe to "forget" the reference inside EOF or error callbacks,
2398             from within all other callbacks, you need to explicitly call the C<<
2399             ->destroy >> method.
2400              
2401             =item Why is my C callback never called?
2402              
2403             Probably because your C callback is being called instead: When
2404             you have outstanding requests in your read queue, then an EOF is
2405             considered an error as you clearly expected some data.
2406              
2407             To avoid this, make sure you have an empty read queue whenever your handle
2408             is supposed to be "idle" (i.e. connection closes are O.K.). You can set
2409             an C handler that simply pushes the first read requests in the
2410             queue.
2411              
2412             See also the next question, which explains this in a bit more detail.
2413              
2414             =item How can I serve requests in a loop?
2415              
2416             Most protocols consist of some setup phase (authentication for example)
2417             followed by a request handling phase, where the server waits for requests
2418             and handles them, in a loop.
2419              
2420             There are two important variants: The first (traditional, better) variant
2421             handles requests until the server gets some QUIT command, causing it to
2422             close the connection first (highly desirable for a busy TCP server). A
2423             client dropping the connection is an error, which means this variant can
2424             detect an unexpected detection close.
2425              
2426             To handle this case, always make sure you have a non-empty read queue, by
2427             pushing the "read request start" handler on it:
2428              
2429             # we assume a request starts with a single line
2430             my @start_request; @start_request = (line => sub {
2431             my ($hdl, $line) = @_;
2432              
2433             ... handle request
2434              
2435             # push next request read, possibly from a nested callback
2436             $hdl->push_read (@start_request);
2437             });
2438              
2439             # auth done, now go into request handling loop
2440             # now push the first @start_request
2441             $hdl->push_read (@start_request);
2442              
2443             By always having an outstanding C, the handle always expects
2444             some data and raises the C error when the connction is dropped
2445             unexpectedly.
2446              
2447             The second variant is a protocol where the client can drop the connection
2448             at any time. For TCP, this means that the server machine may run out of
2449             sockets easier, and in general, it means you cannot distinguish a protocl
2450             failure/client crash from a normal connection close. Nevertheless, these
2451             kinds of protocols are common (and sometimes even the best solution to the
2452             problem).
2453              
2454             Having an outstanding read request at all times is possible if you ignore
2455             C errors, but this doesn't help with when the client drops the
2456             connection during a request, which would still be an error.
2457              
2458             A better solution is to push the initial request read in an C
2459             callback. This avoids an error, as when the server doesn't expect data
2460             (i.e. is idly waiting for the next request, an EOF will not raise an
2461             error, but simply result in an C callback. It is also a bit slower
2462             and simpler:
2463              
2464             # auth done, now go into request handling loop
2465             $hdl->on_read (sub {
2466             my ($hdl) = @_;
2467              
2468             # called each time we receive data but the read queue is empty
2469             # simply start read the request
2470              
2471             $hdl->push_read (line => sub {
2472             my ($hdl, $line) = @_;
2473              
2474             ... handle request
2475              
2476             # do nothing special when the request has been handled, just
2477             # let the request queue go empty.
2478             });
2479             });
2480              
2481             =item I get different callback invocations in TLS mode/Why can't I pause
2482             reading?
2483              
2484             Unlike, say, TCP, TLS connections do not consist of two independent
2485             communication channels, one for each direction. Or put differently, the
2486             read and write directions are not independent of each other: you cannot
2487             write data unless you are also prepared to read, and vice versa.
2488              
2489             This means that, in TLS mode, you might get C or C
2490             callback invocations when you are not expecting any read data - the reason
2491             is that AnyEvent::Handle always reads in TLS mode.
2492              
2493             During the connection, you have to make sure that you always have a
2494             non-empty read-queue, or an C watcher. At the end of the
2495             connection (or when you no longer want to use it) you can call the
2496             C method.
2497              
2498             =item How do I read data until the other side closes the connection?
2499              
2500             If you just want to read your data into a perl scalar, the easiest way
2501             to achieve this is by setting an C callback that does nothing,
2502             clearing the C callback and in the C callback, the data
2503             will be in C<$_[0]{rbuf}>:
2504              
2505             $handle->on_read (sub { });
2506             $handle->on_eof (undef);
2507             $handle->on_error (sub {
2508             my $data = delete $_[0]{rbuf};
2509             });
2510              
2511             Note that this example removes the C member from the handle object,
2512             which is not normally allowed by the API. It is expressly permitted in
2513             this case only, as the handle object needs to be destroyed afterwards.
2514              
2515             The reason to use C is that TCP connections, due to latencies
2516             and packets loss, might get closed quite violently with an error, when in
2517             fact all data has been received.
2518              
2519             It is usually better to use acknowledgements when transferring data,
2520             to make sure the other side hasn't just died and you got the data
2521             intact. This is also one reason why so many internet protocols have an
2522             explicit QUIT command.
2523              
2524             =item I don't want to destroy the handle too early - how do I wait until
2525             all data has been written?
2526              
2527             After writing your last bits of data, set the C callback
2528             and destroy the handle in there - with the default setting of
2529             C this will be called precisely when all data has been
2530             written to the socket:
2531              
2532             $handle->push_write (...);
2533             $handle->on_drain (sub {
2534             AE::log debug => "All data submitted to the kernel.";
2535             undef $handle;
2536             });
2537              
2538             If you just want to queue some data and then signal EOF to the other side,
2539             consider using C<< ->push_shutdown >> instead.
2540              
2541             =item I want to contact a TLS/SSL server, I don't care about security.
2542              
2543             If your TLS server is a pure TLS server (e.g. HTTPS) that only speaks TLS,
2544             connect to it and then create the AnyEvent::Handle with the C
2545             parameter:
2546              
2547             tcp_connect $host, $port, sub {
2548             my ($fh) = @_;
2549              
2550             my $handle = new AnyEvent::Handle
2551             fh => $fh,
2552             tls => "connect",
2553             on_error => sub { ... };
2554              
2555             $handle->push_write (...);
2556             };
2557              
2558             =item I want to contact a TLS/SSL server, I do care about security.
2559              
2560             Then you should additionally enable certificate verification, including
2561             peername verification, if the protocol you use supports it (see
2562             L, C).
2563              
2564             E.g. for HTTPS:
2565              
2566             tcp_connect $host, $port, sub {
2567             my ($fh) = @_;
2568              
2569             my $handle = new AnyEvent::Handle
2570             fh => $fh,
2571             peername => $host,
2572             tls => "connect",
2573             tls_ctx => { verify => 1, verify_peername => "https" },
2574             ...
2575              
2576             Note that you must specify the hostname you connected to (or whatever
2577             "peername" the protocol needs) as the C argument, otherwise no
2578             peername verification will be done.
2579              
2580             The above will use the system-dependent default set of trusted CA
2581             certificates. If you want to check against a specific CA, add the
2582             C (or C) arguments to C:
2583              
2584             tls_ctx => {
2585             verify => 1,
2586             verify_peername => "https",
2587             ca_file => "my-ca-cert.pem",
2588             },
2589              
2590             =item I want to create a TLS/SSL server, how do I do that?
2591              
2592             Well, you first need to get a server certificate and key. You have
2593             three options: a) ask a CA (buy one, use cacert.org etc.) b) create a
2594             self-signed certificate (cheap. check the search engine of your choice,
2595             there are many tutorials on the net) or c) make your own CA (tinyca2 is a
2596             nice program for that purpose).
2597              
2598             Then create a file with your private key (in PEM format, see
2599             L), followed by the certificate (also in PEM format). The
2600             file should then look like this:
2601              
2602             -----BEGIN RSA PRIVATE KEY-----
2603             ...header data
2604             ... lots of base64'y-stuff
2605             -----END RSA PRIVATE KEY-----
2606              
2607             -----BEGIN CERTIFICATE-----
2608             ... lots of base64'y-stuff
2609             -----END CERTIFICATE-----
2610              
2611             The important bits are the "PRIVATE KEY" and "CERTIFICATE" parts. Then
2612             specify this file as C:
2613              
2614             tcp_server undef, $port, sub {
2615             my ($fh) = @_;
2616              
2617             my $handle = new AnyEvent::Handle
2618             fh => $fh,
2619             tls => "accept",
2620             tls_ctx => { cert_file => "my-server-keycert.pem" },
2621             ...
2622              
2623             When you have intermediate CA certificates that your clients might not
2624             know about, just append them to the C.
2625              
2626             =back
2627              
2628             =head1 SUBCLASSING AnyEvent::Handle
2629              
2630             In many cases, you might want to subclass AnyEvent::Handle.
2631              
2632             To make this easier, a given version of AnyEvent::Handle uses these
2633             conventions:
2634              
2635             =over 4
2636              
2637             =item * all constructor arguments become object members.
2638              
2639             At least initially, when you pass a C-argument to the constructor it
2640             will end up in C<< $handle->{tls} >>. Those members might be changed or
2641             mutated later on (for example C will hold the TLS connection object).
2642              
2643             =item * other object member names are prefixed with an C<_>.
2644              
2645             All object members not explicitly documented (internal use) are prefixed
2646             with an underscore character, so the remaining non-C<_>-namespace is free
2647             for use for subclasses.
2648              
2649             =item * all members not documented here and not prefixed with an underscore
2650             are free to use in subclasses.
2651              
2652             Of course, new versions of AnyEvent::Handle may introduce more "public"
2653             member variables, but that's just life. At least it is documented.
2654              
2655             =back
2656              
2657             =head1 AUTHOR
2658              
2659             Robin Redeker C<< >>, Marc Lehmann .
2660              
2661             =cut
2662              
2663             1
2664