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.150 by root, Thu Jul 16 04:16:25 2009 UTC vs.
Revision 1.180 by root, Thu Aug 20 22:58:35 2009 UTC

1package AnyEvent::Handle;
2
3no warnings;
4use strict qw(subs vars);
5
6use AnyEvent ();
7use AnyEvent::Util qw(WSAEWOULDBLOCK);
8use Scalar::Util ();
9use Carp ();
10use Fcntl ();
11use Errno qw(EAGAIN EINTR);
12
13=head1 NAME 1=head1 NAME
14 2
15AnyEvent::Handle - non-blocking I/O on file handles via AnyEvent 3AnyEvent::Handle - non-blocking I/O on file handles via AnyEvent
16
17=cut
18
19our $VERSION = 4.82;
20 4
21=head1 SYNOPSIS 5=head1 SYNOPSIS
22 6
23 use AnyEvent; 7 use AnyEvent;
24 use AnyEvent::Handle; 8 use AnyEvent::Handle;
26 my $cv = AnyEvent->condvar; 10 my $cv = AnyEvent->condvar;
27 11
28 my $hdl; $hdl = new AnyEvent::Handle 12 my $hdl; $hdl = new AnyEvent::Handle
29 fh => \*STDIN, 13 fh => \*STDIN,
30 on_error => sub { 14 on_error => sub {
15 my ($hdl, $fatal, $msg) = @_;
31 warn "got error $_[2]\n"; 16 warn "got error $msg\n";
17 $hdl->destroy;
32 $cv->send; 18 $cv->send;
33 ); 19 );
34 20
35 # send some request line 21 # send some request line
36 $hdl->push_write ("getinfo\015\012"); 22 $hdl->push_write ("getinfo\015\012");
45 $cv->recv; 31 $cv->recv;
46 32
47=head1 DESCRIPTION 33=head1 DESCRIPTION
48 34
49This module is a helper module to make it easier to do event-based I/O on 35This 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 36filehandles.
51on sockets see L<AnyEvent::Util>.
52 37
53The L<AnyEvent::Intro> tutorial contains some well-documented 38The L<AnyEvent::Intro> tutorial contains some well-documented
54AnyEvent::Handle examples. 39AnyEvent::Handle examples.
55 40
56In the following, when the documentation refers to of "bytes" then this 41In the following, when the documentation refers to of "bytes" then this
57means characters. As sysread and syswrite are used for all I/O, their 42means characters. As sysread and syswrite are used for all I/O, their
58treatment of characters applies to this module as well. 43treatment of characters applies to this module as well.
59 44
45At the very minimum, you should specify C<fh> or C<connect>, and the
46C<on_error> callback.
47
60All callbacks will be invoked with the handle object as their first 48All callbacks will be invoked with the handle object as their first
61argument. 49argument.
62 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
63=head1 METHODS 65=head1 METHODS
64 66
65=over 4 67=over 4
66 68
67=item $handle = B<new> AnyEvent::TLS fh => $filehandle, key => value... 69=item $handle = B<new> AnyEvent::TLS fh => $filehandle, key => value...
68 70
69The constructor supports these arguments (all as C<< key => value >> pairs). 71The constructor supports these arguments (all as C<< key => value >> pairs).
70 72
71=over 4 73=over 4
72 74
73=item fh => $filehandle [MANDATORY] 75=item fh => $filehandle [C<fh> or C<connect> MANDATORY]
74 76
75The filehandle this L<AnyEvent::Handle> object will operate on. 77The filehandle this L<AnyEvent::Handle> object will operate on.
76
77NOTE: The filehandle will be set to non-blocking mode (using 78NOTE: The filehandle will be set to non-blocking mode (using
78C<AnyEvent::Util::fh_nonblocking>) by the constructor and needs to stay in 79C<AnyEvent::Util::fh_nonblocking>) by the constructor and needs to stay in
79that mode. 80that mode.
81
82=item connect => [$host, $service] [C<fh> or C<connect> MANDATORY]
83
84Try to connect to the specified host and service (port), using
85C<AnyEvent::Socket::tcp_connect>. The C<$host> additionally becomes the
86default C<peername>.
87
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.
92
93When this parameter is specified, then the C<on_prepare>,
94C<on_connect_error> and C<on_connect> callbacks will be called under the
95appropriate circumstances:
96
97=over 4
98
99=item on_prepare => $cb->($handle)
100
101This (rarely used) callback is called before a new connection is
102attempted, but after the file handle has been created. It could be used to
103prepare the file handle with parameters required for the actual connect
104(as opposed to settings that can be changed when the connection is already
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).
110
111=item on_connect => $cb->($handle, $host, $port, $retry->())
112
113This callback is called when a connection has been successfully established.
114
115The actual numeric host and port (the socket peername) are passed as
116parameters, together with a retry callback.
117
118When, for some reason, the handle is not acceptable, then calling
119C<$retry> will continue with the next conenction target (in case of
120multi-homed hosts or SRV records there can be multiple connection
121endpoints). When it is called then the read and write queues, eof status,
122tls status and similar properties of the handle are being reset.
123
124In most cases, ignoring the C<$retry> parameter is the way to go.
125
126=item on_connect_error => $cb->($handle, $message)
127
128This callback is called when the conenction could not be
129established. C<$!> will contain the relevant error code, and C<$message> a
130message describing it (usually the same as C<"$!">).
131
132If this callback isn't specified, then C<on_error> will be called with a
133fatal error instead.
134
135=back
136
137=item on_error => $cb->($handle, $fatal, $message)
138
139This is the error callback, which is called when, well, some error
140occured, such as not being able to resolve the hostname, failure to
141connect or a read error.
142
143Some errors are fatal (which is indicated by C<$fatal> being true). On
144fatal errors the handle object will be destroyed (by a call to C<< ->
145destroy >>) after invoking the error callback (which means you are free to
146examine the handle object). Examples of fatal errors are an EOF condition
147with active (but unsatisifable) read watchers (C<EPIPE>) or I/O errors. In
148cases where the other side can close the connection at their will it is
149often easiest to not report C<EPIPE> errors in this callback.
150
151AnyEvent::Handle tries to find an appropriate error code for you to check
152against, but in some cases (TLS errors), this does not work well. It is
153recommended to always output the C<$message> argument in human-readable
154error messages (it's usually the same as C<"$!">).
155
156Non-fatal errors can be retried by simply returning, but it is recommended
157to simply ignore this parameter and instead abondon the handle object
158when this callback is invoked. Examples of non-fatal errors are timeouts
159C<ETIMEDOUT>) or badly-formatted data (C<EBADMSG>).
160
161On callback entrance, the value of C<$!> contains the operating system
162error code (or C<ENOSPC>, C<EPIPE>, C<ETIMEDOUT>, C<EBADMSG> or
163C<EPROTO>).
164
165While not mandatory, it is I<highly> recommended to set this callback, as
166you will not be notified of errors otherwise. The default simply calls
167C<croak>.
168
169=item on_read => $cb->($handle)
170
171This sets the default read callback, which is called when data arrives
172and no read request is in the queue (unlike read queue callbacks, this
173callback will only be called when at least one octet of data is in the
174read buffer).
175
176To access (and remove data from) the read buffer, use the C<< ->rbuf >>
177method or access the C<< $handle->{rbuf} >> member directly. Note that you
178must not enlarge or modify the read buffer, you can only remove data at
179the beginning from it.
180
181When an EOF condition is detected then AnyEvent::Handle will first try to
182feed all the remaining data to the queued callbacks and C<on_read> before
183calling the C<on_eof> callback. If no progress can be made, then a fatal
184error will be raised (with C<$!> set to C<EPIPE>).
185
186Note that, unlike requests in the read queue, an C<on_read> callback
187doesn't mean you I<require> some data: if there is an EOF and there
188are outstanding read requests then an error will be flagged. With an
189C<on_read> callback, the C<on_eof> callback will be invoked.
80 190
81=item on_eof => $cb->($handle) 191=item on_eof => $cb->($handle)
82 192
83Set the callback to be called when an end-of-file condition is detected, 193Set the callback to be called when an end-of-file condition is detected,
84i.e. in the case of a socket, when the other side has closed the 194i.e. in the case of a socket, when the other side has closed the
92down. 202down.
93 203
94If an EOF condition has been detected but no C<on_eof> callback has been 204If an EOF condition has been detected but no C<on_eof> callback has been
95set, then a fatal error will be raised with C<$!> set to <0>. 205set, then a fatal error will be raised with C<$!> set to <0>.
96 206
97=item on_error => $cb->($handle, $fatal, $message)
98
99This is the error callback, which is called when, well, some error
100occured, such as not being able to resolve the hostname, failure to
101connect or a read error.
102
103Some errors are fatal (which is indicated by C<$fatal> being true). On
104fatal errors the handle object will be destroyed (by a call to C<< ->
105destroy >>) after invoking the error callback (which means you are free to
106examine the handle object). Examples of fatal errors are an EOF condition
107with active (but unsatisifable) read watchers (C<EPIPE>) or I/O errors.
108
109AnyEvent::Handle tries to find an appropriate error code for you to check
110against, but in some cases (TLS errors), this does not work well. It is
111recommended to always output the C<$message> argument in human-readable
112error messages (it's usually the same as C<"$!">).
113
114Non-fatal errors can be retried by simply returning, but it is recommended
115to simply ignore this parameter and instead abondon the handle object
116when this callback is invoked. Examples of non-fatal errors are timeouts
117C<ETIMEDOUT>) or badly-formatted data (C<EBADMSG>).
118
119On callback entrance, the value of C<$!> contains the operating system
120error code (or C<ENOSPC>, C<EPIPE>, C<ETIMEDOUT>, C<EBADMSG> or
121C<EPROTO>).
122
123While not mandatory, it is I<highly> recommended to set this callback, as
124you will not be notified of errors otherwise. The default simply calls
125C<croak>.
126
127=item on_read => $cb->($handle)
128
129This sets the default read callback, which is called when data arrives
130and no read request is in the queue (unlike read queue callbacks, this
131callback will only be called when at least one octet of data is in the
132read buffer).
133
134To access (and remove data from) the read buffer, use the C<< ->rbuf >>
135method or access the C<< $handle->{rbuf} >> member directly. Note that you
136must not enlarge or modify the read buffer, you can only remove data at
137the beginning from it.
138
139When an EOF condition is detected then AnyEvent::Handle will first try to
140feed all the remaining data to the queued callbacks and C<on_read> before
141calling the C<on_eof> callback. If no progress can be made, then a fatal
142error will be raised (with C<$!> set to C<EPIPE>).
143
144Note that, unlike requests in the read queue, an C<on_read> callback
145doesn't mean you I<require> some data: if there is an EOF and there
146are outstanding read requests then an error will be flagged. With an
147C<on_read> callback, the C<on_eof> callback will be invoked.
148
149=item on_drain => $cb->($handle) 207=item on_drain => $cb->($handle)
150 208
151This sets the callback that is called when the write buffer becomes empty 209This sets the callback that is called when the write buffer becomes empty
152(or when the callback is set and the buffer is empty already). 210(or when the callback is set and the buffer is empty already).
153 211
159memory 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
160the file when the write queue becomes empty. 218the file when the write queue becomes empty.
161 219
162=item timeout => $fractional_seconds 220=item timeout => $fractional_seconds
163 221
222=item rtimeout => $fractional_seconds
223
224=item wtimeout => $fractional_seconds
225
164If non-zero, then this enables an "inactivity" timeout: whenever this many 226If non-zero, then these enables an "inactivity" timeout: whenever this
165seconds pass without a successful read or write on the underlying file 227many seconds pass without a successful read or write on the underlying
166handle, 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
167missing, 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>.
168 237
169Note 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
170any 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
171idle then you should disable the timout temporarily or ignore the timeout 240idle then you should disable the timout temporarily or ignore the timeout
172in 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
351 420
352sub new { 421sub new {
353 my $class = shift; 422 my $class = shift;
354 my $self = bless { @_ }, $class; 423 my $self = bless { @_ }, $class;
355 424
356 $self->{fh} or Carp::croak "mandatory argument fh is missing"; 425 if ($self->{fh}) {
426 $self->_start;
427 return unless $self->{fh}; # could be gone by now
428
429 } elsif ($self->{connect}) {
430 require AnyEvent::Socket;
431
432 $self->{peername} = $self->{connect}[0]
433 unless exists $self->{peername};
434
435 $self->{_skip_drain_rbuf} = 1;
436
437 {
438 Scalar::Util::weaken (my $self = $self);
439
440 $self->{_connect} =
441 AnyEvent::Socket::tcp_connect (
442 $self->{connect}[0],
443 $self->{connect}[1],
444 sub {
445 my ($fh, $host, $port, $retry) = @_;
446
447 if ($fh) {
448 $self->{fh} = $fh;
449
450 delete $self->{_skip_drain_rbuf};
451 $self->_start;
452
453 $self->{on_connect}
454 and $self->{on_connect}($self, $host, $port, sub {
455 delete @$self{qw(fh _tw _rtw _wtw _ww _rw _eof _queue rbuf _wbuf tls _tls_rbuf _tls_wbuf)};
456 $self->{_skip_drain_rbuf} = 1;
457 &$retry;
458 });
459
460 } else {
461 if ($self->{on_connect_error}) {
462 $self->{on_connect_error}($self, "$!");
463 $self->destroy;
464 } else {
465 $self->_error ($!, 1);
466 }
467 }
468 },
469 sub {
470 local $self->{fh} = $_[0];
471
472 $self->{on_prepare}
473 ? $self->{on_prepare}->($self)
474 : ()
475 }
476 );
477 }
478
479 } else {
480 Carp::croak "AnyEvent::Handle: either an existing fh or the connect parameter must be specified";
481 }
482
483 $self
484}
485
486sub _start {
487 my ($self) = @_;
357 488
358 AnyEvent::Util::fh_nonblocking $self->{fh}, 1; 489 AnyEvent::Util::fh_nonblocking $self->{fh}, 1;
359 490
491 $self->{_activity} =
492 $self->{_ractivity} =
360 $self->{_activity} = AnyEvent->now; 493 $self->{_wactivity} = AE::now;
361 $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};
362 498
363 $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};
364 500
365 $self->starttls (delete $self->{tls}, delete $self->{tls_ctx}) 501 $self->starttls (delete $self->{tls}, delete $self->{tls_ctx})
366 if $self->{tls}; 502 if $self->{tls};
367 503
368 $self->on_drain (delete $self->{on_drain}) if $self->{on_drain}; 504 $self->on_drain (delete $self->{on_drain}) if $self->{on_drain};
369 505
370 $self->start_read 506 $self->start_read
371 if $self->{on_read}; 507 if $self->{on_read} || @{ $self->{_queue} };
372 508
373 $self->{fh} && $self 509 $self->_drain_wbuf;
374} 510}
375
376#sub _shutdown {
377# my ($self) = @_;
378#
379# delete @$self{qw(_tw _rw _ww fh wbuf on_read _queue)};
380# $self->{_eof} = 1; # tell starttls et. al to stop trying
381#
382# &_freetls;
383#}
384 511
385sub _error { 512sub _error {
386 my ($self, $errno, $fatal, $message) = @_; 513 my ($self, $errno, $fatal, $message) = @_;
387 514
388 $! = $errno; 515 $! = $errno;
389 $message ||= "$!"; 516 $message ||= "$!";
390 517
391 if ($self->{on_error}) { 518 if ($self->{on_error}) {
392 $self->{on_error}($self, $fatal, $message); 519 $self->{on_error}($self, $fatal, $message);
393 $self->destroy; 520 $self->destroy if $fatal;
394 } elsif ($self->{fh}) { 521 } elsif ($self->{fh}) {
395 $self->destroy; 522 $self->destroy;
396 Carp::croak "AnyEvent::Handle uncaught error: $message"; 523 Carp::croak "AnyEvent::Handle uncaught error: $message";
397 } 524 }
398} 525}
425 $_[0]{on_eof} = $_[1]; 552 $_[0]{on_eof} = $_[1];
426} 553}
427 554
428=item $handle->on_timeout ($cb) 555=item $handle->on_timeout ($cb)
429 556
430Replace the current C<on_timeout> callback, or disables the callback (but 557=item $handle->on_rtimeout ($cb)
431not the timeout) if C<$cb> = C<undef>. See the C<timeout> constructor
432argument and method.
433 558
434=cut 559=item $handle->on_wtimeout ($cb)
435 560
436sub on_timeout { 561Replace the current C<on_timeout>, C<on_rtimeout> or C<on_wtimeout>
437 $_[0]{on_timeout} = $_[1]; 562callback, or disables the callback (but not the timeout) if C<$cb> =
438} 563C<undef>. See the C<timeout> constructor argument and method.
564
565=cut
566
567# see below
439 568
440=item $handle->autocork ($boolean) 569=item $handle->autocork ($boolean)
441 570
442Enables or disables the current autocork behaviour (see C<autocork> 571Enables or disables the current autocork behaviour (see C<autocork>
443constructor argument). Changes will only take effect on the next write. 572constructor argument). Changes will only take effect on the next write.
458sub no_delay { 587sub no_delay {
459 $_[0]{no_delay} = $_[1]; 588 $_[0]{no_delay} = $_[1];
460 589
461 eval { 590 eval {
462 local $SIG{__DIE__}; 591 local $SIG{__DIE__};
463 setsockopt $_[0]{fh}, &Socket::IPPROTO_TCP, &Socket::TCP_NODELAY, int $_[1]; 592 setsockopt $_[0]{fh}, &Socket::IPPROTO_TCP, &Socket::TCP_NODELAY, int $_[1]
593 if $_[0]{fh};
464 }; 594 };
465} 595}
466 596
467=item $handle->on_starttls ($cb) 597=item $handle->on_starttls ($cb)
468 598
482 612
483sub on_starttls { 613sub on_starttls {
484 $_[0]{on_stoptls} = $_[1]; 614 $_[0]{on_stoptls} = $_[1];
485} 615}
486 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
487############################################################################# 627#############################################################################
488 628
489=item $handle->timeout ($seconds) 629=item $handle->timeout ($seconds)
490 630
631=item $handle->rtimeout ($seconds)
632
633=item $handle->wtimeout ($seconds)
634
491Configures (or disables) the inactivity timeout. 635Configures (or disables) the inactivity timeout.
492 636
493=cut 637=item $handle->timeout_reset
494 638
495sub 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 {
496 my ($self, $timeout) = @_; 661 my ($self, $new_value) = @_;
497 662
498 $self->{timeout} = $timeout; 663 $self->{$timeout} = $new_value;
499 $self->_timeout; 664 delete $self->{$tw}; &$cb;
500} 665 };
501 666
667 *{"${dir}timeout_reset"} = sub {
668 $_[0]{$activity} = AE::now;
669 };
670
671 # main workhorse:
502# reset the timeout watcher, as neccessary 672 # reset the timeout watcher, as neccessary
503# also check for time-outs 673 # also check for time-outs
504sub _timeout { 674 $cb = sub {
505 my ($self) = @_; 675 my ($self) = @_;
506 676
507 if ($self->{timeout}) { 677 if ($self->{$timeout} && $self->{fh}) {
508 my $NOW = AnyEvent->now; 678 my $NOW = AE::now;
509 679
510 # when would the timeout trigger? 680 # when would the timeout trigger?
511 my $after = $self->{_activity} + $self->{timeout} - $NOW; 681 my $after = $self->{$activity} + $self->{$timeout} - $NOW;
512 682
513 # now or in the past already? 683 # now or in the past already?
514 if ($after <= 0) { 684 if ($after <= 0) {
515 $self->{_activity} = $NOW; 685 $self->{$activity} = $NOW;
516 686
517 if ($self->{on_timeout}) { 687 if ($self->{$on_timeout}) {
518 $self->{on_timeout}($self); 688 $self->{$on_timeout}($self);
519 } else { 689 } else {
520 $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};
521 } 698 }
522 699
523 # callback could have changed timeout value, optimise 700 Scalar::Util::weaken $self;
524 return unless $self->{timeout}; 701 return unless $self; # ->error could have destroyed $self
525 702
526 # calculate new after 703 $self->{$tw} ||= AE::timer $after, 0, sub {
527 $after = $self->{timeout}; 704 delete $self->{$tw};
705 $cb->($self);
706 };
707 } else {
708 delete $self->{$tw};
528 } 709 }
529
530 Scalar::Util::weaken $self;
531 return unless $self; # ->error could have destroyed $self
532
533 $self->{_tw} ||= AnyEvent->timer (after => $after, cb => sub {
534 delete $self->{_tw};
535 $self->_timeout;
536 });
537 } else {
538 delete $self->{_tw};
539 } 710 }
540} 711}
541 712
542############################################################################# 713#############################################################################
543 714
591 my $len = syswrite $self->{fh}, $self->{wbuf}; 762 my $len = syswrite $self->{fh}, $self->{wbuf};
592 763
593 if (defined $len) { 764 if (defined $len) {
594 substr $self->{wbuf}, 0, $len, ""; 765 substr $self->{wbuf}, 0, $len, "";
595 766
596 $self->{_activity} = AnyEvent->now; 767 $self->{_activity} = $self->{_wactivity} = AE::now;
597 768
598 $self->{on_drain}($self) 769 $self->{on_drain}($self)
599 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})
600 && $self->{on_drain}; 771 && $self->{on_drain};
601 772
607 778
608 # try to write data immediately 779 # try to write data immediately
609 $cb->() unless $self->{autocork}; 780 $cb->() unless $self->{autocork};
610 781
611 # if still data left in wbuf, we need to poll 782 # if still data left in wbuf, we need to poll
612 $self->{_ww} = AnyEvent->io (fh => $self->{fh}, poll => "w", cb => $cb) 783 $self->{_ww} = AE::io $self->{fh}, 1, $cb
613 if length $self->{wbuf}; 784 if length $self->{wbuf};
614 }; 785 };
615} 786}
616 787
617our %WH; 788our %WH;
630 ->($self, @_); 801 ->($self, @_);
631 } 802 }
632 803
633 if ($self->{tls}) { 804 if ($self->{tls}) {
634 $self->{_tls_wbuf} .= $_[0]; 805 $self->{_tls_wbuf} .= $_[0];
635 806 &_dotls ($self) if $self->{fh};
636 &_dotls ($self);
637 } else { 807 } else {
638 $self->{wbuf} .= $_[0]; 808 $self->{wbuf} .= $_[0];
639 $self->_drain_wbuf; 809 $self->_drain_wbuf if $self->{fh};
640 } 810 }
641} 811}
642 812
643=item $handle->push_write (type => @args) 813=item $handle->push_write (type => @args)
644 814
708Other languages could read single lines terminated by a newline and pass 878Other languages could read single lines terminated by a newline and pass
709this line into their JSON decoder of choice. 879this line into their JSON decoder of choice.
710 880
711=cut 881=cut
712 882
883sub json_coder() {
884 eval { require JSON::XS; JSON::XS->new->utf8 }
885 || do { require JSON; JSON->new->utf8 }
886}
887
713register_write_type json => sub { 888register_write_type json => sub {
714 my ($self, $ref) = @_; 889 my ($self, $ref) = @_;
715 890
716 require JSON; 891 my $json = $self->{json} ||= json_coder;
717 892
718 $self->{json} ? $self->{json}->encode ($ref) 893 $json->encode ($ref)
719 : JSON::encode_json ($ref)
720}; 894};
721 895
722=item storable => $reference 896=item storable => $reference
723 897
724Freezes the given reference using L<Storable> and writes it to the 898Freezes the given reference using L<Storable> and writes it to the
861=cut 1035=cut
862 1036
863sub _drain_rbuf { 1037sub _drain_rbuf {
864 my ($self) = @_; 1038 my ($self) = @_;
865 1039
1040 # avoid recursion
1041 return if $self->{_skip_drain_rbuf};
866 local $self->{_in_drain} = 1; 1042 local $self->{_skip_drain_rbuf} = 1;
867
868 if (
869 defined $self->{rbuf_max}
870 && $self->{rbuf_max} < length $self->{rbuf}
871 ) {
872 $self->_error (Errno::ENOSPC, 1), return;
873 }
874 1043
875 while () { 1044 while () {
876 # 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
877 # 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.
878 $self->{rbuf} .= delete $self->{_tls_rbuf} if exists $self->{_tls_rbuf}; 1047 $self->{rbuf} .= delete $self->{_tls_rbuf}
1048 if exists $self->{_tls_rbuf};
879 1049
880 my $len = length $self->{rbuf}; 1050 my $len = length $self->{rbuf};
881 1051
882 if (my $cb = shift @{ $self->{_queue} }) { 1052 if (my $cb = shift @{ $self->{_queue} }) {
883 unless ($cb->($self)) { 1053 unless ($cb->($self)) {
884 if ($self->{_eof}) { 1054 # no progress can be made
885 # no progress can be made (not enough data and no data forthcoming) 1055 # (not enough data and no data forthcoming)
886 $self->_error (Errno::EPIPE, 1), return; 1056 $self->_error (Errno::EPIPE, 1), return
887 } 1057 if $self->{_eof};
888 1058
889 unshift @{ $self->{_queue} }, $cb; 1059 unshift @{ $self->{_queue} }, $cb;
890 last; 1060 last;
891 } 1061 }
892 } elsif ($self->{on_read}) { 1062 } elsif ($self->{on_read}) {
912 last; 1082 last;
913 } 1083 }
914 } 1084 }
915 1085
916 if ($self->{_eof}) { 1086 if ($self->{_eof}) {
917 if ($self->{on_eof}) { 1087 $self->{on_eof}
918 $self->{on_eof}($self) 1088 ? $self->{on_eof}($self)
919 } else {
920 $self->_error (0, 1, "Unexpected end-of-file"); 1089 : $self->_error (0, 1, "Unexpected end-of-file");
921 } 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;
922 } 1099 }
923 1100
924 # may need to restart read watcher 1101 # may need to restart read watcher
925 unless ($self->{_rw}) { 1102 unless ($self->{_rw}) {
926 $self->start_read 1103 $self->start_read
938 1115
939sub on_read { 1116sub on_read {
940 my ($self, $cb) = @_; 1117 my ($self, $cb) = @_;
941 1118
942 $self->{on_read} = $cb; 1119 $self->{on_read} = $cb;
943 $self->_drain_rbuf if $cb && !$self->{_in_drain}; 1120 $self->_drain_rbuf if $cb;
944} 1121}
945 1122
946=item $handle->rbuf 1123=item $handle->rbuf
947 1124
948Returns the read buffer (as a modifiable lvalue). 1125Returns the read buffer (as a modifiable lvalue).
1000 $cb = ($RH{$type} or Carp::croak "unsupported type passed to AnyEvent::Handle::push_read") 1177 $cb = ($RH{$type} or Carp::croak "unsupported type passed to AnyEvent::Handle::push_read")
1001 ->($self, $cb, @_); 1178 ->($self, $cb, @_);
1002 } 1179 }
1003 1180
1004 push @{ $self->{_queue} }, $cb; 1181 push @{ $self->{_queue} }, $cb;
1005 $self->_drain_rbuf unless $self->{_in_drain}; 1182 $self->_drain_rbuf;
1006} 1183}
1007 1184
1008sub unshift_read { 1185sub unshift_read {
1009 my $self = shift; 1186 my $self = shift;
1010 my $cb = pop; 1187 my $cb = pop;
1016 ->($self, $cb, @_); 1193 ->($self, $cb, @_);
1017 } 1194 }
1018 1195
1019 1196
1020 unshift @{ $self->{_queue} }, $cb; 1197 unshift @{ $self->{_queue} }, $cb;
1021 $self->_drain_rbuf unless $self->{_in_drain}; 1198 $self->_drain_rbuf;
1022} 1199}
1023 1200
1024=item $handle->push_read (type => @args, $cb) 1201=item $handle->push_read (type => @args, $cb)
1025 1202
1026=item $handle->unshift_read (type => @args, $cb) 1203=item $handle->unshift_read (type => @args, $cb)
1275=cut 1452=cut
1276 1453
1277register_read_type json => sub { 1454register_read_type json => sub {
1278 my ($self, $cb) = @_; 1455 my ($self, $cb) = @_;
1279 1456
1280 my $json = $self->{json} ||= 1457 my $json = $self->{json} ||= json_coder;
1281 eval { require JSON::XS; JSON::XS->new->utf8 }
1282 || do { require JSON; JSON->new->utf8 };
1283 1458
1284 my $data; 1459 my $data;
1285 my $rbuf = \$self->{rbuf}; 1460 my $rbuf = \$self->{rbuf};
1286 1461
1287 sub { 1462 sub {
1407 my ($self) = @_; 1582 my ($self) = @_;
1408 1583
1409 unless ($self->{_rw} || $self->{_eof}) { 1584 unless ($self->{_rw} || $self->{_eof}) {
1410 Scalar::Util::weaken $self; 1585 Scalar::Util::weaken $self;
1411 1586
1412 $self->{_rw} = AnyEvent->io (fh => $self->{fh}, poll => "r", cb => sub { 1587 $self->{_rw} = AE::io $self->{fh}, 0, sub {
1413 my $rbuf = \($self->{tls} ? my $buf : $self->{rbuf}); 1588 my $rbuf = \($self->{tls} ? my $buf : $self->{rbuf});
1414 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;
1415 1590
1416 if ($len > 0) { 1591 if ($len > 0) {
1417 $self->{_activity} = AnyEvent->now; 1592 $self->{_activity} = $self->{_ractivity} = AE::now;
1418 1593
1419 if ($self->{tls}) { 1594 if ($self->{tls}) {
1420 Net::SSLeay::BIO_write ($self->{_rbio}, $$rbuf); 1595 Net::SSLeay::BIO_write ($self->{_rbio}, $$rbuf);
1421 1596
1422 &_dotls ($self); 1597 &_dotls ($self);
1423 } else { 1598 } else {
1424 $self->_drain_rbuf unless $self->{_in_drain}; 1599 $self->_drain_rbuf;
1425 } 1600 }
1426 1601
1427 } elsif (defined $len) { 1602 } elsif (defined $len) {
1428 delete $self->{_rw}; 1603 delete $self->{_rw};
1429 $self->{_eof} = 1; 1604 $self->{_eof} = 1;
1430 $self->_drain_rbuf unless $self->{_in_drain}; 1605 $self->_drain_rbuf;
1431 1606
1432 } elsif ($! != EAGAIN && $! != EINTR && $! != WSAEWOULDBLOCK) { 1607 } elsif ($! != EAGAIN && $! != EINTR && $! != WSAEWOULDBLOCK) {
1433 return $self->_error ($!, 1); 1608 return $self->_error ($!, 1);
1434 } 1609 }
1435 }); 1610 };
1436 } 1611 }
1437} 1612}
1438 1613
1439our $ERROR_SYSCALL; 1614our $ERROR_SYSCALL;
1440our $ERROR_WANT_READ; 1615our $ERROR_WANT_READ;
1495 $self->{_eof} = 1; 1670 $self->{_eof} = 1;
1496 } 1671 }
1497 } 1672 }
1498 1673
1499 $self->{_tls_rbuf} .= $tmp; 1674 $self->{_tls_rbuf} .= $tmp;
1500 $self->_drain_rbuf unless $self->{_in_drain}; 1675 $self->_drain_rbuf;
1501 $self->{tls} or return; # tls session might have gone away in callback 1676 $self->{tls} or return; # tls session might have gone away in callback
1502 } 1677 }
1503 1678
1504 $tmp = Net::SSLeay::get_error ($self->{tls}, -1); 1679 $tmp = Net::SSLeay::get_error ($self->{tls}, -1);
1505 return $self->_tls_error ($tmp) 1680 return $self->_tls_error ($tmp)
1520 1695
1521Instead of starting TLS negotiation immediately when the AnyEvent::Handle 1696Instead of starting TLS negotiation immediately when the AnyEvent::Handle
1522object is created, you can also do that at a later time by calling 1697object is created, you can also do that at a later time by calling
1523C<starttls>. 1698C<starttls>.
1524 1699
1700Starting TLS is currently an asynchronous operation - when you push some
1701write data and then call C<< ->starttls >> then TLS negotiation will start
1702immediately, after which the queued write data is then sent.
1703
1525The first argument is the same as the C<tls> constructor argument (either 1704The first argument is the same as the C<tls> constructor argument (either
1526C<"connect">, C<"accept"> or an existing Net::SSLeay object). 1705C<"connect">, C<"accept"> or an existing Net::SSLeay object).
1527 1706
1528The second argument is the optional C<AnyEvent::TLS> object that is used 1707The second argument is the optional C<AnyEvent::TLS> object that is used
1529when AnyEvent::Handle has to create its own TLS connection object, or 1708when AnyEvent::Handle has to create its own TLS connection object, or
1533The 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
1534context 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
1535changed to your liking. Note that the handshake might have already started 1714changed to your liking. Note that the handshake might have already started
1536when this function returns. 1715when this function returns.
1537 1716
1538If 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
1539AnyEvent::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.
1540 1720
1541=cut 1721=cut
1542 1722
1543our %TLS_CACHE; #TODO not yet documented, should we? 1723our %TLS_CACHE; #TODO not yet documented, should we?
1544 1724
1545sub starttls { 1725sub starttls {
1546 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};
1547 1735
1548 require Net::SSLeay; 1736 require Net::SSLeay;
1549
1550 Carp::croak "it is an error to call starttls more than once on an AnyEvent::Handle object"
1551 if $self->{tls};
1552 1737
1553 $ERROR_SYSCALL = Net::SSLeay::ERROR_SYSCALL (); 1738 $ERROR_SYSCALL = Net::SSLeay::ERROR_SYSCALL ();
1554 $ERROR_WANT_READ = Net::SSLeay::ERROR_WANT_READ (); 1739 $ERROR_WANT_READ = Net::SSLeay::ERROR_WANT_READ ();
1555 1740
1741 $tls = delete $self->{tls};
1556 $ctx ||= $self->{tls_ctx}; 1742 $ctx = $self->{tls_ctx};
1743
1744 local $Carp::CarpLevel = 1; # skip ourselves when creating a new context or session
1557 1745
1558 if ("HASH" eq ref $ctx) { 1746 if ("HASH" eq ref $ctx) {
1559 require AnyEvent::TLS; 1747 require AnyEvent::TLS;
1560
1561 local $Carp::CarpLevel = 1; # skip ourselves when creating a new context
1562 1748
1563 if ($ctx->{cache}) { 1749 if ($ctx->{cache}) {
1564 my $key = $ctx+0; 1750 my $key = $ctx+0;
1565 $ctx = $TLS_CACHE{$key} ||= new AnyEvent::TLS %$ctx; 1751 $ctx = $TLS_CACHE{$key} ||= new AnyEvent::TLS %$ctx;
1566 } else { 1752 } else {
1567 $ctx = new AnyEvent::TLS %$ctx; 1753 $ctx = new AnyEvent::TLS %$ctx;
1568 } 1754 }
1569 } 1755 }
1570 1756
1571 $self->{tls_ctx} = $ctx || TLS_CTX (); 1757 $self->{tls_ctx} = $ctx || TLS_CTX ();
1572 $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});
1573 1759
1574 # 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)
1575 # but the openssl maintainers basically said: "trust us, it just works". 1761 # but the openssl maintainers basically said: "trust us, it just works".
1576 # (unfortunately, we have to hardcode constants because the abysmally misdesigned 1762 # (unfortunately, we have to hardcode constants because the abysmally misdesigned
1577 # and mismaintained ssleay-module doesn't even offer them). 1763 # and mismaintained ssleay-module doesn't even offer them).
1584 # 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
1585 # have identity issues in that area. 1771 # have identity issues in that area.
1586# Net::SSLeay::CTX_set_mode ($ssl, 1772# Net::SSLeay::CTX_set_mode ($ssl,
1587# (eval { local $SIG{__DIE__}; Net::SSLeay::MODE_ENABLE_PARTIAL_WRITE () } || 1) 1773# (eval { local $SIG{__DIE__}; Net::SSLeay::MODE_ENABLE_PARTIAL_WRITE () } || 1)
1588# | (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));
1589 Net::SSLeay::CTX_set_mode ($ssl, 1|2); 1775 Net::SSLeay::CTX_set_mode ($tls, 1|2);
1590 1776
1591 $self->{_rbio} = Net::SSLeay::BIO_new (Net::SSLeay::BIO_s_mem ()); 1777 $self->{_rbio} = Net::SSLeay::BIO_new (Net::SSLeay::BIO_s_mem ());
1592 $self->{_wbio} = Net::SSLeay::BIO_new (Net::SSLeay::BIO_s_mem ()); 1778 $self->{_wbio} = Net::SSLeay::BIO_new (Net::SSLeay::BIO_s_mem ());
1593 1779
1780 Net::SSLeay::BIO_write ($self->{_rbio}, delete $self->{rbuf});
1781
1594 Net::SSLeay::set_bio ($ssl, $self->{_rbio}, $self->{_wbio}); 1782 Net::SSLeay::set_bio ($tls, $self->{_rbio}, $self->{_wbio});
1595 1783
1596 $self->{_on_starttls} = sub { $_[0]{on_starttls}(@_) } 1784 $self->{_on_starttls} = sub { $_[0]{on_starttls}(@_) }
1597 if $self->{on_starttls}; 1785 if $self->{on_starttls};
1598 1786
1599 &_dotls; # need to trigger the initial handshake 1787 &_dotls; # need to trigger the initial handshake
1602 1790
1603=item $handle->stoptls 1791=item $handle->stoptls
1604 1792
1605Shuts down the SSL connection - this makes a proper EOF handshake by 1793Shuts down the SSL connection - this makes a proper EOF handshake by
1606sending 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
1607support 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
1608afterwards. 1796the stream afterwards.
1609 1797
1610=cut 1798=cut
1611 1799
1612sub stoptls { 1800sub stoptls {
1613 my ($self) = @_; 1801 my ($self) = @_;
1626sub _freetls { 1814sub _freetls {
1627 my ($self) = @_; 1815 my ($self) = @_;
1628 1816
1629 return unless $self->{tls}; 1817 return unless $self->{tls};
1630 1818
1631 $self->{tls_ctx}->_put_session (delete $self->{tls}); 1819 $self->{tls_ctx}->_put_session (delete $self->{tls})
1820 if $self->{tls} > 0;
1632 1821
1633 delete @$self{qw(_rbio _wbio _tls_wbuf _on_starttls)}; 1822 delete @$self{qw(_rbio _wbio _tls_wbuf _on_starttls)};
1634} 1823}
1635 1824
1636sub DESTROY { 1825sub DESTROY {
1638 1827
1639 &_freetls; 1828 &_freetls;
1640 1829
1641 my $linger = exists $self->{linger} ? $self->{linger} : 3600; 1830 my $linger = exists $self->{linger} ? $self->{linger} : 3600;
1642 1831
1643 if ($linger && length $self->{wbuf}) { 1832 if ($linger && length $self->{wbuf} && $self->{fh}) {
1644 my $fh = delete $self->{fh}; 1833 my $fh = delete $self->{fh};
1645 my $wbuf = delete $self->{wbuf}; 1834 my $wbuf = delete $self->{wbuf};
1646 1835
1647 my @linger; 1836 my @linger;
1648 1837
1649 push @linger, AnyEvent->io (fh => $fh, poll => "w", cb => sub { 1838 push @linger, AE::io $fh, 1, sub {
1650 my $len = syswrite $fh, $wbuf, length $wbuf; 1839 my $len = syswrite $fh, $wbuf, length $wbuf;
1651 1840
1652 if ($len > 0) { 1841 if ($len > 0) {
1653 substr $wbuf, 0, $len, ""; 1842 substr $wbuf, 0, $len, "";
1654 } else { 1843 } else {
1655 @linger = (); # end 1844 @linger = (); # end
1656 } 1845 }
1657 }); 1846 };
1658 push @linger, AnyEvent->timer (after => $linger, cb => sub { 1847 push @linger, AE::timer $linger, 0, sub {
1659 @linger = (); 1848 @linger = ();
1660 }); 1849 };
1661 } 1850 }
1662} 1851}
1663 1852
1664=item $handle->destroy 1853=item $handle->destroy
1665 1854
1666Shuts 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
1667no further callbacks will be invoked and as many resources as possible 1856no further callbacks will be invoked and as many resources as possible
1668will 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).
1669 1860
1670Normally, you can just "forget" any references to an AnyEvent::Handle 1861Normally, you can just "forget" any references to an AnyEvent::Handle
1671object 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
1672callbacks, 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
1673callback, so when you want to destroy the AnyEvent::Handle object from 1864callback, so when you want to destroy the AnyEvent::Handle object from
1687sub destroy { 1878sub destroy {
1688 my ($self) = @_; 1879 my ($self) = @_;
1689 1880
1690 $self->DESTROY; 1881 $self->DESTROY;
1691 %$self = (); 1882 %$self = ();
1883 bless $self, "AnyEvent::Handle::destroyed";
1884}
1885
1886sub AnyEvent::Handle::destroyed::AUTOLOAD {
1887 #nop
1692} 1888}
1693 1889
1694=item AnyEvent::Handle::TLS_CTX 1890=item AnyEvent::Handle::TLS_CTX
1695 1891
1696This 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