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.17 by root, Sat May 24 04:17:45 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
… …
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)
… …
257=cut 288=cut
258 289
259sub _drain_wbuf { 290sub _drain_wbuf {
260 my ($self) = @_; 291 my ($self) = @_;
261 292
262 unless ($self->{ww}) { 293 if (!$self->{ww} && length $self->{wbuf}) {
263 Scalar::Util::weaken $self; 294 Scalar::Util::weaken $self;
264 my $cb = sub { 295 my $cb = sub {
265 my $len = syswrite $self->{fh}, $self->{wbuf}; 296 my $len = syswrite $self->{fh}, $self->{wbuf};
266 297
267 if ($len > 0) { 298 if ($len >= 0) {
268 substr $self->{wbuf}, 0, $len, ""; 299 substr $self->{wbuf}, 0, $len, "";
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}
285 316
317our %WH;
318
319sub register_write_type($$) {
320 $WH{$_[0]} = $_[1];
321}
322
286sub push_write { 323sub push_write {
287 my $self = shift; 324 my $self = shift;
288 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
289 if ($self->{filter_w}) { 333 if ($self->{filter_w}) {
290 $self->{filter_w}->(\$_[0]); 334 $self->{filter_w}->($self, \$_[0]);
291 } else { 335 } else {
292 $self->{wbuf} .= $_[0]; 336 $self->{wbuf} .= $_[0];
293 $self->_drain_wbuf; 337 $self->_drain_wbuf;
294 } 338 }
295} 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
296 381
297############################################################################# 382#############################################################################
298 383
299=back 384=back
300 385
… …
388 local $self->{in_drain} = 1; 473 local $self->{in_drain} = 1;
389 474
390 while (my $len = length $self->{rbuf}) { 475 while (my $len = length $self->{rbuf}) {
391 no strict 'refs'; 476 no strict 'refs';
392 if (my $cb = shift @{ $self->{queue} }) { 477 if (my $cb = shift @{ $self->{queue} }) {
393 if (!$cb->($self)) { 478 unless ($cb->($self)) {
394 if ($self->{eof}) { 479 if ($self->{eof}) {
395 # 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)
396 $! = &Errno::EPIPE; return $self->error; 481 $! = &Errno::EPIPE; return $self->error;
397 } 482 }
398 483
… …
463Append 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
464prepend it (C<unshift_read>). 549prepend it (C<unshift_read>).
465 550
466The callback is called each time some additional read data arrives. 551The callback is called each time some additional read data arrives.
467 552
468It must check wether enough data is in the read buffer already. 553It must check whether enough data is in the read buffer already.
469 554
470If 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
471value, 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
472available (or an error condition is detected). 557available (or an error condition is detected).
473 558
… …
475interested 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
476true, it will be removed from the queue. 561true, it will be removed from the queue.
477 562
478=cut 563=cut
479 564
565our %RH;
566
567sub register_read_type($$) {
568 $RH{$_[0]} = $_[1];
569}
570
480sub push_read { 571sub push_read {
481 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 }
482 581
483 push @{ $self->{queue} }, $cb; 582 push @{ $self->{queue} }, $cb;
484 $self->_drain_rbuf; 583 $self->_drain_rbuf;
485} 584}
486 585
487sub unshift_read { 586sub unshift_read {
488 my ($self, $cb) = @_; 587 my $self = shift;
588 my $cb = pop;
489 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
490 push @{ $self->{queue} }, $cb; 598 unshift @{ $self->{queue} }, $cb;
491 $self->_drain_rbuf; 599 $self->_drain_rbuf;
492} 600}
493 601
494=item $handle->push_read_chunk ($len, $cb->($self, $data)) 602=item $handle->push_read (type => @args, $cb)
495 603
496=item $handle->unshift_read_chunk ($len, $cb->($self, $data)) 604=item $handle->unshift_read (type => @args, $cb)
497 605
498Append 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
499prepend it (C<unshift_read_chunk>). 607between a number of predefined parsing formats, for chunks of data, lines
608etc.
500 609
501The 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
502these C<$len> bytes will be passed to the callback. 611drop by and tell us):
503 612
504=cut 613=over 4
505 614
506sub _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 {
507 my ($self, $len, $cb) = @_; 630 my ($self, $cb, $len) = @_;
508 631
509 sub { 632 sub {
510 $len <= length $_[0]{rbuf} or return; 633 $len <= length $_[0]{rbuf} or return;
511 $cb->($_[0], substr $_[0]{rbuf}, 0, $len, ""); 634 $cb->($_[0], substr $_[0]{rbuf}, 0, $len, "");
512 1 635 1
513 } 636 }
514} 637};
515 638
639# compatibility with older API
516sub push_read_chunk { 640sub push_read_chunk {
517 $_[0]->push_read (&_read_chunk); 641 $_[0]->push_read (chunk => $_[1], $_[2]);
518} 642}
519
520 643
521sub unshift_read_chunk { 644sub unshift_read_chunk {
522 $_[0]->unshift_read (&_read_chunk); 645 $_[0]->unshift_read (chunk => $_[1], $_[2]);
523} 646}
524 647
525=item $handle->push_read_line ([$eol, ]$cb->($self, $line, $eol)) 648=item line => [$eol, ]$cb->($self, $line, $eol)
526
527=item $handle->unshift_read_line ([$eol, ]$cb->($self, $line, $eol))
528
529Append the given callback to the end of the queue (C<push_read_line>) or
530prepend it (C<unshift_read_line>).
531 649
532The 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
533line 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
534marker) 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
535the end of line marker as the third argument (C<$eol>). 653the end of line marker as the third argument (C<$eol>).
… …
546Partial 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
547not marked by the end of line marker. 665not marked by the end of line marker.
548 666
549=cut 667=cut
550 668
551sub _read_line($$) { 669register_read_type line => sub {
552 my $self = shift; 670 my ($self, $cb, $eol) = @_;
553 my $cb = pop;
554 my $eol = @_ ? shift : qr|(\015?\012)|;
555 my $pos;
556 671
672 $eol = qr|(\015?\012)| if @_ < 3;
557 $eol = quotemeta $eol unless ref $eol; 673 $eol = quotemeta $eol unless ref $eol;
558 $eol = qr|^(.*?)($eol)|s; 674 $eol = qr|^(.*?)($eol)|s;
559 675
560 sub { 676 sub {
561 $_[0]{rbuf} =~ s/$eol// or return; 677 $_[0]{rbuf} =~ s/$eol// or return;
562 678
563 $cb->($_[0], $1, $2); 679 $cb->($_[0], $1, $2);
564 1 680 1
565 } 681 }
566} 682};
567 683
684# compatibility with older API
568sub push_read_line { 685sub push_read_line {
569 $_[0]->push_read (&_read_line); 686 my $self = shift;
687 $self->push_read (line => @_);
570} 688}
571 689
572sub unshift_read_line { 690sub unshift_read_line {
573 $_[0]->unshift_read (&_read_line); 691 my $self = shift;
692 $self->unshift_read (line => @_);
574} 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>)).
575 754
576=item $handle->stop_read 755=item $handle->stop_read
577 756
578=item $handle->start_read 757=item $handle->start_read
579 758
580In 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
581socket. 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
582any queued callbacks will be executed then. To start readign again, call 761any queued callbacks will be executed then. To start reading again, call
583C<start_read>. 762C<start_read>.
584 763
585=cut 764=cut
586 765
587sub stop_read { 766sub stop_read {
… …
600 my $rbuf = $self->{filter_r} ? \my $buf : \$self->{rbuf}; 779 my $rbuf = $self->{filter_r} ? \my $buf : \$self->{rbuf};
601 my $len = sysread $self->{fh}, $$rbuf, $self->{read_size} || 8192, length $$rbuf; 780 my $len = sysread $self->{fh}, $$rbuf, $self->{read_size} || 8192, length $$rbuf;
602 781
603 if ($len > 0) { 782 if ($len > 0) {
604 $self->{filter_r} 783 $self->{filter_r}
605 ? $self->{filter_r}->($rbuf) 784 ? $self->{filter_r}->($self, $rbuf)
606 : $self->_drain_rbuf; 785 : $self->_drain_rbuf;
607 786
608 } elsif (defined $len) { 787 } elsif (defined $len) {
609 delete $self->{rw}; 788 delete $self->{rw};
610 $self->{eof} = 1; 789 $self->{eof} = 1;
611 $self->_drain_rbuf; 790 $self->_drain_rbuf;
612 791
613 } elsif ($! != EAGAIN && $! != EINTR) { 792 } elsif ($! != EAGAIN && $! != EINTR && $! != &AnyEvent::Util::WSAWOULDBLOCK) {
614 return $self->error; 793 return $self->error;
615 } 794 }
616 }); 795 });
617 } 796 }
618} 797}
619 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
620=back 945=back
621 946
622=head1 AUTHOR 947=head1 AUTHOR
623 948
624Robin 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