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.15 by root, Sat May 17 21:34:15 2008 UTC vs.
Revision 1.33 by root, Sun May 25 03:03:51 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(WSAWOULDBLOCK);
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
… …
72The filehandle this L<AnyEvent::Handle> object will operate on. 73The filehandle this L<AnyEvent::Handle> object will operate on.
73 74
74NOTE: The filehandle will be set to non-blocking (using 75NOTE: The filehandle will be set to non-blocking (using
75AnyEvent::Util::fh_nonblocking). 76AnyEvent::Util::fh_nonblocking).
76 77
77=item on_eof => $cb->($self) [MANDATORY] 78=item on_eof => $cb->($self)
78 79
79Set the callback to be called on EOF. 80Set the callback to be called on EOF.
80 81
82While not mandatory, it is highly recommended to set an eof callback,
83otherwise you might end up with a closed socket while you are still
84waiting for data.
85
81=item on_error => $cb->($self) 86=item on_error => $cb->($self)
82 87
83This 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
84ocurs, 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
85or a read error. 90or a read error.
86 91
87The 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
88called. 93called.
89 94
90On callback entrance, the value of C<$!> contains the operating system 95On callback entrance, the value of C<$!> contains the operating system
91error (or C<ENOSPC> or C<EPIPE>). 96error (or C<ENOSPC>, C<EPIPE> or C<EBADMSG>).
92 97
93While 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
94you will not be notified of errors otherwise. The default simply calls 99you will not be notified of errors otherwise. The default simply calls
95die. 100die.
96 101
… …
98 103
99This sets the default read callback, which is called when data arrives 104This sets the default read callback, which is called when data arrives
100and no read request is in the queue. 105and no read request is in the queue.
101 106
102To 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 >>
103method or acces sthe C<$self->{rbuf}> member directly. 108method or access the C<$self->{rbuf}> member directly.
104 109
105When 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
106feed 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
107calling 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
108error will be raised (with C<$!> set to C<EPIPE>). 113error will be raised (with C<$!> set to C<EPIPE>).
… …
135 140
136Sets 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
137buffer: 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
138considered empty. 143considered empty.
139 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
140=back 170=back
141 171
142=cut 172=cut
143 173
144sub new { 174sub new {
… …
148 178
149 $self->{fh} or Carp::croak "mandatory argument fh is missing"; 179 $self->{fh} or Carp::croak "mandatory argument fh is missing";
150 180
151 AnyEvent::Util::fh_nonblocking $self->{fh}, 1; 181 AnyEvent::Util::fh_nonblocking $self->{fh}, 1;
152 182
153 $self->on_eof ((delete $self->{on_eof} ) or Carp::croak "mandatory argument on_eof is missing"); 183 if ($self->{tls}) {
184 require Net::SSLeay;
185 $self->starttls (delete $self->{tls}, delete $self->{tls_ctx});
186 }
154 187
188 $self->on_eof (delete $self->{on_eof} ) if $self->{on_eof};
155 $self->on_error (delete $self->{on_error}) if $self->{on_error}; 189 $self->on_error (delete $self->{on_error}) if $self->{on_error};
156 $self->on_drain (delete $self->{on_drain}) if $self->{on_drain}; 190 $self->on_drain (delete $self->{on_drain}) if $self->{on_drain};
157 $self->on_read (delete $self->{on_read} ) if $self->{on_read}; 191 $self->on_read (delete $self->{on_read} ) if $self->{on_read};
158 192
159 $self->start_read; 193 $self->start_read;
… …
178 } 212 }
179 213
180 if ($self->{on_error}) { 214 if ($self->{on_error}) {
181 $self->{on_error}($self); 215 $self->{on_error}($self);
182 } else { 216 } else {
183 die "AnyEvent::Handle uncaught fatal error: $!"; 217 Carp::croak "AnyEvent::Handle uncaught fatal error: $!";
184 } 218 }
185} 219}
186 220
187=item $fh = $handle->fh 221=item $fh = $handle->fh
188 222
189This method returns the filehandle of the L<AnyEvent::Handle> object. 223This method returns the file handle of the L<AnyEvent::Handle> object.
190 224
191=cut 225=cut
192 226
193sub fh { $_[0]->{fh} } 227sub fh { $_[0]->{fh} }
194 228
… …
222for reading. 256for reading.
223 257
224The 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
225AnyEvent::Handle will automatically try to get rid of it for you. 259AnyEvent::Handle will automatically try to get rid of it for you.
226 260
227When 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
228water mark, the C<on_drain> callback will be invoked. 262water mark, the C<on_drain> callback will be invoked.
229 263
230=over 4 264=over 4
231 265
232=item $handle->on_drain ($cb) 266=item $handle->on_drain ($cb)
… …
251want (only limited by the available memory), as C<AnyEvent::Handle> 285want (only limited by the available memory), as C<AnyEvent::Handle>
252buffers it independently of the kernel. 286buffers it independently of the kernel.
253 287
254=cut 288=cut
255 289
256sub push_write { 290sub _drain_wbuf {
257 my ($self, $data) = @_; 291 my ($self) = @_;
258 292
259 $self->{wbuf} .= $data; 293 if (!$self->{ww} && length $self->{wbuf}) {
260
261 unless ($self->{ww}) {
262 Scalar::Util::weaken $self; 294 Scalar::Util::weaken $self;
263 my $cb = sub { 295 my $cb = sub {
264 my $len = syswrite $self->{fh}, $self->{wbuf}; 296 my $len = syswrite $self->{fh}, $self->{wbuf};
265 297
266 if ($len > 0) { 298 if ($len >= 0) {
267 substr $self->{wbuf}, 0, $len, ""; 299 substr $self->{wbuf}, 0, $len, "";
268
269 300
270 $self->{on_drain}($self) 301 $self->{on_drain}($self)
271 if $self->{low_water_mark} >= length $self->{wbuf} 302 if $self->{low_water_mark} >= length $self->{wbuf}
272 && $self->{on_drain}; 303 && $self->{on_drain};
273 304
274 delete $self->{ww} unless length $self->{wbuf}; 305 delete $self->{ww} unless length $self->{wbuf};
275 } elsif ($! != EAGAIN && $! != EINTR) { 306 } elsif ($! != EAGAIN && $! != EINTR && $! != WSAWOULDBLOCK) {
276 $self->error; 307 $self->error;
277 } 308 }
278 }; 309 };
279 310
280 $self->{ww} = AnyEvent->io (fh => $self->{fh}, poll => "w", cb => $cb); 311 $self->{ww} = AnyEvent->io (fh => $self->{fh}, poll => "w", cb => $cb);
281 312
282 $cb->($self); 313 $cb->($self);
283 }; 314 };
284} 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
285 381
286############################################################################# 382#############################################################################
287 383
288=back 384=back
289 385
… …
364=cut 460=cut
365 461
366sub _drain_rbuf { 462sub _drain_rbuf {
367 my ($self) = @_; 463 my ($self) = @_;
368 464
465 if (
466 defined $self->{rbuf_max}
467 && $self->{rbuf_max} < length $self->{rbuf}
468 ) {
469 $! = &Errno::ENOSPC; return $self->error;
470 }
471
369 return if $self->{in_drain}; 472 return if $self->{in_drain};
370 local $self->{in_drain} = 1; 473 local $self->{in_drain} = 1;
371 474
372 while (my $len = length $self->{rbuf}) { 475 while (my $len = length $self->{rbuf}) {
373 no strict 'refs'; 476 no strict 'refs';
374 if (my $cb = shift @{ $self->{queue} }) { 477 if (my $cb = shift @{ $self->{queue} }) {
375 if (!$cb->($self)) { 478 unless ($cb->($self)) {
376 if ($self->{eof}) { 479 if ($self->{eof}) {
377 # 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)
378 $! = &Errno::EPIPE; return $self->error; 481 $! = &Errno::EPIPE; return $self->error;
379 } 482 }
380 483
… …
400 } 503 }
401 } 504 }
402 505
403 if ($self->{eof}) { 506 if ($self->{eof}) {
404 $self->_shutdown; 507 $self->_shutdown;
405 $self->{on_eof}($self); 508 $self->{on_eof}($self)
509 if $self->{on_eof};
406 } 510 }
407} 511}
408 512
409=item $handle->on_read ($cb) 513=item $handle->on_read ($cb)
410 514
… …
444Append 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
445prepend it (C<unshift_read>). 549prepend it (C<unshift_read>).
446 550
447The callback is called each time some additional read data arrives. 551The callback is called each time some additional read data arrives.
448 552
449It must check wether enough data is in the read buffer already. 553It must check whether enough data is in the read buffer already.
450 554
451If 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
452value, 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
453available (or an error condition is detected). 557available (or an error condition is detected).
454 558
… …
456interested 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
457true, it will be removed from the queue. 561true, it will be removed from the queue.
458 562
459=cut 563=cut
460 564
565our %RH;
566
567sub register_read_type($$) {
568 $RH{$_[0]} = $_[1];
569}
570
461sub push_read { 571sub push_read {
462 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 }
463 581
464 push @{ $self->{queue} }, $cb; 582 push @{ $self->{queue} }, $cb;
465 $self->_drain_rbuf; 583 $self->_drain_rbuf;
466} 584}
467 585
468sub unshift_read { 586sub unshift_read {
469 my ($self, $cb) = @_; 587 my $self = shift;
588 my $cb = pop;
470 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
471 push @{ $self->{queue} }, $cb; 598 unshift @{ $self->{queue} }, $cb;
472 $self->_drain_rbuf; 599 $self->_drain_rbuf;
473} 600}
474 601
475=item $handle->push_read_chunk ($len, $cb->($self, $data)) 602=item $handle->push_read (type => @args, $cb)
476 603
477=item $handle->unshift_read_chunk ($len, $cb->($self, $data)) 604=item $handle->unshift_read (type => @args, $cb)
478 605
479Append 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
480prepend it (C<unshift_read_chunk>). 607between a number of predefined parsing formats, for chunks of data, lines
608etc.
481 609
482The 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
483these C<$len> bytes will be passed to the callback. 611drop by and tell us):
484 612
485=cut 613=over 4
486 614
487sub _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 {
488 my ($self, $len, $cb) = @_; 630 my ($self, $cb, $len) = @_;
489 631
490 sub { 632 sub {
491 $len <= length $_[0]{rbuf} or return; 633 $len <= length $_[0]{rbuf} or return;
492 $cb->($_[0], substr $_[0]{rbuf}, 0, $len, ""); 634 $cb->($_[0], substr $_[0]{rbuf}, 0, $len, "");
493 1 635 1
494 } 636 }
495} 637};
496 638
639# compatibility with older API
497sub push_read_chunk { 640sub push_read_chunk {
498 $_[0]->push_read (&_read_chunk); 641 $_[0]->push_read (chunk => $_[1], $_[2]);
499} 642}
500
501 643
502sub unshift_read_chunk { 644sub unshift_read_chunk {
503 $_[0]->unshift_read (&_read_chunk); 645 $_[0]->unshift_read (chunk => $_[1], $_[2]);
504} 646}
505 647
506=item $handle->push_read_line ([$eol, ]$cb->($self, $line, $eol)) 648=item line => [$eol, ]$cb->($self, $line, $eol)
507
508=item $handle->unshift_read_line ([$eol, ]$cb->($self, $line, $eol))
509
510Append the given callback to the end of the queue (C<push_read_line>) or
511prepend it (C<unshift_read_line>).
512 649
513The 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
514line 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
515marker) 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
516the end of line marker as the third argument (C<$eol>). 653the end of line marker as the third argument (C<$eol>).
… …
527Partial 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
528not marked by the end of line marker. 665not marked by the end of line marker.
529 666
530=cut 667=cut
531 668
532sub _read_line($$) { 669register_read_type line => sub {
533 my $self = shift; 670 my ($self, $cb, $eol) = @_;
534 my $cb = pop;
535 my $eol = @_ ? shift : qr|(\015?\012)|;
536 my $pos;
537 671
672 $eol = qr|(\015?\012)| if @_ < 3;
538 $eol = quotemeta $eol unless ref $eol; 673 $eol = quotemeta $eol unless ref $eol;
539 $eol = qr|^(.*?)($eol)|s; 674 $eol = qr|^(.*?)($eol)|s;
540 675
541 sub { 676 sub {
542 $_[0]{rbuf} =~ s/$eol// or return; 677 $_[0]{rbuf} =~ s/$eol// or return;
543 678
544 $cb->($_[0], $1, $2); 679 $cb->($_[0], $1, $2);
545 1 680 1
546 } 681 }
547} 682};
548 683
684# compatibility with older API
549sub push_read_line { 685sub push_read_line {
550 $_[0]->push_read (&_read_line); 686 my $self = shift;
687 $self->push_read (line => @_);
551} 688}
552 689
553sub unshift_read_line { 690sub unshift_read_line {
554 $_[0]->unshift_read (&_read_line); 691 my $self = shift;
692 $self->unshift_read (line => @_);
555} 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>)).
556 754
557=item $handle->stop_read 755=item $handle->stop_read
558 756
559=item $handle->start_read 757=item $handle->start_read
560 758
561In 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
562socket. 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
563any queued callbacks will be executed then. To start readign again, call 761any queued callbacks will be executed then. To start reading again, call
564C<start_read>. 762C<start_read>.
565 763
566=cut 764=cut
567 765
568sub stop_read { 766sub stop_read {
… …
576 774
577 unless ($self->{rw} || $self->{eof}) { 775 unless ($self->{rw} || $self->{eof}) {
578 Scalar::Util::weaken $self; 776 Scalar::Util::weaken $self;
579 777
580 $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};
581 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;
582 781
583 if ($len > 0) { 782 if ($len > 0) {
584 if (defined $self->{rbuf_max}) { 783 $self->{filter_r}
585 if ($self->{rbuf_max} < length $self->{rbuf}) { 784 ? $self->{filter_r}->($self, $rbuf)
586 $! = &Errno::ENOSPC; return $self->error; 785 : $self->_drain_rbuf;
587 }
588 }
589 786
590 } elsif (defined $len) { 787 } elsif (defined $len) {
788 delete $self->{rw};
591 $self->{eof} = 1; 789 $self->{eof} = 1;
592 delete $self->{rw}; 790 $self->_drain_rbuf;
593 791
594 } elsif ($! != EAGAIN && $! != EINTR) { 792 } elsif ($! != EAGAIN && $! != EINTR && $! != &AnyEvent::Util::WSAWOULDBLOCK) {
595 return $self->error; 793 return $self->error;
596 } 794 }
597
598 $self->_drain_rbuf;
599 }); 795 });
600 } 796 }
601} 797}
602 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
603=back 945=back
604 946
605=head1 AUTHOR 947=head1 AUTHOR
606 948
607Robin 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