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.30 by root, Sat May 24 23:56:26 2008 UTC

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

Diff Legend

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