ViewVC Help
View File | Revision Log | Show Annotations | Download File
/cvs/AnyEvent/lib/AnyEvent/Handle.pm
(Generate patch)

Comparing AnyEvent/lib/AnyEvent/Handle.pm (file contents):
Revision 1.16 by root, Fri May 23 05:16:57 2008 UTC vs.
Revision 1.32 by root, Sun May 25 01:10:54 2008 UTC

… …
2 2
3no warnings; 3no warnings;
4use strict; 4use strict;
5 5
6use AnyEvent (); 6use AnyEvent ();
7use AnyEvent::Util (); 7use AnyEvent::Util qw(WSAEAGAIN);
8use Scalar::Util (); 8use Scalar::Util ();
9use Carp (); 9use Carp ();
10use Fcntl (); 10use Fcntl ();
11use Errno qw/EAGAIN EINTR/; 11use Errno qw/EAGAIN EINTR/;
12 12
13=head1 NAME 13=head1 NAME
14 14
15AnyEvent::Handle - non-blocking I/O on filehandles via AnyEvent 15AnyEvent::Handle - non-blocking I/O on file handles via AnyEvent
16
17This module is experimental.
18 16
19=cut 17=cut
20 18
21our $VERSION = '0.04'; 19our $VERSION = '0.04';
22 20
… …
25 use AnyEvent; 23 use AnyEvent;
26 use AnyEvent::Handle; 24 use AnyEvent::Handle;
27 25
28 my $cv = AnyEvent->condvar; 26 my $cv = AnyEvent->condvar;
29 27
30 my $ae_fh = AnyEvent::Handle->new (fh => \*STDIN); 28 my $handle =
31
32 #TODO
33
34 # or use the constructor to pass the callback:
35
36 my $ae_fh2 =
37 AnyEvent::Handle->new ( 29 AnyEvent::Handle->new (
38 fh => \*STDIN, 30 fh => \*STDIN,
39 on_eof => sub { 31 on_eof => sub {
40 $cv->broadcast; 32 $cv->broadcast;
41 }, 33 },
42 #TODO
43 ); 34 );
44 35
45 $cv->wait; 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;
46 47
47=head1 DESCRIPTION 48=head1 DESCRIPTION
48 49
49This module is a helper module to make it easier to do event-based I/O on 50This module is a helper module to make it easier to do event-based I/O on
50filehandles. For utility functions for doing non-blocking connects and accepts 51filehandles. For utility functions for doing non-blocking connects and accepts
… …
83waiting for data. 84waiting for data.
84 85
85=item on_error => $cb->($self) 86=item on_error => $cb->($self)
86 87
87This is the fatal error callback, that is called when, well, a fatal error 88This is the fatal error callback, that is called when, well, a fatal error
88ocurs, such as not being able to resolve the hostname, failure to connect 89occurs, such as not being able to resolve the hostname, failure to connect
89or a read error. 90or a read error.
90 91
91The object will not be in a usable state when this callback has been 92The object will not be in a usable state when this callback has been
92called. 93called.
93 94
94On callback entrance, the value of C<$!> contains the operating system 95On callback entrance, the value of C<$!> contains the operating system
95error (or C<ENOSPC> or C<EPIPE>). 96error (or C<ENOSPC>, C<EPIPE> or C<EBADMSG>).
96 97
97While not mandatory, it is I<highly> recommended to set this callback, as 98While not mandatory, it is I<highly> recommended to set this callback, as
98you will not be notified of errors otherwise. The default simply calls 99you will not be notified of errors otherwise. The default simply calls
99die. 100die.
100 101
… …
102 103
103This sets the default read callback, which is called when data arrives 104This sets the default read callback, which is called when data arrives
104and no read request is in the queue. 105and no read request is in the queue.
105 106
106To access (and remove data from) the read buffer, use the C<< ->rbuf >> 107To access (and remove data from) the read buffer, use the C<< ->rbuf >>
107method or acces sthe C<$self->{rbuf}> member directly. 108method or access the C<$self->{rbuf}> member directly.
108 109
109When an EOF condition is detected then AnyEvent::Handle will first try to 110When an EOF condition is detected then AnyEvent::Handle will first try to
110feed all the remaining data to the queued callbacks and C<on_read> before 111feed all the remaining data to the queued callbacks and C<on_read> before
111calling the C<on_eof> callback. If no progress can be made, then a fatal 112calling the C<on_eof> callback. If no progress can be made, then a fatal
112error will be raised (with C<$!> set to C<EPIPE>). 113error will be raised (with C<$!> set to C<EPIPE>).
… …
139 140
140Sets the amount of bytes (default: C<0>) that make up an "empty" write 141Sets the amount of bytes (default: C<0>) that make up an "empty" write
141buffer: If the write reaches this size or gets even samller it is 142buffer: If the write reaches this size or gets even samller it is
142considered empty. 143considered empty.
143 144
145=item tls => "accept" | "connect" | Net::SSLeay::SSL object
146
147When this parameter is given, it enables TLS (SSL) mode, that means it
148will start making tls handshake and will transparently encrypt/decrypt
149data.
150
151TLS mode requires Net::SSLeay to be installed (it will be loaded
152automatically when you try to create a TLS handle).
153
154For the TLS server side, use C<accept>, and for the TLS client side of a
155connection, use C<connect> mode.
156
157You can also provide your own TLS connection object, but you have
158to make sure that you call either C<Net::SSLeay::set_connect_state>
159or C<Net::SSLeay::set_accept_state> on it before you pass it to
160AnyEvent::Handle.
161
162See the C<starttls> method if you need to start TLs negotiation later.
163
164=item tls_ctx => $ssl_ctx
165
166Use the given Net::SSLeay::CTX object to create the new TLS connection
167(unless a connection object was specified directly). If this parameter is
168missing, then AnyEvent::Handle will use C<AnyEvent::Handle::TLS_CTX>.
169
144=back 170=back
145 171
146=cut 172=cut
147 173
148sub new { 174sub new {
… …
151 my $self = bless { @_ }, $class; 177 my $self = bless { @_ }, $class;
152 178
153 $self->{fh} or Carp::croak "mandatory argument fh is missing"; 179 $self->{fh} or Carp::croak "mandatory argument fh is missing";
154 180
155 AnyEvent::Util::fh_nonblocking $self->{fh}, 1; 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 }
156 187
157 $self->on_eof (delete $self->{on_eof} ) if $self->{on_eof}; 188 $self->on_eof (delete $self->{on_eof} ) if $self->{on_eof};
158 $self->on_error (delete $self->{on_error}) if $self->{on_error}; 189 $self->on_error (delete $self->{on_error}) if $self->{on_error};
159 $self->on_drain (delete $self->{on_drain}) if $self->{on_drain}; 190 $self->on_drain (delete $self->{on_drain}) if $self->{on_drain};
160 $self->on_read (delete $self->{on_read} ) if $self->{on_read}; 191 $self->on_read (delete $self->{on_read} ) if $self->{on_read};
… …
181 } 212 }
182 213
183 if ($self->{on_error}) { 214 if ($self->{on_error}) {
184 $self->{on_error}($self); 215 $self->{on_error}($self);
185 } else { 216 } else {
186 die "AnyEvent::Handle uncaught fatal error: $!"; 217 Carp::croak "AnyEvent::Handle uncaught fatal error: $!";
187 } 218 }
188} 219}
189 220
190=item $fh = $handle->fh 221=item $fh = $handle->fh
191 222
192This method returns the filehandle of the L<AnyEvent::Handle> object. 223This method returns the file handle of the L<AnyEvent::Handle> object.
193 224
194=cut 225=cut
195 226
196sub fh { $_[0]->{fh} } 227sub fh { $_[0]->{fh} }
197 228
… …
225for reading. 256for reading.
226 257
227The write queue is very simple: you can add data to its end, and 258The write queue is very simple: you can add data to its end, and
228AnyEvent::Handle will automatically try to get rid of it for you. 259AnyEvent::Handle will automatically try to get rid of it for you.
229 260
230When data could be writtena nd the write buffer is shorter then the low 261When data could be written and the write buffer is shorter then the low
231water mark, the C<on_drain> callback will be invoked. 262water mark, the C<on_drain> callback will be invoked.
232 263
233=over 4 264=over 4
234 265
235=item $handle->on_drain ($cb) 266=item $handle->on_drain ($cb)
… …
254want (only limited by the available memory), as C<AnyEvent::Handle> 285want (only limited by the available memory), as C<AnyEvent::Handle>
255buffers it independently of the kernel. 286buffers it independently of the kernel.
256 287
257=cut 288=cut
258 289
259sub push_write { 290sub _drain_wbuf {
260 my ($self, $data) = @_; 291 my ($self) = @_;
261 292
262 $self->{wbuf} .= $data; 293 if (!$self->{ww} && length $self->{wbuf}) {
263
264 unless ($self->{ww}) {
265 Scalar::Util::weaken $self; 294 Scalar::Util::weaken $self;
266 my $cb = sub { 295 my $cb = sub {
267 my $len = syswrite $self->{fh}, $self->{wbuf}; 296 my $len = syswrite $self->{fh}, $self->{wbuf};
268 297
269 if ($len > 0) { 298 if ($len >= 0) {
270 substr $self->{wbuf}, 0, $len, ""; 299 substr $self->{wbuf}, 0, $len, "";
271
272 300
273 $self->{on_drain}($self) 301 $self->{on_drain}($self)
274 if $self->{low_water_mark} >= length $self->{wbuf} 302 if $self->{low_water_mark} >= length $self->{wbuf}
275 && $self->{on_drain}; 303 && $self->{on_drain};
276 304
277 delete $self->{ww} unless length $self->{wbuf}; 305 delete $self->{ww} unless length $self->{wbuf};
278 } elsif ($! != EAGAIN && $! != EINTR) { 306 } elsif ($! != EAGAIN && $! != EINTR && $! != WSAEAGAIN) {
279 $self->error; 307 $self->error;
280 } 308 }
281 }; 309 };
282 310
283 $self->{ww} = AnyEvent->io (fh => $self->{fh}, poll => "w", cb => $cb); 311 $self->{ww} = AnyEvent->io (fh => $self->{fh}, poll => "w", cb => $cb);
284 312
285 $cb->($self); 313 $cb->($self);
286 }; 314 };
287} 315}
316
317our %WH;
318
319sub register_write_type($$) {
320 $WH{$_[0]} = $_[1];
321}
322
323sub push_write {
324 my $self = shift;
325
326 if (@_ > 1) {
327 my $type = shift;
328
329 @_ = ($WH{$type} or Carp::croak "unsupported type passed to AnyEvent::Handle::push_write")
330 ->($self, @_);
331 }
332
333 if ($self->{filter_w}) {
334 $self->{filter_w}->($self, \$_[0]);
335 } else {
336 $self->{wbuf} .= $_[0];
337 $self->_drain_wbuf;
338 }
339}
340
341=item $handle->push_write (type => @args)
342
343=item $handle->unshift_write (type => @args)
344
345Instead of formatting your data yourself, you can also let this module do
346the job by specifying a type and type-specific arguments.
347
348Predefined types are (if you have ideas for additional types, feel free to
349drop by and tell us):
350
351=over 4
352
353=item netstring => $string
354
355Formats the given value as netstring
356(http://cr.yp.to/proto/netstrings.txt, this is not a recommendation to use them).
357
358=back
359
360=cut
361
362register_write_type netstring => sub {
363 my ($self, $string) = @_;
364
365 sprintf "%d:%s,", (length $string), $string
366};
367
368=item AnyEvent::Handle::register_write_type type => $coderef->($self, @args)
369
370This function (not method) lets you add your own types to C<push_write>.
371Whenever the given C<type> is used, C<push_write> will invoke the code
372reference with the handle object and the remaining arguments.
373
374The code reference is supposed to return a single octet string that will
375be appended to the write buffer.
376
377Note that this is a function, and all types registered this way will be
378global, so try to use unique names.
379
380=cut
288 381
289############################################################################# 382#############################################################################
290 383
291=back 384=back
292 385
… …
367=cut 460=cut
368 461
369sub _drain_rbuf { 462sub _drain_rbuf {
370 my ($self) = @_; 463 my ($self) = @_;
371 464
465 if (
466 defined $self->{rbuf_max}
467 && $self->{rbuf_max} < length $self->{rbuf}
468 ) {
469 $! = &Errno::ENOSPC; return $self->error;
470 }
471
372 return if $self->{in_drain}; 472 return if $self->{in_drain};
373 local $self->{in_drain} = 1; 473 local $self->{in_drain} = 1;
374 474
375 while (my $len = length $self->{rbuf}) { 475 while (my $len = length $self->{rbuf}) {
376 no strict 'refs'; 476 no strict 'refs';
377 if (my $cb = shift @{ $self->{queue} }) { 477 if (my $cb = shift @{ $self->{queue} }) {
378 if (!$cb->($self)) { 478 unless ($cb->($self)) {
379 if ($self->{eof}) { 479 if ($self->{eof}) {
380 # no progress can be made (not enough data and no data forthcoming) 480 # no progress can be made (not enough data and no data forthcoming)
381 $! = &Errno::EPIPE; return $self->error; 481 $! = &Errno::EPIPE; return $self->error;
382 } 482 }
383 483
… …
448Append the given callback to the end of the queue (C<push_read>) or 548Append the given callback to the end of the queue (C<push_read>) or
449prepend it (C<unshift_read>). 549prepend it (C<unshift_read>).
450 550
451The callback is called each time some additional read data arrives. 551The callback is called each time some additional read data arrives.
452 552
453It must check wether enough data is in the read buffer already. 553It must check whether enough data is in the read buffer already.
454 554
455If not enough data is available, it must return the empty list or a false 555If not enough data is available, it must return the empty list or a false
456value, in which case it will be called repeatedly until enough data is 556value, in which case it will be called repeatedly until enough data is
457available (or an error condition is detected). 557available (or an error condition is detected).
458 558
… …
460interested in (which can be none at all) and return a true value. After returning 560interested in (which can be none at all) and return a true value. After returning
461true, it will be removed from the queue. 561true, it will be removed from the queue.
462 562
463=cut 563=cut
464 564
565our %RH;
566
567sub register_read_type($$) {
568 $RH{$_[0]} = $_[1];
569}
570
465sub push_read { 571sub push_read {
466 my ($self, $cb) = @_; 572 my $self = shift;
573 my $cb = pop;
574
575 if (@_) {
576 my $type = shift;
577
578 $cb = ($RH{$type} or Carp::croak "unsupported type passed to AnyEvent::Handle::push_read")
579 ->($self, $cb, @_);
580 }
467 581
468 push @{ $self->{queue} }, $cb; 582 push @{ $self->{queue} }, $cb;
469 $self->_drain_rbuf; 583 $self->_drain_rbuf;
470} 584}
471 585
472sub unshift_read { 586sub unshift_read {
473 my ($self, $cb) = @_; 587 my $self = shift;
588 my $cb = pop;
474 589
590 if (@_) {
591 my $type = shift;
592
593 $cb = ($RH{$type} or Carp::croak "unsupported type passed to AnyEvent::Handle::unshift_read")
594 ->($self, $cb, @_);
595 }
596
597
475 push @{ $self->{queue} }, $cb; 598 unshift @{ $self->{queue} }, $cb;
476 $self->_drain_rbuf; 599 $self->_drain_rbuf;
477} 600}
478 601
479=item $handle->push_read_chunk ($len, $cb->($self, $data)) 602=item $handle->push_read (type => @args, $cb)
480 603
481=item $handle->unshift_read_chunk ($len, $cb->($self, $data)) 604=item $handle->unshift_read (type => @args, $cb)
482 605
483Append the given callback to the end of the queue (C<push_read_chunk>) or 606Instead of providing a callback that parses the data itself you can chose
484prepend it (C<unshift_read_chunk>). 607between a number of predefined parsing formats, for chunks of data, lines
608etc.
485 609
486The callback will be called only once C<$len> bytes have been read, and 610Predefined types are (if you have ideas for additional types, feel free to
487these C<$len> bytes will be passed to the callback. 611drop by and tell us):
488 612
489=cut 613=over 4
490 614
491sub _read_chunk($$) { 615=item chunk => $octets, $cb->($self, $data)
616
617Invoke the callback only once C<$octets> bytes have been read. Pass the
618data read to the callback. The callback will never be called with less
619data.
620
621Example: read 2 bytes.
622
623 $handle->push_read (chunk => 2, sub {
624 warn "yay ", unpack "H*", $_[1];
625 });
626
627=cut
628
629register_read_type chunk => sub {
492 my ($self, $len, $cb) = @_; 630 my ($self, $cb, $len) = @_;
493 631
494 sub { 632 sub {
495 $len <= length $_[0]{rbuf} or return; 633 $len <= length $_[0]{rbuf} or return;
496 $cb->($_[0], substr $_[0]{rbuf}, 0, $len, ""); 634 $cb->($_[0], substr $_[0]{rbuf}, 0, $len, "");
497 1 635 1
498 } 636 }
499} 637};
500 638
639# compatibility with older API
501sub push_read_chunk { 640sub push_read_chunk {
502 $_[0]->push_read (&_read_chunk); 641 $_[0]->push_read (chunk => $_[1], $_[2]);
503} 642}
504
505 643
506sub unshift_read_chunk { 644sub unshift_read_chunk {
507 $_[0]->unshift_read (&_read_chunk); 645 $_[0]->unshift_read (chunk => $_[1], $_[2]);
508} 646}
509 647
510=item $handle->push_read_line ([$eol, ]$cb->($self, $line, $eol)) 648=item line => [$eol, ]$cb->($self, $line, $eol)
511
512=item $handle->unshift_read_line ([$eol, ]$cb->($self, $line, $eol))
513
514Append the given callback to the end of the queue (C<push_read_line>) or
515prepend it (C<unshift_read_line>).
516 649
517The callback will be called only once a full line (including the end of 650The callback will be called only once a full line (including the end of
518line marker, C<$eol>) has been read. This line (excluding the end of line 651line marker, C<$eol>) has been read. This line (excluding the end of line
519marker) will be passed to the callback as second argument (C<$line>), and 652marker) will be passed to the callback as second argument (C<$line>), and
520the end of line marker as the third argument (C<$eol>). 653the end of line marker as the third argument (C<$eol>).
… …
531Partial lines at the end of the stream will never be returned, as they are 664Partial lines at the end of the stream will never be returned, as they are
532not marked by the end of line marker. 665not marked by the end of line marker.
533 666
534=cut 667=cut
535 668
536sub _read_line($$) { 669register_read_type line => sub {
537 my $self = shift; 670 my ($self, $cb, $eol) = @_;
538 my $cb = pop;
539 my $eol = @_ ? shift : qr|(\015?\012)|;
540 my $pos;
541 671
672 $eol = qr|(\015?\012)| if @_ < 3;
542 $eol = quotemeta $eol unless ref $eol; 673 $eol = quotemeta $eol unless ref $eol;
543 $eol = qr|^(.*?)($eol)|s; 674 $eol = qr|^(.*?)($eol)|s;
544 675
545 sub { 676 sub {
546 $_[0]{rbuf} =~ s/$eol// or return; 677 $_[0]{rbuf} =~ s/$eol// or return;
547 678
548 $cb->($_[0], $1, $2); 679 $cb->($_[0], $1, $2);
549 1 680 1
550 } 681 }
551} 682};
552 683
684# compatibility with older API
553sub push_read_line { 685sub push_read_line {
554 $_[0]->push_read (&_read_line); 686 my $self = shift;
687 $self->push_read (line => @_);
555} 688}
556 689
557sub unshift_read_line { 690sub unshift_read_line {
558 $_[0]->unshift_read (&_read_line); 691 my $self = shift;
692 $self->unshift_read (line => @_);
559} 693}
694
695=item netstring => $cb->($string)
696
697A netstring (http://cr.yp.to/proto/netstrings.txt, this is not an endorsement).
698
699Throws an error with C<$!> set to EBADMSG on format violations.
700
701=cut
702
703register_read_type netstring => sub {
704 my ($self, $cb) = @_;
705
706 sub {
707 unless ($_[0]{rbuf} =~ s/^(0|[1-9][0-9]*)://) {
708 if ($_[0]{rbuf} =~ /[^0-9]/) {
709 $! = &Errno::EBADMSG;
710 $self->error;
711 }
712 return;
713 }
714
715 my $len = $1;
716
717 $self->unshift_read (chunk => $len, sub {
718 my $string = $_[1];
719 $_[0]->unshift_read (chunk => 1, sub {
720 if ($_[1] eq ",") {
721 $cb->($_[0], $string);
722 } else {
723 $! = &Errno::EBADMSG;
724 $self->error;
725 }
726 });
727 });
728
729 1
730 }
731};
732
733=back
734
735=item AnyEvent::Handle::register_read_type type => $coderef->($self, $cb, @args)
736
737This function (not method) lets you add your own types to C<push_read>.
738
739Whenever the given C<type> is used, C<push_read> will invoke the code
740reference with the handle object, the callback and the remaining
741arguments.
742
743The code reference is supposed to return a callback (usually a closure)
744that works as a plain read callback (see C<< ->push_read ($cb) >>).
745
746It should invoke the passed callback when it is done reading (remember to
747pass C<$self> as first argument as all other callbacks do that).
748
749Note that this is a function, and all types registered this way will be
750global, so try to use unique names.
751
752For examples, see the source of this module (F<perldoc -m AnyEvent::Handle>,
753search for C<register_read_type>)).
560 754
561=item $handle->stop_read 755=item $handle->stop_read
562 756
563=item $handle->start_read 757=item $handle->start_read
564 758
565In rare cases you actually do not want to read anything form the 759In rare cases you actually do not want to read anything from the
566socket. In this case you can call C<stop_read>. Neither C<on_read> no 760socket. In this case you can call C<stop_read>. Neither C<on_read> no
567any queued callbacks will be executed then. To start readign again, call 761any queued callbacks will be executed then. To start reading again, call
568C<start_read>. 762C<start_read>.
569 763
570=cut 764=cut
571 765
572sub stop_read { 766sub stop_read {
… …
580 774
581 unless ($self->{rw} || $self->{eof}) { 775 unless ($self->{rw} || $self->{eof}) {
582 Scalar::Util::weaken $self; 776 Scalar::Util::weaken $self;
583 777
584 $self->{rw} = AnyEvent->io (fh => $self->{fh}, poll => "r", cb => sub { 778 $self->{rw} = AnyEvent->io (fh => $self->{fh}, poll => "r", cb => sub {
779 my $rbuf = $self->{filter_r} ? \my $buf : \$self->{rbuf};
585 my $len = sysread $self->{fh}, $self->{rbuf}, $self->{read_size} || 8192, length $self->{rbuf}; 780 my $len = sysread $self->{fh}, $$rbuf, $self->{read_size} || 8192, length $$rbuf;
586 781
587 if ($len > 0) { 782 if ($len > 0) {
588 if (defined $self->{rbuf_max}) { 783 $self->{filter_r}
589 if ($self->{rbuf_max} < length $self->{rbuf}) { 784 ? $self->{filter_r}->($self, $rbuf)
590 $! = &Errno::ENOSPC; return $self->error; 785 : $self->_drain_rbuf;
591 }
592 }
593 786
594 } elsif (defined $len) { 787 } elsif (defined $len) {
788 delete $self->{rw};
595 $self->{eof} = 1; 789 $self->{eof} = 1;
596 delete $self->{rw}; 790 $self->_drain_rbuf;
597 791
598 } elsif ($! != EAGAIN && $! != EINTR) { 792 } elsif ($! != EAGAIN && $! != EINTR && $! != &AnyEvent::Util::WSAEAGAIN) {
599 return $self->error; 793 return $self->error;
600 } 794 }
601
602 $self->_drain_rbuf;
603 }); 795 });
604 } 796 }
605} 797}
606 798
799sub _dotls {
800 my ($self) = @_;
801
802 if (length $self->{tls_wbuf}) {
803 while ((my $len = Net::SSLeay::write ($self->{tls}, $self->{tls_wbuf})) > 0) {
804 substr $self->{tls_wbuf}, 0, $len, "";
805 }
806 }
807
808 if (defined (my $buf = Net::SSLeay::BIO_read ($self->{tls_wbio}))) {
809 $self->{wbuf} .= $buf;
810 $self->_drain_wbuf;
811 }
812
813 while (defined (my $buf = Net::SSLeay::read ($self->{tls}))) {
814 $self->{rbuf} .= $buf;
815 $self->_drain_rbuf;
816 }
817
818 my $err = Net::SSLeay::get_error ($self->{tls}, -1);
819
820 if ($err!= Net::SSLeay::ERROR_WANT_READ ()) {
821 if ($err == Net::SSLeay::ERROR_SYSCALL ()) {
822 $self->error;
823 } elsif ($err == Net::SSLeay::ERROR_SSL ()) {
824 $! = &Errno::EIO;
825 $self->error;
826 }
827
828 # all others are fine for our purposes
829 }
830}
831
832=item $handle->starttls ($tls[, $tls_ctx])
833
834Instead of starting TLS negotiation immediately when the AnyEvent::Handle
835object is created, you can also do that at a later time by calling
836C<starttls>.
837
838The first argument is the same as the C<tls> constructor argument (either
839C<"connect">, C<"accept"> or an existing Net::SSLeay object).
840
841The second argument is the optional C<Net::SSLeay::CTX> object that is
842used when AnyEvent::Handle has to create its own TLS connection object.
843
844=cut
845
846# TODO: maybe document...
847sub starttls {
848 my ($self, $ssl, $ctx) = @_;
849
850 $self->stoptls;
851
852 if ($ssl eq "accept") {
853 $ssl = Net::SSLeay::new ($ctx || TLS_CTX ());
854 Net::SSLeay::set_accept_state ($ssl);
855 } elsif ($ssl eq "connect") {
856 $ssl = Net::SSLeay::new ($ctx || TLS_CTX ());
857 Net::SSLeay::set_connect_state ($ssl);
858 }
859
860 $self->{tls} = $ssl;
861
862 # basically, this is deep magic (because SSL_read should have the same issues)
863 # but the openssl maintainers basically said: "trust us, it just works".
864 # (unfortunately, we have to hardcode constants because the abysmally misdesigned
865 # and mismaintained ssleay-module doesn't even offer them).
866 # http://www.mail-archive.com/openssl-dev@openssl.org/msg22420.html
867 Net::SSLeay::CTX_set_mode ($self->{tls},
868 (eval { Net::SSLeay::MODE_ENABLE_PARTIAL_WRITE () } || 1)
869 | (eval { Net::SSLeay::MODE_ACCEPT_MOVING_WRITE_BUFFER () } || 2));
870
871 $self->{tls_rbio} = Net::SSLeay::BIO_new (Net::SSLeay::BIO_s_mem ());
872 $self->{tls_wbio} = Net::SSLeay::BIO_new (Net::SSLeay::BIO_s_mem ());
873
874 Net::SSLeay::set_bio ($ssl, $self->{tls_rbio}, $self->{tls_wbio});
875
876 $self->{filter_w} = sub {
877 $_[0]{tls_wbuf} .= ${$_[1]};
878 &_dotls;
879 };
880 $self->{filter_r} = sub {
881 Net::SSLeay::BIO_write ($_[0]{tls_rbio}, ${$_[1]});
882 &_dotls;
883 };
884}
885
886=item $handle->stoptls
887
888Destroys the SSL connection, if any. Partial read or write data will be
889lost.
890
891=cut
892
893sub stoptls {
894 my ($self) = @_;
895
896 Net::SSLeay::free (delete $self->{tls}) if $self->{tls};
897 delete $self->{tls_rbio};
898 delete $self->{tls_wbio};
899 delete $self->{tls_wbuf};
900 delete $self->{filter_r};
901 delete $self->{filter_w};
902}
903
904sub DESTROY {
905 my $self = shift;
906
907 $self->stoptls;
908}
909
910=item AnyEvent::Handle::TLS_CTX
911
912This function creates and returns the Net::SSLeay::CTX object used by
913default for TLS mode.
914
915The context is created like this:
916
917 Net::SSLeay::load_error_strings;
918 Net::SSLeay::SSLeay_add_ssl_algorithms;
919 Net::SSLeay::randomize;
920
921 my $CTX = Net::SSLeay::CTX_new;
922
923 Net::SSLeay::CTX_set_options $CTX, Net::SSLeay::OP_ALL
924
925=cut
926
927our $TLS_CTX;
928
929sub TLS_CTX() {
930 $TLS_CTX || do {
931 require Net::SSLeay;
932
933 Net::SSLeay::load_error_strings ();
934 Net::SSLeay::SSLeay_add_ssl_algorithms ();
935 Net::SSLeay::randomize ();
936
937 $TLS_CTX = Net::SSLeay::CTX_new ();
938
939 Net::SSLeay::CTX_set_options ($TLS_CTX, Net::SSLeay::OP_ALL ());
940
941 $TLS_CTX
942 }
943}
944
607=back 945=back
608 946
609=head1 AUTHOR 947=head1 AUTHOR
610 948
611Robin Redeker C<< <elmex at ta-sa.org> >>, Marc Lehmann <schmorp@schmorp.de>. 949Robin Redeker C<< <elmex at ta-sa.org> >>, Marc Lehmann <schmorp@schmorp.de>.

Diff Legend

– Removed lines
+ Added lines
< Changed lines
> Changed lines