ViewVC Help
View File | Revision Log | Show Annotations | Download File
/cvs/AnyEvent/lib/AnyEvent/Handle.pm
Revision: 1.35
Committed: Mon May 26 05:46:35 2008 UTC (15 years, 11 months ago) by root
Branch: MAIN
CVS Tags: rel-4_04, rel-4_05
Changes since 1.34: +7 -2 lines
Log Message:
*** empty log message ***

File Contents

# Content
1 package AnyEvent::Handle;
2
3 no warnings;
4 use strict;
5
6 use AnyEvent ();
7 use AnyEvent::Util qw(WSAWOULDBLOCK);
8 use Scalar::Util ();
9 use Carp ();
10 use Fcntl ();
11 use Errno qw/EAGAIN EINTR/;
12
13 =head1 NAME
14
15 AnyEvent::Handle - non-blocking I/O on file handles via AnyEvent
16
17 =cut
18
19 our $VERSION = '0.04';
20
21 =head1 SYNOPSIS
22
23 use AnyEvent;
24 use AnyEvent::Handle;
25
26 my $cv = AnyEvent->condvar;
27
28 my $handle =
29 AnyEvent::Handle->new (
30 fh => \*STDIN,
31 on_eof => sub {
32 $cv->broadcast;
33 },
34 );
35
36 # send some request line
37 $handle->push_write ("getinfo\015\012");
38
39 # read the response line
40 $handle->push_read (line => sub {
41 my ($handle, $line) = @_;
42 warn "read line <$line>\n";
43 $cv->send;
44 });
45
46 $cv->recv;
47
48 =head1 DESCRIPTION
49
50 This module is a helper module to make it easier to do event-based I/O on
51 filehandles. For utility functions for doing non-blocking connects and accepts
52 on sockets see L<AnyEvent::Util>.
53
54 In the following, when the documentation refers to of "bytes" then this
55 means characters. As sysread and syswrite are used for all I/O, their
56 treatment of characters applies to this module as well.
57
58 All callbacks will be invoked with the handle object as their first
59 argument.
60
61 =head1 METHODS
62
63 =over 4
64
65 =item B<new (%args)>
66
67 The constructor supports these arguments (all as key => value pairs).
68
69 =over 4
70
71 =item fh => $filehandle [MANDATORY]
72
73 The filehandle this L<AnyEvent::Handle> object will operate on.
74
75 NOTE: The filehandle will be set to non-blocking (using
76 AnyEvent::Util::fh_nonblocking).
77
78 =item on_eof => $cb->($self)
79
80 Set the callback to be called on EOF.
81
82 While not mandatory, it is highly recommended to set an eof callback,
83 otherwise you might end up with a closed socket while you are still
84 waiting for data.
85
86 =item on_error => $cb->($self)
87
88 This is the fatal error callback, that is called when, well, a fatal error
89 occurs, such as not being able to resolve the hostname, failure to connect
90 or a read error.
91
92 The object will not be in a usable state when this callback has been
93 called.
94
95 On callback entrance, the value of C<$!> contains the operating system
96 error (or C<ENOSPC>, C<EPIPE> or C<EBADMSG>).
97
98 While not mandatory, it is I<highly> recommended to set this callback, as
99 you will not be notified of errors otherwise. The default simply calls
100 die.
101
102 =item on_read => $cb->($self)
103
104 This sets the default read callback, which is called when data arrives
105 and no read request is in the queue.
106
107 To access (and remove data from) the read buffer, use the C<< ->rbuf >>
108 method or access the C<$self->{rbuf}> member directly.
109
110 When an EOF condition is detected then AnyEvent::Handle will first try to
111 feed all the remaining data to the queued callbacks and C<on_read> before
112 calling the C<on_eof> callback. If no progress can be made, then a fatal
113 error will be raised (with C<$!> set to C<EPIPE>).
114
115 =item on_drain => $cb->()
116
117 This sets the callback that is called when the write buffer becomes empty
118 (or when the callback is set and the buffer is empty already).
119
120 To append to the write buffer, use the C<< ->push_write >> method.
121
122 =item rbuf_max => <bytes>
123
124 If defined, then a fatal error will be raised (with C<$!> set to C<ENOSPC>)
125 when the read buffer ever (strictly) exceeds this size. This is useful to
126 avoid denial-of-service attacks.
127
128 For example, a server accepting connections from untrusted sources should
129 be configured to accept only so-and-so much data that it cannot act on
130 (for example, when expecting a line, an attacker could send an unlimited
131 amount of data without a callback ever being called as long as the line
132 isn't finished).
133
134 =item read_size => <bytes>
135
136 The default read block size (the amount of bytes this module will try to read
137 on each [loop iteration). Default: C<4096>.
138
139 =item low_water_mark => <bytes>
140
141 Sets the amount of bytes (default: C<0>) that make up an "empty" write
142 buffer: If the write reaches this size or gets even samller it is
143 considered empty.
144
145 =item tls => "accept" | "connect" | Net::SSLeay::SSL object
146
147 When this parameter is given, it enables TLS (SSL) mode, that means it
148 will start making tls handshake and will transparently encrypt/decrypt
149 data.
150
151 TLS mode requires Net::SSLeay to be installed (it will be loaded
152 automatically when you try to create a TLS handle).
153
154 For the TLS server side, use C<accept>, and for the TLS client side of a
155 connection, use C<connect> mode.
156
157 You can also provide your own TLS connection object, but you have
158 to make sure that you call either C<Net::SSLeay::set_connect_state>
159 or C<Net::SSLeay::set_accept_state> on it before you pass it to
160 AnyEvent::Handle.
161
162 See the C<starttls> method if you need to start TLs negotiation later.
163
164 =item tls_ctx => $ssl_ctx
165
166 Use the given Net::SSLeay::CTX object to create the new TLS connection
167 (unless a connection object was specified directly). If this parameter is
168 missing, then AnyEvent::Handle will use C<AnyEvent::Handle::TLS_CTX>.
169
170 =back
171
172 =cut
173
174 sub new {
175 my $class = shift;
176
177 my $self = bless { @_ }, $class;
178
179 $self->{fh} or Carp::croak "mandatory argument fh is missing";
180
181 AnyEvent::Util::fh_nonblocking $self->{fh}, 1;
182
183 if ($self->{tls}) {
184 require Net::SSLeay;
185 $self->starttls (delete $self->{tls}, delete $self->{tls_ctx});
186 }
187
188 $self->on_eof (delete $self->{on_eof} ) if $self->{on_eof};
189 $self->on_error (delete $self->{on_error}) if $self->{on_error};
190 $self->on_drain (delete $self->{on_drain}) if $self->{on_drain};
191 $self->on_read (delete $self->{on_read} ) if $self->{on_read};
192
193 $self->start_read;
194
195 $self
196 }
197
198 sub _shutdown {
199 my ($self) = @_;
200
201 delete $self->{rw};
202 delete $self->{ww};
203 delete $self->{fh};
204 }
205
206 sub error {
207 my ($self) = @_;
208
209 {
210 local $!;
211 $self->_shutdown;
212 }
213
214 if ($self->{on_error}) {
215 $self->{on_error}($self);
216 } else {
217 Carp::croak "AnyEvent::Handle uncaught fatal error: $!";
218 }
219 }
220
221 =item $fh = $handle->fh
222
223 This method returns the file handle of the L<AnyEvent::Handle> object.
224
225 =cut
226
227 sub fh { $_[0]->{fh} }
228
229 =item $handle->on_error ($cb)
230
231 Replace the current C<on_error> callback (see the C<on_error> constructor argument).
232
233 =cut
234
235 sub on_error {
236 $_[0]{on_error} = $_[1];
237 }
238
239 =item $handle->on_eof ($cb)
240
241 Replace the current C<on_eof> callback (see the C<on_eof> constructor argument).
242
243 =cut
244
245 sub on_eof {
246 $_[0]{on_eof} = $_[1];
247 }
248
249 #############################################################################
250
251 =back
252
253 =head2 WRITE QUEUE
254
255 AnyEvent::Handle manages two queues per handle, one for writing and one
256 for reading.
257
258 The write queue is very simple: you can add data to its end, and
259 AnyEvent::Handle will automatically try to get rid of it for you.
260
261 When data could be written and the write buffer is shorter then the low
262 water mark, the C<on_drain> callback will be invoked.
263
264 =over 4
265
266 =item $handle->on_drain ($cb)
267
268 Sets the C<on_drain> callback or clears it (see the description of
269 C<on_drain> in the constructor).
270
271 =cut
272
273 sub on_drain {
274 my ($self, $cb) = @_;
275
276 $self->{on_drain} = $cb;
277
278 $cb->($self)
279 if $cb && $self->{low_water_mark} >= length $self->{wbuf};
280 }
281
282 =item $handle->push_write ($data)
283
284 Queues the given scalar to be written. You can push as much data as you
285 want (only limited by the available memory), as C<AnyEvent::Handle>
286 buffers it independently of the kernel.
287
288 =cut
289
290 sub _drain_wbuf {
291 my ($self) = @_;
292
293 if (!$self->{ww} && length $self->{wbuf}) {
294
295 Scalar::Util::weaken $self;
296
297 my $cb = sub {
298 my $len = syswrite $self->{fh}, $self->{wbuf};
299
300 if ($len >= 0) {
301 substr $self->{wbuf}, 0, $len, "";
302
303 $self->{on_drain}($self)
304 if $self->{low_water_mark} >= length $self->{wbuf}
305 && $self->{on_drain};
306
307 delete $self->{ww} unless length $self->{wbuf};
308 } elsif ($! != EAGAIN && $! != EINTR && $! != WSAWOULDBLOCK) {
309 $self->error;
310 }
311 };
312
313 # try to write data immediately
314 $cb->();
315
316 # if still data left in wbuf, we need to poll
317 $self->{ww} = AnyEvent->io (fh => $self->{fh}, poll => "w", cb => $cb)
318 if length $self->{wbuf};
319 };
320 }
321
322 our %WH;
323
324 sub register_write_type($$) {
325 $WH{$_[0]} = $_[1];
326 }
327
328 sub push_write {
329 my $self = shift;
330
331 if (@_ > 1) {
332 my $type = shift;
333
334 @_ = ($WH{$type} or Carp::croak "unsupported type passed to AnyEvent::Handle::push_write")
335 ->($self, @_);
336 }
337
338 if ($self->{filter_w}) {
339 $self->{filter_w}->($self, \$_[0]);
340 } else {
341 $self->{wbuf} .= $_[0];
342 $self->_drain_wbuf;
343 }
344 }
345
346 =item $handle->push_write (type => @args)
347
348 =item $handle->unshift_write (type => @args)
349
350 Instead of formatting your data yourself, you can also let this module do
351 the job by specifying a type and type-specific arguments.
352
353 Predefined types are (if you have ideas for additional types, feel free to
354 drop by and tell us):
355
356 =over 4
357
358 =item netstring => $string
359
360 Formats the given value as netstring
361 (http://cr.yp.to/proto/netstrings.txt, this is not a recommendation to use them).
362
363 =back
364
365 =cut
366
367 register_write_type netstring => sub {
368 my ($self, $string) = @_;
369
370 sprintf "%d:%s,", (length $string), $string
371 };
372
373 =item AnyEvent::Handle::register_write_type type => $coderef->($self, @args)
374
375 This function (not method) lets you add your own types to C<push_write>.
376 Whenever the given C<type> is used, C<push_write> will invoke the code
377 reference with the handle object and the remaining arguments.
378
379 The code reference is supposed to return a single octet string that will
380 be appended to the write buffer.
381
382 Note that this is a function, and all types registered this way will be
383 global, so try to use unique names.
384
385 =cut
386
387 #############################################################################
388
389 =back
390
391 =head2 READ QUEUE
392
393 AnyEvent::Handle manages two queues per handle, one for writing and one
394 for reading.
395
396 The read queue is more complex than the write queue. It can be used in two
397 ways, the "simple" way, using only C<on_read> and the "complex" way, using
398 a queue.
399
400 In the simple case, you just install an C<on_read> callback and whenever
401 new data arrives, it will be called. You can then remove some data (if
402 enough is there) from the read buffer (C<< $handle->rbuf >>) if you want
403 or not.
404
405 In the more complex case, you want to queue multiple callbacks. In this
406 case, AnyEvent::Handle will call the first queued callback each time new
407 data arrives and removes it when it has done its job (see C<push_read>,
408 below).
409
410 This way you can, for example, push three line-reads, followed by reading
411 a chunk of data, and AnyEvent::Handle will execute them in order.
412
413 Example 1: EPP protocol parser. EPP sends 4 byte length info, followed by
414 the specified number of bytes which give an XML datagram.
415
416 # in the default state, expect some header bytes
417 $handle->on_read (sub {
418 # some data is here, now queue the length-header-read (4 octets)
419 shift->unshift_read_chunk (4, sub {
420 # header arrived, decode
421 my $len = unpack "N", $_[1];
422
423 # now read the payload
424 shift->unshift_read_chunk ($len, sub {
425 my $xml = $_[1];
426 # handle xml
427 });
428 });
429 });
430
431 Example 2: Implement a client for a protocol that replies either with
432 "OK" and another line or "ERROR" for one request, and 64 bytes for the
433 second request. Due tot he availability of a full queue, we can just
434 pipeline sending both requests and manipulate the queue as necessary in
435 the callbacks:
436
437 # request one
438 $handle->push_write ("request 1\015\012");
439
440 # we expect "ERROR" or "OK" as response, so push a line read
441 $handle->push_read_line (sub {
442 # if we got an "OK", we have to _prepend_ another line,
443 # so it will be read before the second request reads its 64 bytes
444 # which are already in the queue when this callback is called
445 # we don't do this in case we got an error
446 if ($_[1] eq "OK") {
447 $_[0]->unshift_read_line (sub {
448 my $response = $_[1];
449 ...
450 });
451 }
452 });
453
454 # request two
455 $handle->push_write ("request 2\015\012");
456
457 # simply read 64 bytes, always
458 $handle->push_read_chunk (64, sub {
459 my $response = $_[1];
460 ...
461 });
462
463 =over 4
464
465 =cut
466
467 sub _drain_rbuf {
468 my ($self) = @_;
469
470 if (
471 defined $self->{rbuf_max}
472 && $self->{rbuf_max} < length $self->{rbuf}
473 ) {
474 $! = &Errno::ENOSPC; return $self->error;
475 }
476
477 return if $self->{in_drain};
478 local $self->{in_drain} = 1;
479
480 while (my $len = length $self->{rbuf}) {
481 no strict 'refs';
482 if (my $cb = shift @{ $self->{queue} }) {
483 unless ($cb->($self)) {
484 if ($self->{eof}) {
485 # no progress can be made (not enough data and no data forthcoming)
486 $! = &Errno::EPIPE; return $self->error;
487 }
488
489 unshift @{ $self->{queue} }, $cb;
490 return;
491 }
492 } elsif ($self->{on_read}) {
493 $self->{on_read}($self);
494
495 if (
496 $self->{eof} # if no further data will arrive
497 && $len == length $self->{rbuf} # and no data has been consumed
498 && !@{ $self->{queue} } # and the queue is still empty
499 && $self->{on_read} # and we still want to read data
500 ) {
501 # then no progress can be made
502 $! = &Errno::EPIPE; return $self->error;
503 }
504 } else {
505 # read side becomes idle
506 delete $self->{rw};
507 return;
508 }
509 }
510
511 if ($self->{eof}) {
512 $self->_shutdown;
513 $self->{on_eof}($self)
514 if $self->{on_eof};
515 }
516 }
517
518 =item $handle->on_read ($cb)
519
520 This replaces the currently set C<on_read> callback, or clears it (when
521 the new callback is C<undef>). See the description of C<on_read> in the
522 constructor.
523
524 =cut
525
526 sub on_read {
527 my ($self, $cb) = @_;
528
529 $self->{on_read} = $cb;
530 }
531
532 =item $handle->rbuf
533
534 Returns the read buffer (as a modifiable lvalue).
535
536 You can access the read buffer directly as the C<< ->{rbuf} >> member, if
537 you want.
538
539 NOTE: The read buffer should only be used or modified if the C<on_read>,
540 C<push_read> or C<unshift_read> methods are used. The other read methods
541 automatically manage the read buffer.
542
543 =cut
544
545 sub rbuf : lvalue {
546 $_[0]{rbuf}
547 }
548
549 =item $handle->push_read ($cb)
550
551 =item $handle->unshift_read ($cb)
552
553 Append the given callback to the end of the queue (C<push_read>) or
554 prepend it (C<unshift_read>).
555
556 The callback is called each time some additional read data arrives.
557
558 It must check whether enough data is in the read buffer already.
559
560 If not enough data is available, it must return the empty list or a false
561 value, in which case it will be called repeatedly until enough data is
562 available (or an error condition is detected).
563
564 If enough data was available, then the callback must remove all data it is
565 interested in (which can be none at all) and return a true value. After returning
566 true, it will be removed from the queue.
567
568 =cut
569
570 our %RH;
571
572 sub register_read_type($$) {
573 $RH{$_[0]} = $_[1];
574 }
575
576 sub push_read {
577 my $self = shift;
578 my $cb = pop;
579
580 if (@_) {
581 my $type = shift;
582
583 $cb = ($RH{$type} or Carp::croak "unsupported type passed to AnyEvent::Handle::push_read")
584 ->($self, $cb, @_);
585 }
586
587 push @{ $self->{queue} }, $cb;
588 $self->_drain_rbuf;
589 }
590
591 sub unshift_read {
592 my $self = shift;
593 my $cb = pop;
594
595 if (@_) {
596 my $type = shift;
597
598 $cb = ($RH{$type} or Carp::croak "unsupported type passed to AnyEvent::Handle::unshift_read")
599 ->($self, $cb, @_);
600 }
601
602
603 unshift @{ $self->{queue} }, $cb;
604 $self->_drain_rbuf;
605 }
606
607 =item $handle->push_read (type => @args, $cb)
608
609 =item $handle->unshift_read (type => @args, $cb)
610
611 Instead of providing a callback that parses the data itself you can chose
612 between a number of predefined parsing formats, for chunks of data, lines
613 etc.
614
615 Predefined types are (if you have ideas for additional types, feel free to
616 drop by and tell us):
617
618 =over 4
619
620 =item chunk => $octets, $cb->($self, $data)
621
622 Invoke the callback only once C<$octets> bytes have been read. Pass the
623 data read to the callback. The callback will never be called with less
624 data.
625
626 Example: read 2 bytes.
627
628 $handle->push_read (chunk => 2, sub {
629 warn "yay ", unpack "H*", $_[1];
630 });
631
632 =cut
633
634 register_read_type chunk => sub {
635 my ($self, $cb, $len) = @_;
636
637 sub {
638 $len <= length $_[0]{rbuf} or return;
639 $cb->($_[0], substr $_[0]{rbuf}, 0, $len, "");
640 1
641 }
642 };
643
644 # compatibility with older API
645 sub push_read_chunk {
646 $_[0]->push_read (chunk => $_[1], $_[2]);
647 }
648
649 sub unshift_read_chunk {
650 $_[0]->unshift_read (chunk => $_[1], $_[2]);
651 }
652
653 =item line => [$eol, ]$cb->($self, $line, $eol)
654
655 The callback will be called only once a full line (including the end of
656 line marker, C<$eol>) has been read. This line (excluding the end of line
657 marker) will be passed to the callback as second argument (C<$line>), and
658 the end of line marker as the third argument (C<$eol>).
659
660 The end of line marker, C<$eol>, can be either a string, in which case it
661 will be interpreted as a fixed record end marker, or it can be a regex
662 object (e.g. created by C<qr>), in which case it is interpreted as a
663 regular expression.
664
665 The end of line marker argument C<$eol> is optional, if it is missing (NOT
666 undef), then C<qr|\015?\012|> is used (which is good for most internet
667 protocols).
668
669 Partial lines at the end of the stream will never be returned, as they are
670 not marked by the end of line marker.
671
672 =cut
673
674 register_read_type line => sub {
675 my ($self, $cb, $eol) = @_;
676
677 $eol = qr|(\015?\012)| if @_ < 3;
678 $eol = quotemeta $eol unless ref $eol;
679 $eol = qr|^(.*?)($eol)|s;
680
681 sub {
682 $_[0]{rbuf} =~ s/$eol// or return;
683
684 $cb->($_[0], $1, $2);
685 1
686 }
687 };
688
689 # compatibility with older API
690 sub push_read_line {
691 my $self = shift;
692 $self->push_read (line => @_);
693 }
694
695 sub unshift_read_line {
696 my $self = shift;
697 $self->unshift_read (line => @_);
698 }
699
700 =item netstring => $cb->($string)
701
702 A netstring (http://cr.yp.to/proto/netstrings.txt, this is not an endorsement).
703
704 Throws an error with C<$!> set to EBADMSG on format violations.
705
706 =cut
707
708 register_read_type netstring => sub {
709 my ($self, $cb) = @_;
710
711 sub {
712 unless ($_[0]{rbuf} =~ s/^(0|[1-9][0-9]*)://) {
713 if ($_[0]{rbuf} =~ /[^0-9]/) {
714 $! = &Errno::EBADMSG;
715 $self->error;
716 }
717 return;
718 }
719
720 my $len = $1;
721
722 $self->unshift_read (chunk => $len, sub {
723 my $string = $_[1];
724 $_[0]->unshift_read (chunk => 1, sub {
725 if ($_[1] eq ",") {
726 $cb->($_[0], $string);
727 } else {
728 $! = &Errno::EBADMSG;
729 $self->error;
730 }
731 });
732 });
733
734 1
735 }
736 };
737
738 =back
739
740 =item AnyEvent::Handle::register_read_type type => $coderef->($self, $cb, @args)
741
742 This function (not method) lets you add your own types to C<push_read>.
743
744 Whenever the given C<type> is used, C<push_read> will invoke the code
745 reference with the handle object, the callback and the remaining
746 arguments.
747
748 The code reference is supposed to return a callback (usually a closure)
749 that works as a plain read callback (see C<< ->push_read ($cb) >>).
750
751 It should invoke the passed callback when it is done reading (remember to
752 pass C<$self> as first argument as all other callbacks do that).
753
754 Note that this is a function, and all types registered this way will be
755 global, so try to use unique names.
756
757 For examples, see the source of this module (F<perldoc -m AnyEvent::Handle>,
758 search for C<register_read_type>)).
759
760 =item $handle->stop_read
761
762 =item $handle->start_read
763
764 In rare cases you actually do not want to read anything from the
765 socket. In this case you can call C<stop_read>. Neither C<on_read> no
766 any queued callbacks will be executed then. To start reading again, call
767 C<start_read>.
768
769 =cut
770
771 sub stop_read {
772 my ($self) = @_;
773
774 delete $self->{rw};
775 }
776
777 sub start_read {
778 my ($self) = @_;
779
780 unless ($self->{rw} || $self->{eof}) {
781 Scalar::Util::weaken $self;
782
783 $self->{rw} = AnyEvent->io (fh => $self->{fh}, poll => "r", cb => sub {
784 my $rbuf = $self->{filter_r} ? \my $buf : \$self->{rbuf};
785 my $len = sysread $self->{fh}, $$rbuf, $self->{read_size} || 8192, length $$rbuf;
786
787 if ($len > 0) {
788 $self->{filter_r}
789 ? $self->{filter_r}->($self, $rbuf)
790 : $self->_drain_rbuf;
791
792 } elsif (defined $len) {
793 delete $self->{rw};
794 $self->{eof} = 1;
795 $self->_drain_rbuf;
796
797 } elsif ($! != EAGAIN && $! != EINTR && $! != &AnyEvent::Util::WSAWOULDBLOCK) {
798 return $self->error;
799 }
800 });
801 }
802 }
803
804 sub _dotls {
805 my ($self) = @_;
806
807 if (length $self->{tls_wbuf}) {
808 while ((my $len = Net::SSLeay::write ($self->{tls}, $self->{tls_wbuf})) > 0) {
809 substr $self->{tls_wbuf}, 0, $len, "";
810 }
811 }
812
813 if (defined (my $buf = Net::SSLeay::BIO_read ($self->{tls_wbio}))) {
814 $self->{wbuf} .= $buf;
815 $self->_drain_wbuf;
816 }
817
818 while (defined (my $buf = Net::SSLeay::read ($self->{tls}))) {
819 $self->{rbuf} .= $buf;
820 $self->_drain_rbuf;
821 }
822
823 my $err = Net::SSLeay::get_error ($self->{tls}, -1);
824
825 if ($err!= Net::SSLeay::ERROR_WANT_READ ()) {
826 if ($err == Net::SSLeay::ERROR_SYSCALL ()) {
827 $self->error;
828 } elsif ($err == Net::SSLeay::ERROR_SSL ()) {
829 $! = &Errno::EIO;
830 $self->error;
831 }
832
833 # all others are fine for our purposes
834 }
835 }
836
837 =item $handle->starttls ($tls[, $tls_ctx])
838
839 Instead of starting TLS negotiation immediately when the AnyEvent::Handle
840 object is created, you can also do that at a later time by calling
841 C<starttls>.
842
843 The first argument is the same as the C<tls> constructor argument (either
844 C<"connect">, C<"accept"> or an existing Net::SSLeay object).
845
846 The second argument is the optional C<Net::SSLeay::CTX> object that is
847 used when AnyEvent::Handle has to create its own TLS connection object.
848
849 =cut
850
851 # TODO: maybe document...
852 sub starttls {
853 my ($self, $ssl, $ctx) = @_;
854
855 $self->stoptls;
856
857 if ($ssl eq "accept") {
858 $ssl = Net::SSLeay::new ($ctx || TLS_CTX ());
859 Net::SSLeay::set_accept_state ($ssl);
860 } elsif ($ssl eq "connect") {
861 $ssl = Net::SSLeay::new ($ctx || TLS_CTX ());
862 Net::SSLeay::set_connect_state ($ssl);
863 }
864
865 $self->{tls} = $ssl;
866
867 # basically, this is deep magic (because SSL_read should have the same issues)
868 # but the openssl maintainers basically said: "trust us, it just works".
869 # (unfortunately, we have to hardcode constants because the abysmally misdesigned
870 # and mismaintained ssleay-module doesn't even offer them).
871 # http://www.mail-archive.com/openssl-dev@openssl.org/msg22420.html
872 Net::SSLeay::CTX_set_mode ($self->{tls},
873 (eval { local $SIG{__DIE__}; Net::SSLeay::MODE_ENABLE_PARTIAL_WRITE () } || 1)
874 | (eval { local $SIG{__DIE__}; Net::SSLeay::MODE_ACCEPT_MOVING_WRITE_BUFFER () } || 2));
875
876 $self->{tls_rbio} = Net::SSLeay::BIO_new (Net::SSLeay::BIO_s_mem ());
877 $self->{tls_wbio} = Net::SSLeay::BIO_new (Net::SSLeay::BIO_s_mem ());
878
879 Net::SSLeay::set_bio ($ssl, $self->{tls_rbio}, $self->{tls_wbio});
880
881 $self->{filter_w} = sub {
882 $_[0]{tls_wbuf} .= ${$_[1]};
883 &_dotls;
884 };
885 $self->{filter_r} = sub {
886 Net::SSLeay::BIO_write ($_[0]{tls_rbio}, ${$_[1]});
887 &_dotls;
888 };
889 }
890
891 =item $handle->stoptls
892
893 Destroys the SSL connection, if any. Partial read or write data will be
894 lost.
895
896 =cut
897
898 sub stoptls {
899 my ($self) = @_;
900
901 Net::SSLeay::free (delete $self->{tls}) if $self->{tls};
902 delete $self->{tls_rbio};
903 delete $self->{tls_wbio};
904 delete $self->{tls_wbuf};
905 delete $self->{filter_r};
906 delete $self->{filter_w};
907 }
908
909 sub DESTROY {
910 my $self = shift;
911
912 $self->stoptls;
913 }
914
915 =item AnyEvent::Handle::TLS_CTX
916
917 This function creates and returns the Net::SSLeay::CTX object used by
918 default for TLS mode.
919
920 The context is created like this:
921
922 Net::SSLeay::load_error_strings;
923 Net::SSLeay::SSLeay_add_ssl_algorithms;
924 Net::SSLeay::randomize;
925
926 my $CTX = Net::SSLeay::CTX_new;
927
928 Net::SSLeay::CTX_set_options $CTX, Net::SSLeay::OP_ALL
929
930 =cut
931
932 our $TLS_CTX;
933
934 sub TLS_CTX() {
935 $TLS_CTX || do {
936 require Net::SSLeay;
937
938 Net::SSLeay::load_error_strings ();
939 Net::SSLeay::SSLeay_add_ssl_algorithms ();
940 Net::SSLeay::randomize ();
941
942 $TLS_CTX = Net::SSLeay::CTX_new ();
943
944 Net::SSLeay::CTX_set_options ($TLS_CTX, Net::SSLeay::OP_ALL ());
945
946 $TLS_CTX
947 }
948 }
949
950 =back
951
952 =head1 AUTHOR
953
954 Robin Redeker C<< <elmex at ta-sa.org> >>, Marc Lehmann <schmorp@schmorp.de>.
955
956 =cut
957
958 1; # End of AnyEvent::Handle