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.159 by root, Fri Jul 24 12:35:58 2009 UTC vs.
Revision 1.180 by root, Thu Aug 20 22:58:35 2009 UTC

1package AnyEvent::Handle;
2
3use Scalar::Util ();
4use Carp ();
5use Errno qw(EAGAIN EINTR);
6
7use AnyEvent (); BEGIN { AnyEvent::common_sense }
8use AnyEvent::Util qw(WSAEWOULDBLOCK);
9
10=head1 NAME 1=head1 NAME
11 2
12AnyEvent::Handle - non-blocking I/O on file handles via AnyEvent 3AnyEvent::Handle - non-blocking I/O on file handles via AnyEvent
13
14=cut
15
16our $VERSION = 4.86;
17 4
18=head1 SYNOPSIS 5=head1 SYNOPSIS
19 6
20 use AnyEvent; 7 use AnyEvent;
21 use AnyEvent::Handle; 8 use AnyEvent::Handle;
… …
59C<on_error> callback. 46C<on_error> callback.
60 47
61All callbacks will be invoked with the handle object as their first 48All callbacks will be invoked with the handle object as their first
62argument. 49argument.
63 50
51=cut
52
53package AnyEvent::Handle;
54
55use Scalar::Util ();
56use List::Util ();
57use Carp ();
58use Errno qw(EAGAIN EINTR);
59
60use AnyEvent (); BEGIN { AnyEvent::common_sense }
61use AnyEvent::Util qw(WSAEWOULDBLOCK);
62
63our $VERSION = $AnyEvent::VERSION;
64
64=head1 METHODS 65=head1 METHODS
65 66
66=over 4 67=over 4
67 68
68=item $handle = B<new> AnyEvent::TLS fh => $filehandle, key => value... 69=item $handle = B<new> AnyEvent::TLS fh => $filehandle, key => value...
… …
83Try to connect to the specified host and service (port), using 84Try to connect to the specified host and service (port), using
84C<AnyEvent::Socket::tcp_connect>. The C<$host> additionally becomes the 85C<AnyEvent::Socket::tcp_connect>. The C<$host> additionally becomes the
85default C<peername>. 86default C<peername>.
86 87
87You have to specify either this parameter, or C<fh>, above. 88You have to specify either this parameter, or C<fh>, above.
89
90It is possible to push requests on the read and write queues, and modify
91properties of the stream, even while AnyEvent::Handle is connecting.
88 92
89When this parameter is specified, then the C<on_prepare>, 93When this parameter is specified, then the C<on_prepare>,
90C<on_connect_error> and C<on_connect> callbacks will be called under the 94C<on_connect_error> and C<on_connect> callbacks will be called under the
91appropriate circumstances: 95appropriate circumstances:
92 96
… …
97This (rarely used) callback is called before a new connection is 101This (rarely used) callback is called before a new connection is
98attempted, but after the file handle has been created. It could be used to 102attempted, but after the file handle has been created. It could be used to
99prepare the file handle with parameters required for the actual connect 103prepare the file handle with parameters required for the actual connect
100(as opposed to settings that can be changed when the connection is already 104(as opposed to settings that can be changed when the connection is already
101established). 105established).
106
107The return value of this callback should be the connect timeout value in
108seconds (or C<0>, or C<undef>, or the empty list, to indicate the default
109timeout is to be used).
102 110
103=item on_connect => $cb->($handle, $host, $port, $retry->()) 111=item on_connect => $cb->($handle, $host, $port, $retry->())
104 112
105This callback is called when a connection has been successfully established. 113This callback is called when a connection has been successfully established.
106 114
… …
209memory and push it into the queue, but instead only read more data from 217memory and push it into the queue, but instead only read more data from
210the file when the write queue becomes empty. 218the file when the write queue becomes empty.
211 219
212=item timeout => $fractional_seconds 220=item timeout => $fractional_seconds
213 221
222=item rtimeout => $fractional_seconds
223
224=item wtimeout => $fractional_seconds
225
214If non-zero, then this enables an "inactivity" timeout: whenever this many 226If non-zero, then these enables an "inactivity" timeout: whenever this
215seconds pass without a successful read or write on the underlying file 227many seconds pass without a successful read or write on the underlying
216handle, the C<on_timeout> callback will be invoked (and if that one is 228file handle (or a call to C<timeout_reset>), the C<on_timeout> callback
217missing, a non-fatal C<ETIMEDOUT> error will be raised). 229will be invoked (and if that one is missing, a non-fatal C<ETIMEDOUT>
230error will be raised).
231
232There are three variants of the timeouts that work fully independent
233of each other, for both read and write, just read, and just write:
234C<timeout>, C<rtimeout> and C<wtimeout>, with corresponding callbacks
235C<on_timeout>, C<on_rtimeout> and C<on_wtimeout>, and reset functions
236C<timeout_reset>, C<rtimeout_reset>, and C<wtimeout_reset>.
218 237
219Note that timeout processing is also active when you currently do not have 238Note that timeout processing is also active when you currently do not have
220any outstanding read or write requests: If you plan to keep the connection 239any outstanding read or write requests: If you plan to keep the connection
221idle then you should disable the timout temporarily or ignore the timeout 240idle then you should disable the timout temporarily or ignore the timeout
222in the C<on_timeout> callback, in which case AnyEvent::Handle will simply 241in the C<on_timeout> callback, in which case AnyEvent::Handle will simply
… …
431 delete $self->{_skip_drain_rbuf}; 450 delete $self->{_skip_drain_rbuf};
432 $self->_start; 451 $self->_start;
433 452
434 $self->{on_connect} 453 $self->{on_connect}
435 and $self->{on_connect}($self, $host, $port, sub { 454 and $self->{on_connect}($self, $host, $port, sub {
436 delete @$self{qw(fh _tw _ww _rw _eof _queue rbuf _wbuf tls _tls_rbuf _tls_wbuf)}; 455 delete @$self{qw(fh _tw _rtw _wtw _ww _rw _eof _queue rbuf _wbuf tls _tls_rbuf _tls_wbuf)};
437 $self->{_skip_drain_rbuf} = 1; 456 $self->{_skip_drain_rbuf} = 1;
438 &$retry; 457 &$retry;
439 }); 458 });
440 459
441 } else { 460 } else {
442 if ($self->{on_connect_error}) { 461 if ($self->{on_connect_error}) {
443 $self->{on_connect_error}($self, "$!"); 462 $self->{on_connect_error}($self, "$!");
444 $self->destroy; 463 $self->destroy;
445 } else { 464 } else {
446 $self->fatal ($!, 1); 465 $self->_error ($!, 1);
447 } 466 }
448 } 467 }
449 }, 468 },
450 sub { 469 sub {
451 local $self->{fh} = $_[0]; 470 local $self->{fh} = $_[0];
452 471
472 $self->{on_prepare}
453 $self->{on_prepare}->($self) 473 ? $self->{on_prepare}->($self)
454 if $self->{on_prepare}; 474 : ()
455 } 475 }
456 ); 476 );
457 } 477 }
458 478
459 } else { 479 } else {
… …
466sub _start { 486sub _start {
467 my ($self) = @_; 487 my ($self) = @_;
468 488
469 AnyEvent::Util::fh_nonblocking $self->{fh}, 1; 489 AnyEvent::Util::fh_nonblocking $self->{fh}, 1;
470 490
491 $self->{_activity} =
492 $self->{_ractivity} =
471 $self->{_activity} = AnyEvent->now; 493 $self->{_wactivity} = AE::now;
472 $self->_timeout; 494
495 $self->timeout (delete $self->{timeout} ) if $self->{timeout};
496 $self->rtimeout (delete $self->{rtimeout}) if $self->{rtimeout};
497 $self->wtimeout (delete $self->{wtimeout}) if $self->{wtimeout};
473 498
474 $self->no_delay (delete $self->{no_delay}) if exists $self->{no_delay}; 499 $self->no_delay (delete $self->{no_delay}) if exists $self->{no_delay};
475 500
476 $self->starttls (delete $self->{tls}, delete $self->{tls_ctx}) 501 $self->starttls (delete $self->{tls}, delete $self->{tls_ctx})
477 if $self->{tls}; 502 if $self->{tls};
478 503
479 $self->on_drain (delete $self->{on_drain}) if $self->{on_drain}; 504 $self->on_drain (delete $self->{on_drain}) if $self->{on_drain};
480 505
481 $self->start_read 506 $self->start_read
482 if $self->{on_read} || @{ $self->{_queue} }; 507 if $self->{on_read} || @{ $self->{_queue} };
483}
484 508
485#sub _shutdown { 509 $self->_drain_wbuf;
486# my ($self) = @_; 510}
487#
488# delete @$self{qw(_tw _rw _ww fh wbuf on_read _queue)};
489# $self->{_eof} = 1; # tell starttls et. al to stop trying
490#
491# &_freetls;
492#}
493 511
494sub _error { 512sub _error {
495 my ($self, $errno, $fatal, $message) = @_; 513 my ($self, $errno, $fatal, $message) = @_;
496 514
497 $! = $errno; 515 $! = $errno;
… …
534 $_[0]{on_eof} = $_[1]; 552 $_[0]{on_eof} = $_[1];
535} 553}
536 554
537=item $handle->on_timeout ($cb) 555=item $handle->on_timeout ($cb)
538 556
539Replace the current C<on_timeout> callback, or disables the callback (but 557=item $handle->on_rtimeout ($cb)
540not the timeout) if C<$cb> = C<undef>. See the C<timeout> constructor
541argument and method.
542 558
543=cut 559=item $handle->on_wtimeout ($cb)
544 560
545sub on_timeout { 561Replace the current C<on_timeout>, C<on_rtimeout> or C<on_wtimeout>
546 $_[0]{on_timeout} = $_[1]; 562callback, or disables the callback (but not the timeout) if C<$cb> =
547} 563C<undef>. See the C<timeout> constructor argument and method.
564
565=cut
566
567# see below
548 568
549=item $handle->autocork ($boolean) 569=item $handle->autocork ($boolean)
550 570
551Enables or disables the current autocork behaviour (see C<autocork> 571Enables or disables the current autocork behaviour (see C<autocork>
552constructor argument). Changes will only take effect on the next write. 572constructor argument). Changes will only take effect on the next write.
… …
592 612
593sub on_starttls { 613sub on_starttls {
594 $_[0]{on_stoptls} = $_[1]; 614 $_[0]{on_stoptls} = $_[1];
595} 615}
596 616
617=item $handle->rbuf_max ($max_octets)
618
619Configures the C<rbuf_max> setting (C<undef> disables it).
620
621=cut
622
623sub rbuf_max {
624 $_[0]{rbuf_max} = $_[1];
625}
626
597############################################################################# 627#############################################################################
598 628
599=item $handle->timeout ($seconds) 629=item $handle->timeout ($seconds)
600 630
631=item $handle->rtimeout ($seconds)
632
633=item $handle->wtimeout ($seconds)
634
601Configures (or disables) the inactivity timeout. 635Configures (or disables) the inactivity timeout.
602 636
603=cut 637=item $handle->timeout_reset
604 638
605sub timeout { 639=item $handle->rtimeout_reset
640
641=item $handle->wtimeout_reset
642
643Reset the activity timeout, as if data was received or sent.
644
645These methods are cheap to call.
646
647=cut
648
649for my $dir ("", "r", "w") {
650 my $timeout = "${dir}timeout";
651 my $tw = "_${dir}tw";
652 my $on_timeout = "on_${dir}timeout";
653 my $activity = "_${dir}activity";
654 my $cb;
655
656 *$on_timeout = sub {
657 $_[0]{$on_timeout} = $_[1];
658 };
659
660 *$timeout = sub {
606 my ($self, $timeout) = @_; 661 my ($self, $new_value) = @_;
607 662
608 $self->{timeout} = $timeout; 663 $self->{$timeout} = $new_value;
609 $self->_timeout; 664 delete $self->{$tw}; &$cb;
610} 665 };
611 666
667 *{"${dir}timeout_reset"} = sub {
668 $_[0]{$activity} = AE::now;
669 };
670
671 # main workhorse:
612# reset the timeout watcher, as neccessary 672 # reset the timeout watcher, as neccessary
613# also check for time-outs 673 # also check for time-outs
614sub _timeout { 674 $cb = sub {
615 my ($self) = @_; 675 my ($self) = @_;
616 676
617 if ($self->{timeout} && $self->{fh}) { 677 if ($self->{$timeout} && $self->{fh}) {
618 my $NOW = AnyEvent->now; 678 my $NOW = AE::now;
619 679
620 # when would the timeout trigger? 680 # when would the timeout trigger?
621 my $after = $self->{_activity} + $self->{timeout} - $NOW; 681 my $after = $self->{$activity} + $self->{$timeout} - $NOW;
622 682
623 # now or in the past already? 683 # now or in the past already?
624 if ($after <= 0) { 684 if ($after <= 0) {
625 $self->{_activity} = $NOW; 685 $self->{$activity} = $NOW;
626 686
627 if ($self->{on_timeout}) { 687 if ($self->{$on_timeout}) {
628 $self->{on_timeout}($self); 688 $self->{$on_timeout}($self);
629 } else { 689 } else {
630 $self->_error (Errno::ETIMEDOUT); 690 $self->_error (Errno::ETIMEDOUT);
691 }
692
693 # callback could have changed timeout value, optimise
694 return unless $self->{$timeout};
695
696 # calculate new after
697 $after = $self->{$timeout};
631 } 698 }
632 699
633 # callback could have changed timeout value, optimise 700 Scalar::Util::weaken $self;
634 return unless $self->{timeout}; 701 return unless $self; # ->error could have destroyed $self
635 702
636 # calculate new after 703 $self->{$tw} ||= AE::timer $after, 0, sub {
637 $after = $self->{timeout}; 704 delete $self->{$tw};
705 $cb->($self);
706 };
707 } else {
708 delete $self->{$tw};
638 } 709 }
639
640 Scalar::Util::weaken $self;
641 return unless $self; # ->error could have destroyed $self
642
643 $self->{_tw} ||= AnyEvent->timer (after => $after, cb => sub {
644 delete $self->{_tw};
645 $self->_timeout;
646 });
647 } else {
648 delete $self->{_tw};
649 } 710 }
650} 711}
651 712
652############################################################################# 713#############################################################################
653 714
… …
701 my $len = syswrite $self->{fh}, $self->{wbuf}; 762 my $len = syswrite $self->{fh}, $self->{wbuf};
702 763
703 if (defined $len) { 764 if (defined $len) {
704 substr $self->{wbuf}, 0, $len, ""; 765 substr $self->{wbuf}, 0, $len, "";
705 766
706 $self->{_activity} = AnyEvent->now; 767 $self->{_activity} = $self->{_wactivity} = AE::now;
707 768
708 $self->{on_drain}($self) 769 $self->{on_drain}($self)
709 if $self->{low_water_mark} >= (length $self->{wbuf}) + (length $self->{_tls_wbuf}) 770 if $self->{low_water_mark} >= (length $self->{wbuf}) + (length $self->{_tls_wbuf})
710 && $self->{on_drain}; 771 && $self->{on_drain};
711 772
… …
717 778
718 # try to write data immediately 779 # try to write data immediately
719 $cb->() unless $self->{autocork}; 780 $cb->() unless $self->{autocork};
720 781
721 # if still data left in wbuf, we need to poll 782 # if still data left in wbuf, we need to poll
722 $self->{_ww} = AnyEvent->io (fh => $self->{fh}, poll => "w", cb => $cb) 783 $self->{_ww} = AE::io $self->{fh}, 1, $cb
723 if length $self->{wbuf}; 784 if length $self->{wbuf};
724 }; 785 };
725} 786}
726 787
727our %WH; 788our %WH;
… …
740 ->($self, @_); 801 ->($self, @_);
741 } 802 }
742 803
743 if ($self->{tls}) { 804 if ($self->{tls}) {
744 $self->{_tls_wbuf} .= $_[0]; 805 $self->{_tls_wbuf} .= $_[0];
745 806 &_dotls ($self) if $self->{fh};
746 &_dotls ($self);
747 } else { 807 } else {
748 $self->{wbuf} .= $_[0]; 808 $self->{wbuf} .= $_[0];
749 $self->_drain_wbuf if $self->{fh}; 809 $self->_drain_wbuf if $self->{fh};
750 } 810 }
751} 811}
752 812
753=item $handle->push_write (type => @args) 813=item $handle->push_write (type => @args)
… …
818Other languages could read single lines terminated by a newline and pass 878Other languages could read single lines terminated by a newline and pass
819this line into their JSON decoder of choice. 879this line into their JSON decoder of choice.
820 880
821=cut 881=cut
822 882
883sub json_coder() {
884 eval { require JSON::XS; JSON::XS->new->utf8 }
885 || do { require JSON; JSON->new->utf8 }
886}
887
823register_write_type json => sub { 888register_write_type json => sub {
824 my ($self, $ref) = @_; 889 my ($self, $ref) = @_;
825 890
826 require JSON; 891 my $json = $self->{json} ||= json_coder;
827 892
828 $self->{json} ? $self->{json}->encode ($ref) 893 $json->encode ($ref)
829 : JSON::encode_json ($ref)
830}; 894};
831 895
832=item storable => $reference 896=item storable => $reference
833 897
834Freezes the given reference using L<Storable> and writes it to the 898Freezes the given reference using L<Storable> and writes it to the
… …
972 1036
973sub _drain_rbuf { 1037sub _drain_rbuf {
974 my ($self) = @_; 1038 my ($self) = @_;
975 1039
976 # avoid recursion 1040 # avoid recursion
977 return if exists $self->{_skip_drain_rbuf}; 1041 return if $self->{_skip_drain_rbuf};
978 local $self->{_skip_drain_rbuf} = 1; 1042 local $self->{_skip_drain_rbuf} = 1;
979
980 if (
981 defined $self->{rbuf_max}
982 && $self->{rbuf_max} < length $self->{rbuf}
983 ) {
984 $self->_error (Errno::ENOSPC, 1), return;
985 }
986 1043
987 while () { 1044 while () {
988 # we need to use a separate tls read buffer, as we must not receive data while 1045 # we need to use a separate tls read buffer, as we must not receive data while
989 # we are draining the buffer, and this can only happen with TLS. 1046 # we are draining the buffer, and this can only happen with TLS.
990 $self->{rbuf} .= delete $self->{_tls_rbuf} if exists $self->{_tls_rbuf}; 1047 $self->{rbuf} .= delete $self->{_tls_rbuf}
1048 if exists $self->{_tls_rbuf};
991 1049
992 my $len = length $self->{rbuf}; 1050 my $len = length $self->{rbuf};
993 1051
994 if (my $cb = shift @{ $self->{_queue} }) { 1052 if (my $cb = shift @{ $self->{_queue} }) {
995 unless ($cb->($self)) { 1053 unless ($cb->($self)) {
996 if ($self->{_eof}) { 1054 # no progress can be made
997 # no progress can be made (not enough data and no data forthcoming) 1055 # (not enough data and no data forthcoming)
998 $self->_error (Errno::EPIPE, 1), return; 1056 $self->_error (Errno::EPIPE, 1), return
999 } 1057 if $self->{_eof};
1000 1058
1001 unshift @{ $self->{_queue} }, $cb; 1059 unshift @{ $self->{_queue} }, $cb;
1002 last; 1060 last;
1003 } 1061 }
1004 } elsif ($self->{on_read}) { 1062 } elsif ($self->{on_read}) {
… …
1024 last; 1082 last;
1025 } 1083 }
1026 } 1084 }
1027 1085
1028 if ($self->{_eof}) { 1086 if ($self->{_eof}) {
1029 if ($self->{on_eof}) { 1087 $self->{on_eof}
1030 $self->{on_eof}($self) 1088 ? $self->{on_eof}($self)
1031 } else {
1032 $self->_error (0, 1, "Unexpected end-of-file"); 1089 : $self->_error (0, 1, "Unexpected end-of-file");
1033 } 1090
1091 return;
1092 }
1093
1094 if (
1095 defined $self->{rbuf_max}
1096 && $self->{rbuf_max} < length $self->{rbuf}
1097 ) {
1098 $self->_error (Errno::ENOSPC, 1), return;
1034 } 1099 }
1035 1100
1036 # may need to restart read watcher 1101 # may need to restart read watcher
1037 unless ($self->{_rw}) { 1102 unless ($self->{_rw}) {
1038 $self->start_read 1103 $self->start_read
… …
1387=cut 1452=cut
1388 1453
1389register_read_type json => sub { 1454register_read_type json => sub {
1390 my ($self, $cb) = @_; 1455 my ($self, $cb) = @_;
1391 1456
1392 my $json = $self->{json} ||= 1457 my $json = $self->{json} ||= json_coder;
1393 eval { require JSON::XS; JSON::XS->new->utf8 }
1394 || do { require JSON; JSON->new->utf8 };
1395 1458
1396 my $data; 1459 my $data;
1397 my $rbuf = \$self->{rbuf}; 1460 my $rbuf = \$self->{rbuf};
1398 1461
1399 sub { 1462 sub {
… …
1519 my ($self) = @_; 1582 my ($self) = @_;
1520 1583
1521 unless ($self->{_rw} || $self->{_eof}) { 1584 unless ($self->{_rw} || $self->{_eof}) {
1522 Scalar::Util::weaken $self; 1585 Scalar::Util::weaken $self;
1523 1586
1524 $self->{_rw} = AnyEvent->io (fh => $self->{fh}, poll => "r", cb => sub { 1587 $self->{_rw} = AE::io $self->{fh}, 0, sub {
1525 my $rbuf = \($self->{tls} ? my $buf : $self->{rbuf}); 1588 my $rbuf = \($self->{tls} ? my $buf : $self->{rbuf});
1526 my $len = sysread $self->{fh}, $$rbuf, $self->{read_size} || 8192, length $$rbuf; 1589 my $len = sysread $self->{fh}, $$rbuf, $self->{read_size} || 8192, length $$rbuf;
1527 1590
1528 if ($len > 0) { 1591 if ($len > 0) {
1529 $self->{_activity} = AnyEvent->now; 1592 $self->{_activity} = $self->{_ractivity} = AE::now;
1530 1593
1531 if ($self->{tls}) { 1594 if ($self->{tls}) {
1532 Net::SSLeay::BIO_write ($self->{_rbio}, $$rbuf); 1595 Net::SSLeay::BIO_write ($self->{_rbio}, $$rbuf);
1533 1596
1534 &_dotls ($self); 1597 &_dotls ($self);
… …
1542 $self->_drain_rbuf; 1605 $self->_drain_rbuf;
1543 1606
1544 } elsif ($! != EAGAIN && $! != EINTR && $! != WSAEWOULDBLOCK) { 1607 } elsif ($! != EAGAIN && $! != EINTR && $! != WSAEWOULDBLOCK) {
1545 return $self->_error ($!, 1); 1608 return $self->_error ($!, 1);
1546 } 1609 }
1547 }); 1610 };
1548 } 1611 }
1549} 1612}
1550 1613
1551our $ERROR_SYSCALL; 1614our $ERROR_SYSCALL;
1552our $ERROR_WANT_READ; 1615our $ERROR_WANT_READ;
… …
1649The TLS connection object will end up in C<< $handle->{tls} >>, the TLS 1712The TLS connection object will end up in C<< $handle->{tls} >>, the TLS
1650context in C<< $handle->{tls_ctx} >> after this call and can be used or 1713context in C<< $handle->{tls_ctx} >> after this call and can be used or
1651changed to your liking. Note that the handshake might have already started 1714changed to your liking. Note that the handshake might have already started
1652when this function returns. 1715when this function returns.
1653 1716
1654If it an error to start a TLS handshake more than once per 1717Due to bugs in OpenSSL, it might or might not be possible to do multiple
1655AnyEvent::Handle object (this is due to bugs in OpenSSL). 1718handshakes on the same stream. Best do not attempt to use the stream after
1719stopping TLS.
1656 1720
1657=cut 1721=cut
1658 1722
1659our %TLS_CACHE; #TODO not yet documented, should we? 1723our %TLS_CACHE; #TODO not yet documented, should we?
1660 1724
1661sub starttls { 1725sub starttls {
1662 my ($self, $ssl, $ctx) = @_; 1726 my ($self, $tls, $ctx) = @_;
1727
1728 Carp::croak "It is an error to call starttls on an AnyEvent::Handle object while TLS is already active, caught"
1729 if $self->{tls};
1730
1731 $self->{tls} = $tls;
1732 $self->{tls_ctx} = $ctx if @_ > 2;
1733
1734 return unless $self->{fh};
1663 1735
1664 require Net::SSLeay; 1736 require Net::SSLeay;
1665
1666 Carp::croak "it is an error to call starttls more than once on an AnyEvent::Handle object"
1667 if $self->{tls};
1668 1737
1669 $ERROR_SYSCALL = Net::SSLeay::ERROR_SYSCALL (); 1738 $ERROR_SYSCALL = Net::SSLeay::ERROR_SYSCALL ();
1670 $ERROR_WANT_READ = Net::SSLeay::ERROR_WANT_READ (); 1739 $ERROR_WANT_READ = Net::SSLeay::ERROR_WANT_READ ();
1671 1740
1741 $tls = delete $self->{tls};
1672 $ctx ||= $self->{tls_ctx}; 1742 $ctx = $self->{tls_ctx};
1673 1743
1674 local $Carp::CarpLevel = 1; # skip ourselves when creating a new context or session 1744 local $Carp::CarpLevel = 1; # skip ourselves when creating a new context or session
1675 1745
1676 if ("HASH" eq ref $ctx) { 1746 if ("HASH" eq ref $ctx) {
1677 require AnyEvent::TLS; 1747 require AnyEvent::TLS;
… …
1683 $ctx = new AnyEvent::TLS %$ctx; 1753 $ctx = new AnyEvent::TLS %$ctx;
1684 } 1754 }
1685 } 1755 }
1686 1756
1687 $self->{tls_ctx} = $ctx || TLS_CTX (); 1757 $self->{tls_ctx} = $ctx || TLS_CTX ();
1688 $self->{tls} = $ssl = $self->{tls_ctx}->_get_session ($ssl, $self, $self->{peername}); 1758 $self->{tls} = $tls = $self->{tls_ctx}->_get_session ($tls, $self, $self->{peername});
1689 1759
1690 # basically, this is deep magic (because SSL_read should have the same issues) 1760 # basically, this is deep magic (because SSL_read should have the same issues)
1691 # but the openssl maintainers basically said: "trust us, it just works". 1761 # but the openssl maintainers basically said: "trust us, it just works".
1692 # (unfortunately, we have to hardcode constants because the abysmally misdesigned 1762 # (unfortunately, we have to hardcode constants because the abysmally misdesigned
1693 # and mismaintained ssleay-module doesn't even offer them). 1763 # and mismaintained ssleay-module doesn't even offer them).
… …
1700 # and we drive openssl fully in blocking mode here. Or maybe we don't - openssl seems to 1770 # and we drive openssl fully in blocking mode here. Or maybe we don't - openssl seems to
1701 # have identity issues in that area. 1771 # have identity issues in that area.
1702# Net::SSLeay::CTX_set_mode ($ssl, 1772# Net::SSLeay::CTX_set_mode ($ssl,
1703# (eval { local $SIG{__DIE__}; Net::SSLeay::MODE_ENABLE_PARTIAL_WRITE () } || 1) 1773# (eval { local $SIG{__DIE__}; Net::SSLeay::MODE_ENABLE_PARTIAL_WRITE () } || 1)
1704# | (eval { local $SIG{__DIE__}; Net::SSLeay::MODE_ACCEPT_MOVING_WRITE_BUFFER () } || 2)); 1774# | (eval { local $SIG{__DIE__}; Net::SSLeay::MODE_ACCEPT_MOVING_WRITE_BUFFER () } || 2));
1705 Net::SSLeay::CTX_set_mode ($ssl, 1|2); 1775 Net::SSLeay::CTX_set_mode ($tls, 1|2);
1706 1776
1707 $self->{_rbio} = Net::SSLeay::BIO_new (Net::SSLeay::BIO_s_mem ()); 1777 $self->{_rbio} = Net::SSLeay::BIO_new (Net::SSLeay::BIO_s_mem ());
1708 $self->{_wbio} = Net::SSLeay::BIO_new (Net::SSLeay::BIO_s_mem ()); 1778 $self->{_wbio} = Net::SSLeay::BIO_new (Net::SSLeay::BIO_s_mem ());
1709 1779
1780 Net::SSLeay::BIO_write ($self->{_rbio}, delete $self->{rbuf});
1781
1710 Net::SSLeay::set_bio ($ssl, $self->{_rbio}, $self->{_wbio}); 1782 Net::SSLeay::set_bio ($tls, $self->{_rbio}, $self->{_wbio});
1711 1783
1712 $self->{_on_starttls} = sub { $_[0]{on_starttls}(@_) } 1784 $self->{_on_starttls} = sub { $_[0]{on_starttls}(@_) }
1713 if $self->{on_starttls}; 1785 if $self->{on_starttls};
1714 1786
1715 &_dotls; # need to trigger the initial handshake 1787 &_dotls; # need to trigger the initial handshake
… …
1718 1790
1719=item $handle->stoptls 1791=item $handle->stoptls
1720 1792
1721Shuts down the SSL connection - this makes a proper EOF handshake by 1793Shuts down the SSL connection - this makes a proper EOF handshake by
1722sending a close notify to the other side, but since OpenSSL doesn't 1794sending a close notify to the other side, but since OpenSSL doesn't
1723support non-blocking shut downs, it is not possible to re-use the stream 1795support non-blocking shut downs, it is not guarenteed that you can re-use
1724afterwards. 1796the stream afterwards.
1725 1797
1726=cut 1798=cut
1727 1799
1728sub stoptls { 1800sub stoptls {
1729 my ($self) = @_; 1801 my ($self) = @_;
… …
1742sub _freetls { 1814sub _freetls {
1743 my ($self) = @_; 1815 my ($self) = @_;
1744 1816
1745 return unless $self->{tls}; 1817 return unless $self->{tls};
1746 1818
1747 $self->{tls_ctx}->_put_session (delete $self->{tls}); 1819 $self->{tls_ctx}->_put_session (delete $self->{tls})
1820 if $self->{tls} > 0;
1748 1821
1749 delete @$self{qw(_rbio _wbio _tls_wbuf _on_starttls)}; 1822 delete @$self{qw(_rbio _wbio _tls_wbuf _on_starttls)};
1750} 1823}
1751 1824
1752sub DESTROY { 1825sub DESTROY {
… …
1760 my $fh = delete $self->{fh}; 1833 my $fh = delete $self->{fh};
1761 my $wbuf = delete $self->{wbuf}; 1834 my $wbuf = delete $self->{wbuf};
1762 1835
1763 my @linger; 1836 my @linger;
1764 1837
1765 push @linger, AnyEvent->io (fh => $fh, poll => "w", cb => sub { 1838 push @linger, AE::io $fh, 1, sub {
1766 my $len = syswrite $fh, $wbuf, length $wbuf; 1839 my $len = syswrite $fh, $wbuf, length $wbuf;
1767 1840
1768 if ($len > 0) { 1841 if ($len > 0) {
1769 substr $wbuf, 0, $len, ""; 1842 substr $wbuf, 0, $len, "";
1770 } else { 1843 } else {
1771 @linger = (); # end 1844 @linger = (); # end
1772 } 1845 }
1773 }); 1846 };
1774 push @linger, AnyEvent->timer (after => $linger, cb => sub { 1847 push @linger, AE::timer $linger, 0, sub {
1775 @linger = (); 1848 @linger = ();
1776 }); 1849 };
1777 } 1850 }
1778} 1851}
1779 1852
1780=item $handle->destroy 1853=item $handle->destroy
1781 1854
1782Shuts down the handle object as much as possible - this call ensures that 1855Shuts down the handle object as much as possible - this call ensures that
1783no further callbacks will be invoked and as many resources as possible 1856no further callbacks will be invoked and as many resources as possible
1784will be freed. You must not call any methods on the object afterwards. 1857will be freed. Any method you will call on the handle object after
1858destroying it in this way will be silently ignored (and it will return the
1859empty list).
1785 1860
1786Normally, you can just "forget" any references to an AnyEvent::Handle 1861Normally, you can just "forget" any references to an AnyEvent::Handle
1787object and it will simply shut down. This works in fatal error and EOF 1862object and it will simply shut down. This works in fatal error and EOF
1788callbacks, as well as code outside. It does I<NOT> work in a read or write 1863callbacks, as well as code outside. It does I<NOT> work in a read or write
1789callback, so when you want to destroy the AnyEvent::Handle object from 1864callback, so when you want to destroy the AnyEvent::Handle object from
… …
1803sub destroy { 1878sub destroy {
1804 my ($self) = @_; 1879 my ($self) = @_;
1805 1880
1806 $self->DESTROY; 1881 $self->DESTROY;
1807 %$self = (); 1882 %$self = ();
1883 bless $self, "AnyEvent::Handle::destroyed";
1884}
1885
1886sub AnyEvent::Handle::destroyed::AUTOLOAD {
1887 #nop
1808} 1888}
1809 1889
1810=item AnyEvent::Handle::TLS_CTX 1890=item AnyEvent::Handle::TLS_CTX
1811 1891
1812This function creates and returns the AnyEvent::TLS object used by default 1892This function creates and returns the AnyEvent::TLS object used by default

Diff Legend

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