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.187 by root, Tue Sep 8 00:01:12 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
65sub _load_func($) {
66 my $func = $_[0];
67
68 unless (defined &$func) {
69 my $pkg = $func;
70 do {
71 $pkg =~ s/::[^:]+$//
72 or return;
73 eval "require $pkg";
74 } until defined &$func;
75 }
76
77 \&$func
78}
79
64=head1 METHODS 80=head1 METHODS
65 81
66=over 4 82=over 4
67 83
68=item $handle = B<new> AnyEvent::TLS fh => $filehandle, key => value... 84=item $handle = B<new> AnyEvent::TLS fh => $filehandle, key => value...
83Try to connect to the specified host and service (port), using 99Try to connect to the specified host and service (port), using
84C<AnyEvent::Socket::tcp_connect>. The C<$host> additionally becomes the 100C<AnyEvent::Socket::tcp_connect>. The C<$host> additionally becomes the
85default C<peername>. 101default C<peername>.
86 102
87You have to specify either this parameter, or C<fh>, above. 103You have to specify either this parameter, or C<fh>, above.
104
105It is possible to push requests on the read and write queues, and modify
106properties of the stream, even while AnyEvent::Handle is connecting.
88 107
89When this parameter is specified, then the C<on_prepare>, 108When this parameter is specified, then the C<on_prepare>,
90C<on_connect_error> and C<on_connect> callbacks will be called under the 109C<on_connect_error> and C<on_connect> callbacks will be called under the
91appropriate circumstances: 110appropriate circumstances:
92 111
98attempted, but after the file handle has been created. It could be used to 117attempted, but after the file handle has been created. It could be used to
99prepare the file handle with parameters required for the actual connect 118prepare the file handle with parameters required for the actual connect
100(as opposed to settings that can be changed when the connection is already 119(as opposed to settings that can be changed when the connection is already
101established). 120established).
102 121
122The return value of this callback should be the connect timeout value in
123seconds (or C<0>, or C<undef>, or the empty list, to indicate the default
124timeout is to be used).
125
103=item on_connect => $cb->($handle, $host, $port, $retry->()) 126=item on_connect => $cb->($handle, $host, $port, $retry->())
104 127
105This callback is called when a connection has been successfully established. 128This callback is called when a connection has been successfully established.
106 129
107The actual numeric host and port (the socket peername) are passed as 130The actual numeric host and port (the socket peername) are passed as
108parameters, together with a retry callback. 131parameters, together with a retry callback.
109 132
110When, for some reason, the handle is not acceptable, then calling 133When, for some reason, the handle is not acceptable, then calling
111C<$retry> will continue with the next conenction target (in case of 134C<$retry> will continue with the next connection target (in case of
112multi-homed hosts or SRV records there can be multiple connection 135multi-homed hosts or SRV records there can be multiple connection
113endpoints). When it is called then the read and write queues, eof status, 136endpoints). At the time it is called the read and write queues, eof
114tls status and similar properties of the handle are being reset. 137status, tls status and similar properties of the handle will have been
138reset.
115 139
116In most cases, ignoring the C<$retry> parameter is the way to go. 140In most cases, ignoring the C<$retry> parameter is the way to go.
117 141
118=item on_connect_error => $cb->($handle, $message) 142=item on_connect_error => $cb->($handle, $message)
119 143
120This callback is called when the conenction could not be 144This callback is called when the connection could not be
121established. C<$!> will contain the relevant error code, and C<$message> a 145established. C<$!> will contain the relevant error code, and C<$message> a
122message describing it (usually the same as C<"$!">). 146message describing it (usually the same as C<"$!">).
123 147
124If this callback isn't specified, then C<on_error> will be called with a 148If this callback isn't specified, then C<on_error> will be called with a
125fatal error instead. 149fatal error instead.
209memory and push it into the queue, but instead only read more data from 233memory and push it into the queue, but instead only read more data from
210the file when the write queue becomes empty. 234the file when the write queue becomes empty.
211 235
212=item timeout => $fractional_seconds 236=item timeout => $fractional_seconds
213 237
238=item rtimeout => $fractional_seconds
239
240=item wtimeout => $fractional_seconds
241
214If non-zero, then this enables an "inactivity" timeout: whenever this many 242If non-zero, then these enables an "inactivity" timeout: whenever this
215seconds pass without a successful read or write on the underlying file 243many 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 244file handle (or a call to C<timeout_reset>), the C<on_timeout> callback
217missing, a non-fatal C<ETIMEDOUT> error will be raised). 245will be invoked (and if that one is missing, a non-fatal C<ETIMEDOUT>
246error will be raised).
247
248There are three variants of the timeouts that work fully independent
249of each other, for both read and write, just read, and just write:
250C<timeout>, C<rtimeout> and C<wtimeout>, with corresponding callbacks
251C<on_timeout>, C<on_rtimeout> and C<on_wtimeout>, and reset functions
252C<timeout_reset>, C<rtimeout_reset>, and C<wtimeout_reset>.
218 253
219Note that timeout processing is also active when you currently do not have 254Note 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 255any outstanding read or write requests: If you plan to keep the connection
221idle then you should disable the timout temporarily or ignore the timeout 256idle then you should disable the timout temporarily or ignore the timeout
222in the C<on_timeout> callback, in which case AnyEvent::Handle will simply 257in the C<on_timeout> callback, in which case AnyEvent::Handle will simply
266accomplishd by setting this option to a true value. 301accomplishd by setting this option to a true value.
267 302
268The default is your opertaing system's default behaviour (most likely 303The default is your opertaing system's default behaviour (most likely
269enabled), this option explicitly enables or disables it, if possible. 304enabled), this option explicitly enables or disables it, if possible.
270 305
306=item keepalive => <boolean>
307
308Enables (default disable) the SO_KEEPALIVE option on the stream socket:
309normally, TCP connections have no time-out once established, so TCP
310connections, once established, can stay alive forever even when the other
311side has long gone. TCP keepalives are a cheap way to take down long-lived
312TCP connections whent he other side becomes unreachable. While the default
313is OS-dependent, TCP keepalives usually kick in after around two hours,
314and, if the other side doesn't reply, take down the TCP connection some 10
315to 15 minutes later.
316
317It is harmless to specify this option for file handles that do not support
318keepalives, and enabling it on connections that are potentially long-lived
319is usually a good idea.
320
321=item oobinline => <boolean>
322
323BSD majorly fucked up the implementation of TCP urgent data. The result
324is that almost no OS implements TCP according to the specs, and every OS
325implements it slightly differently.
326
327If you want to handle TCP urgent data, then setting this flag (the default
328is enabled) gives you the most portable way of getting urgent data, by
329putting it into the stream.
330
331Since BSD emulation of OOB data on top of TCP's urgent data can have
332security implications, AnyEvent::Handle sets this flag automatically
333unless explicitly specified. Note that setting this flag after
334establishing a connection I<may> be a bit too late (data loss could
335already have occured on BSD systems), but at least it will protect you
336from most attacks.
337
271=item read_size => <bytes> 338=item read_size => <bytes>
272 339
273The default read block size (the amount of bytes this module will 340The default read block size (the amount of bytes this module will
274try to read during each loop iteration, which affects memory 341try to read during each loop iteration, which affects memory
275requirements). Default: C<8192>. 342requirements). Default: C<8192>.
308C<undef>. 375C<undef>.
309 376
310=item tls => "accept" | "connect" | Net::SSLeay::SSL object 377=item tls => "accept" | "connect" | Net::SSLeay::SSL object
311 378
312When this parameter is given, it enables TLS (SSL) mode, that means 379When this parameter is given, it enables TLS (SSL) mode, that means
313AnyEvent will start a TLS handshake as soon as the conenction has been 380AnyEvent will start a TLS handshake as soon as the connection has been
314established and will transparently encrypt/decrypt data afterwards. 381established and will transparently encrypt/decrypt data afterwards.
315 382
316All TLS protocol errors will be signalled as C<EPROTO>, with an 383All TLS protocol errors will be signalled as C<EPROTO>, with an
317appropriate error message. 384appropriate error message.
318 385
431 delete $self->{_skip_drain_rbuf}; 498 delete $self->{_skip_drain_rbuf};
432 $self->_start; 499 $self->_start;
433 500
434 $self->{on_connect} 501 $self->{on_connect}
435 and $self->{on_connect}($self, $host, $port, sub { 502 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)}; 503 delete @$self{qw(fh _tw _rtw _wtw _ww _rw _eof _queue rbuf _wbuf tls _tls_rbuf _tls_wbuf)};
437 $self->{_skip_drain_rbuf} = 1; 504 $self->{_skip_drain_rbuf} = 1;
438 &$retry; 505 &$retry;
439 }); 506 });
440 507
441 } else { 508 } else {
442 if ($self->{on_connect_error}) { 509 if ($self->{on_connect_error}) {
443 $self->{on_connect_error}($self, "$!"); 510 $self->{on_connect_error}($self, "$!");
444 $self->destroy; 511 $self->destroy;
445 } else { 512 } else {
446 $self->fatal ($!, 1); 513 $self->_error ($!, 1);
447 } 514 }
448 } 515 }
449 }, 516 },
450 sub { 517 sub {
451 local $self->{fh} = $_[0]; 518 local $self->{fh} = $_[0];
452 519
520 $self->{on_prepare}
453 $self->{on_prepare}->($self) 521 ? $self->{on_prepare}->($self)
454 if $self->{on_prepare}; 522 : ()
455 } 523 }
456 ); 524 );
457 } 525 }
458 526
459 } else { 527 } else {
466sub _start { 534sub _start {
467 my ($self) = @_; 535 my ($self) = @_;
468 536
469 AnyEvent::Util::fh_nonblocking $self->{fh}, 1; 537 AnyEvent::Util::fh_nonblocking $self->{fh}, 1;
470 538
539 $self->{_activity} =
540 $self->{_ractivity} =
471 $self->{_activity} = AnyEvent->now; 541 $self->{_wactivity} = AE::now;
472 $self->_timeout;
473 542
543 $self->timeout (delete $self->{timeout} ) if $self->{timeout};
544 $self->rtimeout (delete $self->{rtimeout} ) if $self->{rtimeout};
545 $self->wtimeout (delete $self->{wtimeout} ) if $self->{wtimeout};
546
474 $self->no_delay (delete $self->{no_delay}) if exists $self->{no_delay}; 547 $self->no_delay (delete $self->{no_delay} ) if exists $self->{no_delay} && $self->{no_delay};
548 $self->keepalive (delete $self->{keepalive}) if exists $self->{keepalive} && $self->{keepalive};
475 549
550 $self->oobinline (exists $self->{oobinline} ? delete $self->{oobinline} : 1);
551
476 $self->starttls (delete $self->{tls}, delete $self->{tls_ctx}) 552 $self->starttls (delete $self->{tls}, delete $self->{tls_ctx})
477 if $self->{tls}; 553 if $self->{tls};
478 554
479 $self->on_drain (delete $self->{on_drain}) if $self->{on_drain}; 555 $self->on_drain (delete $self->{on_drain}) if $self->{on_drain};
480 556
481 $self->start_read 557 $self->start_read
482 if $self->{on_read} || @{ $self->{_queue} }; 558 if $self->{on_read} || @{ $self->{_queue} };
483}
484 559
485#sub _shutdown { 560 $self->_drain_wbuf;
486# my ($self) = @_; 561}
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 562
494sub _error { 563sub _error {
495 my ($self, $errno, $fatal, $message) = @_; 564 my ($self, $errno, $fatal, $message) = @_;
496 565
497 $! = $errno; 566 $! = $errno;
498 $message ||= "$!"; 567 $message ||= "$!";
499 568
500 if ($self->{on_error}) { 569 if ($self->{on_error}) {
501 $self->{on_error}($self, $fatal, $message); 570 $self->{on_error}($self, $fatal, $message);
502 $self->destroy if $fatal; 571 $self->destroy if $fatal;
503 } elsif ($self->{fh}) { 572 } elsif ($self->{fh} || $self->{connect}) {
504 $self->destroy; 573 $self->destroy;
505 Carp::croak "AnyEvent::Handle uncaught error: $message"; 574 Carp::croak "AnyEvent::Handle uncaught error: $message";
506 } 575 }
507} 576}
508 577
534 $_[0]{on_eof} = $_[1]; 603 $_[0]{on_eof} = $_[1];
535} 604}
536 605
537=item $handle->on_timeout ($cb) 606=item $handle->on_timeout ($cb)
538 607
539Replace the current C<on_timeout> callback, or disables the callback (but 608=item $handle->on_rtimeout ($cb)
540not the timeout) if C<$cb> = C<undef>. See the C<timeout> constructor
541argument and method.
542 609
543=cut 610=item $handle->on_wtimeout ($cb)
544 611
545sub on_timeout { 612Replace the current C<on_timeout>, C<on_rtimeout> or C<on_wtimeout>
546 $_[0]{on_timeout} = $_[1]; 613callback, or disables the callback (but not the timeout) if C<$cb> =
547} 614C<undef>. See the C<timeout> constructor argument and method.
615
616=cut
617
618# see below
548 619
549=item $handle->autocork ($boolean) 620=item $handle->autocork ($boolean)
550 621
551Enables or disables the current autocork behaviour (see C<autocork> 622Enables or disables the current autocork behaviour (see C<autocork>
552constructor argument). Changes will only take effect on the next write. 623constructor argument). Changes will only take effect on the next write.
567sub no_delay { 638sub no_delay {
568 $_[0]{no_delay} = $_[1]; 639 $_[0]{no_delay} = $_[1];
569 640
570 eval { 641 eval {
571 local $SIG{__DIE__}; 642 local $SIG{__DIE__};
572 setsockopt $_[0]{fh}, &Socket::IPPROTO_TCP, &Socket::TCP_NODELAY, int $_[1] 643 setsockopt $_[0]{fh}, Socket::IPPROTO_TCP (), Socket::TCP_NODELAY (), int $_[1]
573 if $_[0]{fh}; 644 if $_[0]{fh};
574 }; 645 };
575} 646}
576 647
648=item $handle->keepalive ($boolean)
649
650Enables or disables the C<keepalive> setting (see constructor argument of
651the same name for details).
652
653=cut
654
655sub keepalive {
656 $_[0]{keepalive} = $_[1];
657
658 eval {
659 local $SIG{__DIE__};
660 setsockopt $_[0]{fh}, Socket::SOL_SOCKET (), Socket::SO_KEEPALIVE (), int $_[1]
661 if $_[0]{fh};
662 };
663}
664
665=item $handle->oobinline ($boolean)
666
667Enables or disables the C<oobinline> setting (see constructor argument of
668the same name for details).
669
670=cut
671
672sub oobinline {
673 $_[0]{oobinline} = $_[1];
674
675 eval {
676 local $SIG{__DIE__};
677 setsockopt $_[0]{fh}, Socket::SOL_SOCKET (), Socket::SO_OOBINLINE (), int $_[1]
678 if $_[0]{fh};
679 };
680}
681
682=item $handle->keepalive ($boolean)
683
684Enables or disables the C<keepalive> setting (see constructor argument of
685the same name for details).
686
687=cut
688
689sub keepalive {
690 $_[0]{keepalive} = $_[1];
691
692 eval {
693 local $SIG{__DIE__};
694 setsockopt $_[0]{fh}, Socket::SOL_SOCKET (), Socket::SO_KEEPALIVE (), int $_[1]
695 if $_[0]{fh};
696 };
697}
698
577=item $handle->on_starttls ($cb) 699=item $handle->on_starttls ($cb)
578 700
579Replace the current C<on_starttls> callback (see the C<on_starttls> constructor argument). 701Replace the current C<on_starttls> callback (see the C<on_starttls> constructor argument).
580 702
581=cut 703=cut
592 714
593sub on_starttls { 715sub on_starttls {
594 $_[0]{on_stoptls} = $_[1]; 716 $_[0]{on_stoptls} = $_[1];
595} 717}
596 718
719=item $handle->rbuf_max ($max_octets)
720
721Configures the C<rbuf_max> setting (C<undef> disables it).
722
723=cut
724
725sub rbuf_max {
726 $_[0]{rbuf_max} = $_[1];
727}
728
597############################################################################# 729#############################################################################
598 730
599=item $handle->timeout ($seconds) 731=item $handle->timeout ($seconds)
600 732
733=item $handle->rtimeout ($seconds)
734
735=item $handle->wtimeout ($seconds)
736
601Configures (or disables) the inactivity timeout. 737Configures (or disables) the inactivity timeout.
602 738
603=cut 739=item $handle->timeout_reset
604 740
605sub timeout { 741=item $handle->rtimeout_reset
742
743=item $handle->wtimeout_reset
744
745Reset the activity timeout, as if data was received or sent.
746
747These methods are cheap to call.
748
749=cut
750
751for my $dir ("", "r", "w") {
752 my $timeout = "${dir}timeout";
753 my $tw = "_${dir}tw";
754 my $on_timeout = "on_${dir}timeout";
755 my $activity = "_${dir}activity";
756 my $cb;
757
758 *$on_timeout = sub {
759 $_[0]{$on_timeout} = $_[1];
760 };
761
762 *$timeout = sub {
606 my ($self, $timeout) = @_; 763 my ($self, $new_value) = @_;
607 764
608 $self->{timeout} = $timeout; 765 $self->{$timeout} = $new_value;
609 $self->_timeout; 766 delete $self->{$tw}; &$cb;
610} 767 };
611 768
769 *{"${dir}timeout_reset"} = sub {
770 $_[0]{$activity} = AE::now;
771 };
772
773 # main workhorse:
612# reset the timeout watcher, as neccessary 774 # reset the timeout watcher, as neccessary
613# also check for time-outs 775 # also check for time-outs
614sub _timeout { 776 $cb = sub {
615 my ($self) = @_; 777 my ($self) = @_;
616 778
617 if ($self->{timeout} && $self->{fh}) { 779 if ($self->{$timeout} && $self->{fh}) {
618 my $NOW = AnyEvent->now; 780 my $NOW = AE::now;
619 781
620 # when would the timeout trigger? 782 # when would the timeout trigger?
621 my $after = $self->{_activity} + $self->{timeout} - $NOW; 783 my $after = $self->{$activity} + $self->{$timeout} - $NOW;
622 784
623 # now or in the past already? 785 # now or in the past already?
624 if ($after <= 0) { 786 if ($after <= 0) {
625 $self->{_activity} = $NOW; 787 $self->{$activity} = $NOW;
626 788
627 if ($self->{on_timeout}) { 789 if ($self->{$on_timeout}) {
628 $self->{on_timeout}($self); 790 $self->{$on_timeout}($self);
629 } else { 791 } else {
630 $self->_error (Errno::ETIMEDOUT); 792 $self->_error (Errno::ETIMEDOUT);
793 }
794
795 # callback could have changed timeout value, optimise
796 return unless $self->{$timeout};
797
798 # calculate new after
799 $after = $self->{$timeout};
631 } 800 }
632 801
633 # callback could have changed timeout value, optimise 802 Scalar::Util::weaken $self;
634 return unless $self->{timeout}; 803 return unless $self; # ->error could have destroyed $self
635 804
636 # calculate new after 805 $self->{$tw} ||= AE::timer $after, 0, sub {
637 $after = $self->{timeout}; 806 delete $self->{$tw};
807 $cb->($self);
808 };
809 } else {
810 delete $self->{$tw};
638 } 811 }
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 } 812 }
650} 813}
651 814
652############################################################################# 815#############################################################################
653 816
701 my $len = syswrite $self->{fh}, $self->{wbuf}; 864 my $len = syswrite $self->{fh}, $self->{wbuf};
702 865
703 if (defined $len) { 866 if (defined $len) {
704 substr $self->{wbuf}, 0, $len, ""; 867 substr $self->{wbuf}, 0, $len, "";
705 868
706 $self->{_activity} = AnyEvent->now; 869 $self->{_activity} = $self->{_wactivity} = AE::now;
707 870
708 $self->{on_drain}($self) 871 $self->{on_drain}($self)
709 if $self->{low_water_mark} >= (length $self->{wbuf}) + (length $self->{_tls_wbuf}) 872 if $self->{low_water_mark} >= (length $self->{wbuf}) + (length $self->{_tls_wbuf})
710 && $self->{on_drain}; 873 && $self->{on_drain};
711 874
717 880
718 # try to write data immediately 881 # try to write data immediately
719 $cb->() unless $self->{autocork}; 882 $cb->() unless $self->{autocork};
720 883
721 # if still data left in wbuf, we need to poll 884 # if still data left in wbuf, we need to poll
722 $self->{_ww} = AnyEvent->io (fh => $self->{fh}, poll => "w", cb => $cb) 885 $self->{_ww} = AE::io $self->{fh}, 1, $cb
723 if length $self->{wbuf}; 886 if length $self->{wbuf};
724 }; 887 };
725} 888}
726 889
727our %WH; 890our %WH;
728 891
892# deprecated
729sub register_write_type($$) { 893sub register_write_type($$) {
730 $WH{$_[0]} = $_[1]; 894 $WH{$_[0]} = $_[1];
731} 895}
732 896
733sub push_write { 897sub push_write {
734 my $self = shift; 898 my $self = shift;
735 899
736 if (@_ > 1) { 900 if (@_ > 1) {
737 my $type = shift; 901 my $type = shift;
738 902
903 @_ = ($WH{$type} ||= _load_func "$type\::anyevent_write_type"
739 @_ = ($WH{$type} or Carp::croak "unsupported type passed to AnyEvent::Handle::push_write") 904 or Carp::croak "unsupported/unloadable type '$type' passed to AnyEvent::Handle::push_write")
740 ->($self, @_); 905 ->($self, @_);
741 } 906 }
742 907
743 if ($self->{tls}) { 908 if ($self->{tls}) {
744 $self->{_tls_wbuf} .= $_[0]; 909 $self->{_tls_wbuf} .= $_[0];
745 910 &_dotls ($self) if $self->{fh};
746 &_dotls ($self);
747 } else { 911 } else {
748 $self->{wbuf} .= $_[0]; 912 $self->{wbuf} .= $_[0];
749 $self->_drain_wbuf if $self->{fh}; 913 $self->_drain_wbuf if $self->{fh};
750 } 914 }
751} 915}
752 916
753=item $handle->push_write (type => @args) 917=item $handle->push_write (type => @args)
754 918
755Instead of formatting your data yourself, you can also let this module do 919Instead of formatting your data yourself, you can also let this module
756the job by specifying a type and type-specific arguments. 920do the job by specifying a type and type-specific arguments. You
921can also specify the (fully qualified) name of a package, in which
922case AnyEvent tries to load the package and then expects to find the
923C<anyevent_read_type> function inside (see "custom write types", below).
757 924
758Predefined types are (if you have ideas for additional types, feel free to 925Predefined types are (if you have ideas for additional types, feel free to
759drop by and tell us): 926drop by and tell us):
760 927
761=over 4 928=over 4
818Other languages could read single lines terminated by a newline and pass 985Other languages could read single lines terminated by a newline and pass
819this line into their JSON decoder of choice. 986this line into their JSON decoder of choice.
820 987
821=cut 988=cut
822 989
990sub json_coder() {
991 eval { require JSON::XS; JSON::XS->new->utf8 }
992 || do { require JSON; JSON->new->utf8 }
993}
994
823register_write_type json => sub { 995register_write_type json => sub {
824 my ($self, $ref) = @_; 996 my ($self, $ref) = @_;
825 997
826 require JSON; 998 my $json = $self->{json} ||= json_coder;
827 999
828 $self->{json} ? $self->{json}->encode ($ref) 1000 $json->encode ($ref)
829 : JSON::encode_json ($ref)
830}; 1001};
831 1002
832=item storable => $reference 1003=item storable => $reference
833 1004
834Freezes the given reference using L<Storable> and writes it to the 1005Freezes the given reference using L<Storable> and writes it to the
869 1040
870 delete $self->{low_water_mark}; 1041 delete $self->{low_water_mark};
871 $self->on_drain (sub { shutdown $_[0]{fh}, 1 }); 1042 $self->on_drain (sub { shutdown $_[0]{fh}, 1 });
872} 1043}
873 1044
874=item AnyEvent::Handle::register_write_type type => $coderef->($handle, @args) 1045=item custom write types - Package::anyevent_write_type $handle, @args
875 1046
876This function (not method) lets you add your own types to C<push_write>. 1047Instead of one of the predefined types, you can also specify the name of
1048a package. AnyEvent will try to load the package and then expects to find
1049a function named C<anyevent_write_type> inside. If it isn't found, it
1050progressively tries to load the parent package until it either finds the
1051function (good) or runs out of packages (bad).
1052
877Whenever the given C<type> is used, C<push_write> will invoke the code 1053Whenever the given C<type> is used, C<push_write> will the function with
878reference with the handle object and the remaining arguments. 1054the handle object and the remaining arguments.
879 1055
880The code reference is supposed to return a single octet string that will 1056The function is supposed to return a single octet string that will be
881be appended to the write buffer. 1057appended to the write buffer, so you cna mentally treat this function as a
1058"arguments to on-the-wire-format" converter.
882 1059
883Note that this is a function, and all types registered this way will be 1060Example: implement a custom write type C<join> that joins the remaining
884global, so try to use unique names. 1061arguments using the first one.
1062
1063 $handle->push_write (My::Type => " ", 1,2,3);
1064
1065 # uses the following package, which can be defined in the "My::Type" or in
1066 # the "My" modules to be auto-loaded, or just about anywhere when the
1067 # My::Type::anyevent_write_type is defined before invoking it.
1068
1069 package My::Type;
1070
1071 sub anyevent_write_type {
1072 my ($handle, $delim, @args) = @_;
1073
1074 join $delim, @args
1075 }
885 1076
886=cut 1077=cut
887 1078
888############################################################################# 1079#############################################################################
889 1080
972 1163
973sub _drain_rbuf { 1164sub _drain_rbuf {
974 my ($self) = @_; 1165 my ($self) = @_;
975 1166
976 # avoid recursion 1167 # avoid recursion
977 return if exists $self->{_skip_drain_rbuf}; 1168 return if $self->{_skip_drain_rbuf};
978 local $self->{_skip_drain_rbuf} = 1; 1169 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 1170
987 while () { 1171 while () {
988 # we need to use a separate tls read buffer, as we must not receive data while 1172 # 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. 1173 # we are draining the buffer, and this can only happen with TLS.
990 $self->{rbuf} .= delete $self->{_tls_rbuf} if exists $self->{_tls_rbuf}; 1174 $self->{rbuf} .= delete $self->{_tls_rbuf}
1175 if exists $self->{_tls_rbuf};
991 1176
992 my $len = length $self->{rbuf}; 1177 my $len = length $self->{rbuf};
993 1178
994 if (my $cb = shift @{ $self->{_queue} }) { 1179 if (my $cb = shift @{ $self->{_queue} }) {
995 unless ($cb->($self)) { 1180 unless ($cb->($self)) {
996 if ($self->{_eof}) { 1181 # no progress can be made
997 # no progress can be made (not enough data and no data forthcoming) 1182 # (not enough data and no data forthcoming)
998 $self->_error (Errno::EPIPE, 1), return; 1183 $self->_error (Errno::EPIPE, 1), return
999 } 1184 if $self->{_eof};
1000 1185
1001 unshift @{ $self->{_queue} }, $cb; 1186 unshift @{ $self->{_queue} }, $cb;
1002 last; 1187 last;
1003 } 1188 }
1004 } elsif ($self->{on_read}) { 1189 } elsif ($self->{on_read}) {
1024 last; 1209 last;
1025 } 1210 }
1026 } 1211 }
1027 1212
1028 if ($self->{_eof}) { 1213 if ($self->{_eof}) {
1029 if ($self->{on_eof}) { 1214 $self->{on_eof}
1030 $self->{on_eof}($self) 1215 ? $self->{on_eof}($self)
1031 } else {
1032 $self->_error (0, 1, "Unexpected end-of-file"); 1216 : $self->_error (0, 1, "Unexpected end-of-file");
1033 } 1217
1218 return;
1219 }
1220
1221 if (
1222 defined $self->{rbuf_max}
1223 && $self->{rbuf_max} < length $self->{rbuf}
1224 ) {
1225 $self->_error (Errno::ENOSPC, 1), return;
1034 } 1226 }
1035 1227
1036 # may need to restart read watcher 1228 # may need to restart read watcher
1037 unless ($self->{_rw}) { 1229 unless ($self->{_rw}) {
1038 $self->start_read 1230 $self->start_read
1107 my $cb = pop; 1299 my $cb = pop;
1108 1300
1109 if (@_) { 1301 if (@_) {
1110 my $type = shift; 1302 my $type = shift;
1111 1303
1304 $cb = ($RH{$type} ||= _load_func "$type\::anyevent_read_type"
1112 $cb = ($RH{$type} or Carp::croak "unsupported type passed to AnyEvent::Handle::push_read") 1305 or Carp::croak "unsupported/unloadable type '$type' passed to AnyEvent::Handle::push_read")
1113 ->($self, $cb, @_); 1306 ->($self, $cb, @_);
1114 } 1307 }
1115 1308
1116 push @{ $self->{_queue} }, $cb; 1309 push @{ $self->{_queue} }, $cb;
1117 $self->_drain_rbuf; 1310 $self->_drain_rbuf;
1126 1319
1127 $cb = ($RH{$type} or Carp::croak "unsupported type passed to AnyEvent::Handle::unshift_read") 1320 $cb = ($RH{$type} or Carp::croak "unsupported type passed to AnyEvent::Handle::unshift_read")
1128 ->($self, $cb, @_); 1321 ->($self, $cb, @_);
1129 } 1322 }
1130 1323
1131
1132 unshift @{ $self->{_queue} }, $cb; 1324 unshift @{ $self->{_queue} }, $cb;
1133 $self->_drain_rbuf; 1325 $self->_drain_rbuf;
1134} 1326}
1135 1327
1136=item $handle->push_read (type => @args, $cb) 1328=item $handle->push_read (type => @args, $cb)
1137 1329
1138=item $handle->unshift_read (type => @args, $cb) 1330=item $handle->unshift_read (type => @args, $cb)
1139 1331
1140Instead of providing a callback that parses the data itself you can chose 1332Instead of providing a callback that parses the data itself you can chose
1141between a number of predefined parsing formats, for chunks of data, lines 1333between a number of predefined parsing formats, for chunks of data, lines
1142etc. 1334etc. You can also specify the (fully qualified) name of a package, in
1335which case AnyEvent tries to load the package and then expects to find the
1336C<anyevent_read_type> function inside (see "custom read types", below).
1143 1337
1144Predefined types are (if you have ideas for additional types, feel free to 1338Predefined types are (if you have ideas for additional types, feel free to
1145drop by and tell us): 1339drop by and tell us):
1146 1340
1147=over 4 1341=over 4
1387=cut 1581=cut
1388 1582
1389register_read_type json => sub { 1583register_read_type json => sub {
1390 my ($self, $cb) = @_; 1584 my ($self, $cb) = @_;
1391 1585
1392 my $json = $self->{json} ||= 1586 my $json = $self->{json} ||= json_coder;
1393 eval { require JSON::XS; JSON::XS->new->utf8 }
1394 || do { require JSON; JSON->new->utf8 };
1395 1587
1396 my $data; 1588 my $data;
1397 my $rbuf = \$self->{rbuf}; 1589 my $rbuf = \$self->{rbuf};
1398 1590
1399 sub { 1591 sub {
1468 } 1660 }
1469}; 1661};
1470 1662
1471=back 1663=back
1472 1664
1473=item AnyEvent::Handle::register_read_type type => $coderef->($handle, $cb, @args) 1665=item custom read types - Package::anyevent_read_type $handle, $cb, @args
1474 1666
1475This function (not method) lets you add your own types to C<push_read>. 1667Instead of one of the predefined types, you can also specify the name
1668of a package. AnyEvent will try to load the package and then expects to
1669find a function named C<anyevent_read_type> inside. If it isn't found, it
1670progressively tries to load the parent package until it either finds the
1671function (good) or runs out of packages (bad).
1476 1672
1477Whenever the given C<type> is used, C<push_read> will invoke the code 1673Whenever this type is used, C<push_read> will invoke the function with the
1478reference with the handle object, the callback and the remaining 1674handle object, the original callback and the remaining arguments.
1479arguments.
1480 1675
1481The code reference is supposed to return a callback (usually a closure) 1676The function is supposed to return a callback (usually a closure) that
1482that works as a plain read callback (see C<< ->push_read ($cb) >>). 1677works as a plain read callback (see C<< ->push_read ($cb) >>), so you can
1678mentally treat the function as a "configurable read type to read callback"
1679converter.
1483 1680
1484It should invoke the passed callback when it is done reading (remember to 1681It should invoke the original callback when it is done reading (remember
1485pass C<$handle> as first argument as all other callbacks do that). 1682to pass C<$handle> as first argument as all other callbacks do that,
1683although there is no strict requirement on this).
1486 1684
1487Note that this is a function, and all types registered this way will be
1488global, so try to use unique names.
1489
1490For examples, see the source of this module (F<perldoc -m AnyEvent::Handle>, 1685For examples, see the source of this module (F<perldoc -m
1491search for C<register_read_type>)). 1686AnyEvent::Handle>, search for C<register_read_type>)).
1492 1687
1493=item $handle->stop_read 1688=item $handle->stop_read
1494 1689
1495=item $handle->start_read 1690=item $handle->start_read
1496 1691
1519 my ($self) = @_; 1714 my ($self) = @_;
1520 1715
1521 unless ($self->{_rw} || $self->{_eof}) { 1716 unless ($self->{_rw} || $self->{_eof}) {
1522 Scalar::Util::weaken $self; 1717 Scalar::Util::weaken $self;
1523 1718
1524 $self->{_rw} = AnyEvent->io (fh => $self->{fh}, poll => "r", cb => sub { 1719 $self->{_rw} = AE::io $self->{fh}, 0, sub {
1525 my $rbuf = \($self->{tls} ? my $buf : $self->{rbuf}); 1720 my $rbuf = \($self->{tls} ? my $buf : $self->{rbuf});
1526 my $len = sysread $self->{fh}, $$rbuf, $self->{read_size} || 8192, length $$rbuf; 1721 my $len = sysread $self->{fh}, $$rbuf, $self->{read_size} || 8192, length $$rbuf;
1527 1722
1528 if ($len > 0) { 1723 if ($len > 0) {
1529 $self->{_activity} = AnyEvent->now; 1724 $self->{_activity} = $self->{_ractivity} = AE::now;
1530 1725
1531 if ($self->{tls}) { 1726 if ($self->{tls}) {
1532 Net::SSLeay::BIO_write ($self->{_rbio}, $$rbuf); 1727 Net::SSLeay::BIO_write ($self->{_rbio}, $$rbuf);
1533 1728
1534 &_dotls ($self); 1729 &_dotls ($self);
1542 $self->_drain_rbuf; 1737 $self->_drain_rbuf;
1543 1738
1544 } elsif ($! != EAGAIN && $! != EINTR && $! != WSAEWOULDBLOCK) { 1739 } elsif ($! != EAGAIN && $! != EINTR && $! != WSAEWOULDBLOCK) {
1545 return $self->_error ($!, 1); 1740 return $self->_error ($!, 1);
1546 } 1741 }
1547 }); 1742 };
1548 } 1743 }
1549} 1744}
1550 1745
1551our $ERROR_SYSCALL; 1746our $ERROR_SYSCALL;
1552our $ERROR_WANT_READ; 1747our $ERROR_WANT_READ;
1649The TLS connection object will end up in C<< $handle->{tls} >>, the TLS 1844The 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 1845context 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 1846changed to your liking. Note that the handshake might have already started
1652when this function returns. 1847when this function returns.
1653 1848
1654If it an error to start a TLS handshake more than once per 1849Due to bugs in OpenSSL, it might or might not be possible to do multiple
1655AnyEvent::Handle object (this is due to bugs in OpenSSL). 1850handshakes on the same stream. Best do not attempt to use the stream after
1851stopping TLS.
1656 1852
1657=cut 1853=cut
1658 1854
1659our %TLS_CACHE; #TODO not yet documented, should we? 1855our %TLS_CACHE; #TODO not yet documented, should we?
1660 1856
1661sub starttls { 1857sub starttls {
1662 my ($self, $ssl, $ctx) = @_; 1858 my ($self, $tls, $ctx) = @_;
1859
1860 Carp::croak "It is an error to call starttls on an AnyEvent::Handle object while TLS is already active, caught"
1861 if $self->{tls};
1862
1863 $self->{tls} = $tls;
1864 $self->{tls_ctx} = $ctx if @_ > 2;
1865
1866 return unless $self->{fh};
1663 1867
1664 require Net::SSLeay; 1868 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 1869
1669 $ERROR_SYSCALL = Net::SSLeay::ERROR_SYSCALL (); 1870 $ERROR_SYSCALL = Net::SSLeay::ERROR_SYSCALL ();
1670 $ERROR_WANT_READ = Net::SSLeay::ERROR_WANT_READ (); 1871 $ERROR_WANT_READ = Net::SSLeay::ERROR_WANT_READ ();
1671 1872
1873 $tls = delete $self->{tls};
1672 $ctx ||= $self->{tls_ctx}; 1874 $ctx = $self->{tls_ctx};
1673 1875
1674 local $Carp::CarpLevel = 1; # skip ourselves when creating a new context or session 1876 local $Carp::CarpLevel = 1; # skip ourselves when creating a new context or session
1675 1877
1676 if ("HASH" eq ref $ctx) { 1878 if ("HASH" eq ref $ctx) {
1677 require AnyEvent::TLS; 1879 require AnyEvent::TLS;
1683 $ctx = new AnyEvent::TLS %$ctx; 1885 $ctx = new AnyEvent::TLS %$ctx;
1684 } 1886 }
1685 } 1887 }
1686 1888
1687 $self->{tls_ctx} = $ctx || TLS_CTX (); 1889 $self->{tls_ctx} = $ctx || TLS_CTX ();
1688 $self->{tls} = $ssl = $self->{tls_ctx}->_get_session ($ssl, $self, $self->{peername}); 1890 $self->{tls} = $tls = $self->{tls_ctx}->_get_session ($tls, $self, $self->{peername});
1689 1891
1690 # basically, this is deep magic (because SSL_read should have the same issues) 1892 # 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". 1893 # but the openssl maintainers basically said: "trust us, it just works".
1692 # (unfortunately, we have to hardcode constants because the abysmally misdesigned 1894 # (unfortunately, we have to hardcode constants because the abysmally misdesigned
1693 # and mismaintained ssleay-module doesn't even offer them). 1895 # 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 1902 # and we drive openssl fully in blocking mode here. Or maybe we don't - openssl seems to
1701 # have identity issues in that area. 1903 # have identity issues in that area.
1702# Net::SSLeay::CTX_set_mode ($ssl, 1904# Net::SSLeay::CTX_set_mode ($ssl,
1703# (eval { local $SIG{__DIE__}; Net::SSLeay::MODE_ENABLE_PARTIAL_WRITE () } || 1) 1905# (eval { local $SIG{__DIE__}; Net::SSLeay::MODE_ENABLE_PARTIAL_WRITE () } || 1)
1704# | (eval { local $SIG{__DIE__}; Net::SSLeay::MODE_ACCEPT_MOVING_WRITE_BUFFER () } || 2)); 1906# | (eval { local $SIG{__DIE__}; Net::SSLeay::MODE_ACCEPT_MOVING_WRITE_BUFFER () } || 2));
1705 Net::SSLeay::CTX_set_mode ($ssl, 1|2); 1907 Net::SSLeay::CTX_set_mode ($tls, 1|2);
1706 1908
1707 $self->{_rbio} = Net::SSLeay::BIO_new (Net::SSLeay::BIO_s_mem ()); 1909 $self->{_rbio} = Net::SSLeay::BIO_new (Net::SSLeay::BIO_s_mem ());
1708 $self->{_wbio} = Net::SSLeay::BIO_new (Net::SSLeay::BIO_s_mem ()); 1910 $self->{_wbio} = Net::SSLeay::BIO_new (Net::SSLeay::BIO_s_mem ());
1709 1911
1912 Net::SSLeay::BIO_write ($self->{_rbio}, delete $self->{rbuf});
1913
1710 Net::SSLeay::set_bio ($ssl, $self->{_rbio}, $self->{_wbio}); 1914 Net::SSLeay::set_bio ($tls, $self->{_rbio}, $self->{_wbio});
1711 1915
1712 $self->{_on_starttls} = sub { $_[0]{on_starttls}(@_) } 1916 $self->{_on_starttls} = sub { $_[0]{on_starttls}(@_) }
1713 if $self->{on_starttls}; 1917 if $self->{on_starttls};
1714 1918
1715 &_dotls; # need to trigger the initial handshake 1919 &_dotls; # need to trigger the initial handshake
1718 1922
1719=item $handle->stoptls 1923=item $handle->stoptls
1720 1924
1721Shuts down the SSL connection - this makes a proper EOF handshake by 1925Shuts down the SSL connection - this makes a proper EOF handshake by
1722sending a close notify to the other side, but since OpenSSL doesn't 1926sending 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 1927support non-blocking shut downs, it is not guarenteed that you can re-use
1724afterwards. 1928the stream afterwards.
1725 1929
1726=cut 1930=cut
1727 1931
1728sub stoptls { 1932sub stoptls {
1729 my ($self) = @_; 1933 my ($self) = @_;
1742sub _freetls { 1946sub _freetls {
1743 my ($self) = @_; 1947 my ($self) = @_;
1744 1948
1745 return unless $self->{tls}; 1949 return unless $self->{tls};
1746 1950
1747 $self->{tls_ctx}->_put_session (delete $self->{tls}); 1951 $self->{tls_ctx}->_put_session (delete $self->{tls})
1952 if $self->{tls} > 0;
1748 1953
1749 delete @$self{qw(_rbio _wbio _tls_wbuf _on_starttls)}; 1954 delete @$self{qw(_rbio _wbio _tls_wbuf _on_starttls)};
1750} 1955}
1751 1956
1752sub DESTROY { 1957sub DESTROY {
1760 my $fh = delete $self->{fh}; 1965 my $fh = delete $self->{fh};
1761 my $wbuf = delete $self->{wbuf}; 1966 my $wbuf = delete $self->{wbuf};
1762 1967
1763 my @linger; 1968 my @linger;
1764 1969
1765 push @linger, AnyEvent->io (fh => $fh, poll => "w", cb => sub { 1970 push @linger, AE::io $fh, 1, sub {
1766 my $len = syswrite $fh, $wbuf, length $wbuf; 1971 my $len = syswrite $fh, $wbuf, length $wbuf;
1767 1972
1768 if ($len > 0) { 1973 if ($len > 0) {
1769 substr $wbuf, 0, $len, ""; 1974 substr $wbuf, 0, $len, "";
1770 } else { 1975 } else {
1771 @linger = (); # end 1976 @linger = (); # end
1772 } 1977 }
1773 }); 1978 };
1774 push @linger, AnyEvent->timer (after => $linger, cb => sub { 1979 push @linger, AE::timer $linger, 0, sub {
1775 @linger = (); 1980 @linger = ();
1776 }); 1981 };
1777 } 1982 }
1778} 1983}
1779 1984
1780=item $handle->destroy 1985=item $handle->destroy
1781 1986
1782Shuts down the handle object as much as possible - this call ensures that 1987Shuts down the handle object as much as possible - this call ensures that
1783no further callbacks will be invoked and as many resources as possible 1988no further callbacks will be invoked and as many resources as possible
1784will be freed. You must not call any methods on the object afterwards. 1989will be freed. Any method you will call on the handle object after
1990destroying it in this way will be silently ignored (and it will return the
1991empty list).
1785 1992
1786Normally, you can just "forget" any references to an AnyEvent::Handle 1993Normally, you can just "forget" any references to an AnyEvent::Handle
1787object and it will simply shut down. This works in fatal error and EOF 1994object 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 1995callbacks, 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 1996callback, so when you want to destroy the AnyEvent::Handle object from
1803sub destroy { 2010sub destroy {
1804 my ($self) = @_; 2011 my ($self) = @_;
1805 2012
1806 $self->DESTROY; 2013 $self->DESTROY;
1807 %$self = (); 2014 %$self = ();
2015 bless $self, "AnyEvent::Handle::destroyed";
2016}
2017
2018sub AnyEvent::Handle::destroyed::AUTOLOAD {
2019 #nop
1808} 2020}
1809 2021
1810=item AnyEvent::Handle::TLS_CTX 2022=item AnyEvent::Handle::TLS_CTX
1811 2023
1812This function creates and returns the AnyEvent::TLS object used by default 2024This function creates and returns the AnyEvent::TLS object used by default

Diff Legend

Removed lines
+ Added lines
< Changed lines
> Changed lines