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.143 by root, Mon Jul 6 21:02:34 2009 UTC vs.
Revision 1.168 by root, Fri Jul 31 07:34:00 2009 UTC

1package AnyEvent::Handle; 1package AnyEvent::Handle;
2 2
3no warnings;
4use strict qw(subs vars);
5
6use AnyEvent ();
7use AnyEvent::Util qw(WSAEWOULDBLOCK);
8use Scalar::Util (); 3use Scalar::Util ();
9use Carp (); 4use Carp ();
10use Fcntl ();
11use Errno qw(EAGAIN EINTR); 5use Errno qw(EAGAIN EINTR);
12 6
7use AnyEvent (); BEGIN { AnyEvent::common_sense }
8use AnyEvent::Util qw(WSAEWOULDBLOCK);
9
13=head1 NAME 10=head1 NAME
14 11
15AnyEvent::Handle - non-blocking I/O on file handles via AnyEvent 12AnyEvent::Handle - non-blocking I/O on file handles via AnyEvent
16 13
17=cut 14=cut
18 15
19our $VERSION = 4.452; 16our $VERSION = 4.881;
20 17
21=head1 SYNOPSIS 18=head1 SYNOPSIS
22 19
23 use AnyEvent; 20 use AnyEvent;
24 use AnyEvent::Handle; 21 use AnyEvent::Handle;
25 22
26 my $cv = AnyEvent->condvar; 23 my $cv = AnyEvent->condvar;
27 24
28 my $handle = 25 my $hdl; $hdl = new AnyEvent::Handle
29 AnyEvent::Handle->new (
30 fh => \*STDIN, 26 fh => \*STDIN,
31 on_eof => sub { 27 on_error => sub {
28 my ($hdl, $fatal, $msg) = @_;
29 warn "got error $msg\n";
30 $hdl->destroy;
32 $cv->send; 31 $cv->send;
33 },
34 ); 32 );
35 33
36 # send some request line 34 # send some request line
37 $handle->push_write ("getinfo\015\012"); 35 $hdl->push_write ("getinfo\015\012");
38 36
39 # read the response line 37 # read the response line
40 $handle->push_read (line => sub { 38 $hdl->push_read (line => sub {
41 my ($handle, $line) = @_; 39 my ($hdl, $line) = @_;
42 warn "read line <$line>\n"; 40 warn "got line <$line>\n";
43 $cv->send; 41 $cv->send;
44 }); 42 });
45 43
46 $cv->recv; 44 $cv->recv;
47 45
48=head1 DESCRIPTION 46=head1 DESCRIPTION
49 47
50This module is a helper module to make it easier to do event-based I/O on 48This module is a helper module to make it easier to do event-based I/O on
51filehandles. For utility functions for doing non-blocking connects and accepts 49filehandles.
52on sockets see L<AnyEvent::Util>.
53 50
54The L<AnyEvent::Intro> tutorial contains some well-documented 51The L<AnyEvent::Intro> tutorial contains some well-documented
55AnyEvent::Handle examples. 52AnyEvent::Handle examples.
56 53
57In the following, when the documentation refers to of "bytes" then this 54In the following, when the documentation refers to of "bytes" then this
58means characters. As sysread and syswrite are used for all I/O, their 55means characters. As sysread and syswrite are used for all I/O, their
59treatment of characters applies to this module as well. 56treatment of characters applies to this module as well.
60 57
58At the very minimum, you should specify C<fh> or C<connect>, and the
59C<on_error> callback.
60
61All callbacks will be invoked with the handle object as their first 61All callbacks will be invoked with the handle object as their first
62argument. 62argument.
63 63
64=head1 METHODS 64=head1 METHODS
65 65
69 69
70The constructor supports these arguments (all as C<< key => value >> pairs). 70The constructor supports these arguments (all as C<< key => value >> pairs).
71 71
72=over 4 72=over 4
73 73
74=item fh => $filehandle [MANDATORY] 74=item fh => $filehandle [C<fh> or C<connect> MANDATORY]
75 75
76The filehandle this L<AnyEvent::Handle> object will operate on. 76The filehandle this L<AnyEvent::Handle> object will operate on.
77
78NOTE: The filehandle will be set to non-blocking mode (using 77NOTE: The filehandle will be set to non-blocking mode (using
79C<AnyEvent::Util::fh_nonblocking>) by the constructor and needs to stay in 78C<AnyEvent::Util::fh_nonblocking>) by the constructor and needs to stay in
80that mode. 79that mode.
81 80
81=item connect => [$host, $service] [C<fh> or C<connect> MANDATORY]
82
83Try to connect to the specified host and service (port), using
84C<AnyEvent::Socket::tcp_connect>. The C<$host> additionally becomes the
85default C<peername>.
86
87You have to specify either this parameter, or C<fh>, above.
88
89It is possible to push requests on the read and write queues, and modify
90properties of the stream, even while AnyEvent::Handle is connecting.
91
92When this parameter is specified, then the C<on_prepare>,
93C<on_connect_error> and C<on_connect> callbacks will be called under the
94appropriate circumstances:
95
96=over 4
97
98=item on_prepare => $cb->($handle)
99
100This (rarely used) callback is called before a new connection is
101attempted, but after the file handle has been created. It could be used to
102prepare the file handle with parameters required for the actual connect
103(as opposed to settings that can be changed when the connection is already
104established).
105
106The return value of this callback should be the connect timeout value in
107seconds (or C<0>, or C<undef>, or the empty list, to indicate the default
108timeout is to be used).
109
110=item on_connect => $cb->($handle, $host, $port, $retry->())
111
112This callback is called when a connection has been successfully established.
113
114The actual numeric host and port (the socket peername) are passed as
115parameters, together with a retry callback.
116
117When, for some reason, the handle is not acceptable, then calling
118C<$retry> will continue with the next conenction target (in case of
119multi-homed hosts or SRV records there can be multiple connection
120endpoints). When it is called then the read and write queues, eof status,
121tls status and similar properties of the handle are being reset.
122
123In most cases, ignoring the C<$retry> parameter is the way to go.
124
125=item on_connect_error => $cb->($handle, $message)
126
127This callback is called when the conenction could not be
128established. C<$!> will contain the relevant error code, and C<$message> a
129message describing it (usually the same as C<"$!">).
130
131If this callback isn't specified, then C<on_error> will be called with a
132fatal error instead.
133
134=back
135
136=item on_error => $cb->($handle, $fatal, $message)
137
138This is the error callback, which is called when, well, some error
139occured, such as not being able to resolve the hostname, failure to
140connect or a read error.
141
142Some errors are fatal (which is indicated by C<$fatal> being true). On
143fatal errors the handle object will be destroyed (by a call to C<< ->
144destroy >>) after invoking the error callback (which means you are free to
145examine the handle object). Examples of fatal errors are an EOF condition
146with active (but unsatisifable) read watchers (C<EPIPE>) or I/O errors. In
147cases where the other side can close the connection at their will it is
148often easiest to not report C<EPIPE> errors in this callback.
149
150AnyEvent::Handle tries to find an appropriate error code for you to check
151against, but in some cases (TLS errors), this does not work well. It is
152recommended to always output the C<$message> argument in human-readable
153error messages (it's usually the same as C<"$!">).
154
155Non-fatal errors can be retried by simply returning, but it is recommended
156to simply ignore this parameter and instead abondon the handle object
157when this callback is invoked. Examples of non-fatal errors are timeouts
158C<ETIMEDOUT>) or badly-formatted data (C<EBADMSG>).
159
160On callback entrance, the value of C<$!> contains the operating system
161error code (or C<ENOSPC>, C<EPIPE>, C<ETIMEDOUT>, C<EBADMSG> or
162C<EPROTO>).
163
164While not mandatory, it is I<highly> recommended to set this callback, as
165you will not be notified of errors otherwise. The default simply calls
166C<croak>.
167
168=item on_read => $cb->($handle)
169
170This sets the default read callback, which is called when data arrives
171and no read request is in the queue (unlike read queue callbacks, this
172callback will only be called when at least one octet of data is in the
173read buffer).
174
175To access (and remove data from) the read buffer, use the C<< ->rbuf >>
176method or access the C<< $handle->{rbuf} >> member directly. Note that you
177must not enlarge or modify the read buffer, you can only remove data at
178the beginning from it.
179
180When an EOF condition is detected then AnyEvent::Handle will first try to
181feed all the remaining data to the queued callbacks and C<on_read> before
182calling the C<on_eof> callback. If no progress can be made, then a fatal
183error will be raised (with C<$!> set to C<EPIPE>).
184
185Note that, unlike requests in the read queue, an C<on_read> callback
186doesn't mean you I<require> some data: if there is an EOF and there
187are outstanding read requests then an error will be flagged. With an
188C<on_read> callback, the C<on_eof> callback will be invoked.
189
82=item on_eof => $cb->($handle) 190=item on_eof => $cb->($handle)
83 191
84Set the callback to be called when an end-of-file condition is detected, 192Set the callback to be called when an end-of-file condition is detected,
85i.e. in the case of a socket, when the other side has closed the 193i.e. in the case of a socket, when the other side has closed the
86connection cleanly. 194connection cleanly, and there are no outstanding read requests in the
195queue (if there are read requests, then an EOF counts as an unexpected
196connection close and will be flagged as an error).
87 197
88For sockets, this just means that the other side has stopped sending data, 198For sockets, this just means that the other side has stopped sending data,
89you can still try to write data, and, in fact, one can return from the EOF 199you can still try to write data, and, in fact, one can return from the EOF
90callback and continue writing data, as only the read part has been shut 200callback and continue writing data, as only the read part has been shut
91down. 201down.
92 202
93While not mandatory, it is I<highly> recommended to set an EOF callback,
94otherwise you might end up with a closed socket while you are still
95waiting for data.
96
97If an EOF condition has been detected but no C<on_eof> callback has been 203If an EOF condition has been detected but no C<on_eof> callback has been
98set, then a fatal error will be raised with C<$!> set to <0>. 204set, then a fatal error will be raised with C<$!> set to <0>.
99
100=item on_error => $cb->($handle, $fatal, $message)
101
102This is the error callback, which is called when, well, some error
103occured, such as not being able to resolve the hostname, failure to
104connect or a read error.
105
106Some errors are fatal (which is indicated by C<$fatal> being true). On
107fatal errors the handle object will be shut down and will not be usable
108(but you are free to look at the current C<< ->rbuf >>). Examples of fatal
109errors are an EOF condition with active (but unsatisifable) read watchers
110(C<EPIPE>) or I/O errors.
111
112AnyEvent::Handle tries to find an appropriate error code for you to check
113against, but in some cases (TLS errors), this does not work well. It is
114recommended to always output the C<$message> argument in human-readable
115error messages (it's usually the same as C<"$!">).
116
117Non-fatal errors can be retried by simply returning, but it is recommended
118to simply ignore this parameter and instead abondon the handle object
119when this callback is invoked. Examples of non-fatal errors are timeouts
120C<ETIMEDOUT>) or badly-formatted data (C<EBADMSG>).
121
122On callback entrance, the value of C<$!> contains the operating system
123error code (or C<ENOSPC>, C<EPIPE>, C<ETIMEDOUT>, C<EBADMSG> or
124C<EPROTO>).
125
126While not mandatory, it is I<highly> recommended to set this callback, as
127you will not be notified of errors otherwise. The default simply calls
128C<croak>.
129
130=item on_read => $cb->($handle)
131
132This sets the default read callback, which is called when data arrives
133and no read request is in the queue (unlike read queue callbacks, this
134callback will only be called when at least one octet of data is in the
135read buffer).
136
137To access (and remove data from) the read buffer, use the C<< ->rbuf >>
138method or access the C<< $handle->{rbuf} >> member directly. Note that you
139must not enlarge or modify the read buffer, you can only remove data at
140the beginning from it.
141
142When an EOF condition is detected then AnyEvent::Handle will first try to
143feed all the remaining data to the queued callbacks and C<on_read> before
144calling the C<on_eof> callback. If no progress can be made, then a fatal
145error will be raised (with C<$!> set to C<EPIPE>).
146 205
147=item on_drain => $cb->($handle) 206=item on_drain => $cb->($handle)
148 207
149This sets the callback that is called when the write buffer becomes empty 208This sets the callback that is called when the write buffer becomes empty
150(or when the callback is set and the buffer is empty already). 209(or when the callback is set and the buffer is empty already).
249 308
250A string used to identify the remote site - usually the DNS hostname 309A string used to identify the remote site - usually the DNS hostname
251(I<not> IDN!) used to create the connection, rarely the IP address. 310(I<not> IDN!) used to create the connection, rarely the IP address.
252 311
253Apart from being useful in error messages, this string is also used in TLS 312Apart from being useful in error messages, this string is also used in TLS
254peername verification (see C<verify_peername> in L<AnyEvent::TLS>). 313peername verification (see C<verify_peername> in L<AnyEvent::TLS>). This
314verification will be skipped when C<peername> is not specified or
315C<undef>.
255 316
256=item tls => "accept" | "connect" | Net::SSLeay::SSL object 317=item tls => "accept" | "connect" | Net::SSLeay::SSL object
257 318
258When this parameter is given, it enables TLS (SSL) mode, that means 319When this parameter is given, it enables TLS (SSL) mode, that means
259AnyEvent will start a TLS handshake as soon as the conenction has been 320AnyEvent will start a TLS handshake as soon as the conenction has been
347 408
348sub new { 409sub new {
349 my $class = shift; 410 my $class = shift;
350 my $self = bless { @_ }, $class; 411 my $self = bless { @_ }, $class;
351 412
352 $self->{fh} or Carp::croak "mandatory argument fh is missing"; 413 if ($self->{fh}) {
414 $self->_start;
415 return unless $self->{fh}; # could be gone by now
416
417 } elsif ($self->{connect}) {
418 require AnyEvent::Socket;
419
420 $self->{peername} = $self->{connect}[0]
421 unless exists $self->{peername};
422
423 $self->{_skip_drain_rbuf} = 1;
424
425 {
426 Scalar::Util::weaken (my $self = $self);
427
428 $self->{_connect} =
429 AnyEvent::Socket::tcp_connect (
430 $self->{connect}[0],
431 $self->{connect}[1],
432 sub {
433 my ($fh, $host, $port, $retry) = @_;
434
435 if ($fh) {
436 $self->{fh} = $fh;
437
438 delete $self->{_skip_drain_rbuf};
439 $self->_start;
440
441 $self->{on_connect}
442 and $self->{on_connect}($self, $host, $port, sub {
443 delete @$self{qw(fh _tw _ww _rw _eof _queue rbuf _wbuf tls _tls_rbuf _tls_wbuf)};
444 $self->{_skip_drain_rbuf} = 1;
445 &$retry;
446 });
447
448 } else {
449 if ($self->{on_connect_error}) {
450 $self->{on_connect_error}($self, "$!");
451 $self->destroy;
452 } else {
453 $self->_error ($!, 1);
454 }
455 }
456 },
457 sub {
458 local $self->{fh} = $_[0];
459
460 $self->{on_prepare}
461 ? $self->{on_prepare}->($self)
462 : ()
463 }
464 );
465 }
466
467 } else {
468 Carp::croak "AnyEvent::Handle: either an existing fh or the connect parameter must be specified";
469 }
470
471 $self
472}
473
474sub _start {
475 my ($self) = @_;
353 476
354 AnyEvent::Util::fh_nonblocking $self->{fh}, 1; 477 AnyEvent::Util::fh_nonblocking $self->{fh}, 1;
355 478
356 $self->{_activity} = AnyEvent->now; 479 $self->{_activity} = AnyEvent->now;
357 $self->_timeout; 480 $self->_timeout;
362 if $self->{tls}; 485 if $self->{tls};
363 486
364 $self->on_drain (delete $self->{on_drain}) if $self->{on_drain}; 487 $self->on_drain (delete $self->{on_drain}) if $self->{on_drain};
365 488
366 $self->start_read 489 $self->start_read
367 if $self->{on_read}; 490 if $self->{on_read} || @{ $self->{_queue} };
368 491
369 $self->{fh} && $self 492 $self->_drain_wbuf;
370} 493}
371 494
372sub _shutdown { 495#sub _shutdown {
373 my ($self) = @_; 496# my ($self) = @_;
374 497#
375 delete @$self{qw(_tw _rw _ww fh wbuf on_read _queue)}; 498# delete @$self{qw(_tw _rw _ww fh wbuf on_read _queue)};
376 $self->{_eof} = 1; # tell starttls et. al to stop trying 499# $self->{_eof} = 1; # tell starttls et. al to stop trying
377 500#
378 &_freetls; 501# &_freetls;
379} 502#}
380 503
381sub _error { 504sub _error {
382 my ($self, $errno, $fatal, $message) = @_; 505 my ($self, $errno, $fatal, $message) = @_;
383 506
384 $self->_shutdown
385 if $fatal;
386
387 $! = $errno; 507 $! = $errno;
388 $message ||= "$!"; 508 $message ||= "$!";
389 509
390 if ($self->{on_error}) { 510 if ($self->{on_error}) {
391 $self->{on_error}($self, $fatal, $message); 511 $self->{on_error}($self, $fatal, $message);
512 $self->destroy if $fatal;
392 } elsif ($self->{fh}) { 513 } elsif ($self->{fh}) {
514 $self->destroy;
393 Carp::croak "AnyEvent::Handle uncaught error: $message"; 515 Carp::croak "AnyEvent::Handle uncaught error: $message";
394 } 516 }
395} 517}
396 518
397=item $fh = $handle->fh 519=item $fh = $handle->fh
455sub no_delay { 577sub no_delay {
456 $_[0]{no_delay} = $_[1]; 578 $_[0]{no_delay} = $_[1];
457 579
458 eval { 580 eval {
459 local $SIG{__DIE__}; 581 local $SIG{__DIE__};
460 setsockopt $_[0]{fh}, &Socket::IPPROTO_TCP, &Socket::TCP_NODELAY, int $_[1]; 582 setsockopt $_[0]{fh}, &Socket::IPPROTO_TCP, &Socket::TCP_NODELAY, int $_[1]
583 if $_[0]{fh};
461 }; 584 };
462} 585}
463 586
464=item $handle->on_starttls ($cb) 587=item $handle->on_starttls ($cb)
465 588
477 600
478=cut 601=cut
479 602
480sub on_starttls { 603sub on_starttls {
481 $_[0]{on_stoptls} = $_[1]; 604 $_[0]{on_stoptls} = $_[1];
605}
606
607=item $handle->rbuf_max ($max_octets)
608
609Configures the C<rbuf_max> setting (C<undef> disables it).
610
611=cut
612
613sub rbuf_max {
614 $_[0]{rbuf_max} = $_[1];
482} 615}
483 616
484############################################################################# 617#############################################################################
485 618
486=item $handle->timeout ($seconds) 619=item $handle->timeout ($seconds)
499# reset the timeout watcher, as neccessary 632# reset the timeout watcher, as neccessary
500# also check for time-outs 633# also check for time-outs
501sub _timeout { 634sub _timeout {
502 my ($self) = @_; 635 my ($self) = @_;
503 636
504 if ($self->{timeout}) { 637 if ($self->{timeout} && $self->{fh}) {
505 my $NOW = AnyEvent->now; 638 my $NOW = AnyEvent->now;
506 639
507 # when would the timeout trigger? 640 # when would the timeout trigger?
508 my $after = $self->{_activity} + $self->{timeout} - $NOW; 641 my $after = $self->{_activity} + $self->{timeout} - $NOW;
509 642
512 $self->{_activity} = $NOW; 645 $self->{_activity} = $NOW;
513 646
514 if ($self->{on_timeout}) { 647 if ($self->{on_timeout}) {
515 $self->{on_timeout}($self); 648 $self->{on_timeout}($self);
516 } else { 649 } else {
517 $self->_error (&Errno::ETIMEDOUT); 650 $self->_error (Errno::ETIMEDOUT);
518 } 651 }
519 652
520 # callback could have changed timeout value, optimise 653 # callback could have changed timeout value, optimise
521 return unless $self->{timeout}; 654 return unless $self->{timeout};
522 655
585 Scalar::Util::weaken $self; 718 Scalar::Util::weaken $self;
586 719
587 my $cb = sub { 720 my $cb = sub {
588 my $len = syswrite $self->{fh}, $self->{wbuf}; 721 my $len = syswrite $self->{fh}, $self->{wbuf};
589 722
590 if ($len >= 0) { 723 if (defined $len) {
591 substr $self->{wbuf}, 0, $len, ""; 724 substr $self->{wbuf}, 0, $len, "";
592 725
593 $self->{_activity} = AnyEvent->now; 726 $self->{_activity} = AnyEvent->now;
594 727
595 $self->{on_drain}($self) 728 $self->{on_drain}($self)
627 ->($self, @_); 760 ->($self, @_);
628 } 761 }
629 762
630 if ($self->{tls}) { 763 if ($self->{tls}) {
631 $self->{_tls_wbuf} .= $_[0]; 764 $self->{_tls_wbuf} .= $_[0];
632 765 &_dotls ($self) if $self->{fh};
633 &_dotls ($self);
634 } else { 766 } else {
635 $self->{wbuf} .= $_[0]; 767 $self->{wbuf} .= $_[0];
636 $self->_drain_wbuf; 768 $self->_drain_wbuf if $self->{fh};
637 } 769 }
638} 770}
639 771
640=item $handle->push_write (type => @args) 772=item $handle->push_write (type => @args)
641 773
858=cut 990=cut
859 991
860sub _drain_rbuf { 992sub _drain_rbuf {
861 my ($self) = @_; 993 my ($self) = @_;
862 994
995 # avoid recursion
996 return if $self->{_skip_drain_rbuf};
863 local $self->{_in_drain} = 1; 997 local $self->{_skip_drain_rbuf} = 1;
864 998
865 if ( 999 if (
866 defined $self->{rbuf_max} 1000 defined $self->{rbuf_max}
867 && $self->{rbuf_max} < length $self->{rbuf} 1001 && $self->{rbuf_max} < length $self->{rbuf}
868 ) { 1002 ) {
869 $self->_error (&Errno::ENOSPC, 1), return; 1003 $self->_error (Errno::ENOSPC, 1), return;
870 } 1004 }
871 1005
872 while () { 1006 while () {
873 # we need to use a separate tls read buffer, as we must not receive data while 1007 # we need to use a separate tls read buffer, as we must not receive data while
874 # we are draining the buffer, and this can only happen with TLS. 1008 # we are draining the buffer, and this can only happen with TLS.
875 $self->{rbuf} .= delete $self->{_tls_rbuf} if exists $self->{_tls_rbuf}; 1009 $self->{rbuf} .= delete $self->{_tls_rbuf}
1010 if exists $self->{_tls_rbuf};
876 1011
877 my $len = length $self->{rbuf}; 1012 my $len = length $self->{rbuf};
878 1013
879 if (my $cb = shift @{ $self->{_queue} }) { 1014 if (my $cb = shift @{ $self->{_queue} }) {
880 unless ($cb->($self)) { 1015 unless ($cb->($self)) {
881 if ($self->{_eof}) { 1016 # no progress can be made
882 # no progress can be made (not enough data and no data forthcoming) 1017 # (not enough data and no data forthcoming)
883 $self->_error (&Errno::EPIPE, 1), return; 1018 $self->_error (Errno::EPIPE, 1), return
884 } 1019 if $self->{_eof};
885 1020
886 unshift @{ $self->{_queue} }, $cb; 1021 unshift @{ $self->{_queue} }, $cb;
887 last; 1022 last;
888 } 1023 }
889 } elsif ($self->{on_read}) { 1024 } elsif ($self->{on_read}) {
896 && !@{ $self->{_queue} } # and the queue is still empty 1031 && !@{ $self->{_queue} } # and the queue is still empty
897 && $self->{on_read} # but we still have on_read 1032 && $self->{on_read} # but we still have on_read
898 ) { 1033 ) {
899 # no further data will arrive 1034 # no further data will arrive
900 # so no progress can be made 1035 # so no progress can be made
901 $self->_error (&Errno::EPIPE, 1), return 1036 $self->_error (Errno::EPIPE, 1), return
902 if $self->{_eof}; 1037 if $self->{_eof};
903 1038
904 last; # more data might arrive 1039 last; # more data might arrive
905 } 1040 }
906 } else { 1041 } else {
909 last; 1044 last;
910 } 1045 }
911 } 1046 }
912 1047
913 if ($self->{_eof}) { 1048 if ($self->{_eof}) {
914 if ($self->{on_eof}) { 1049 $self->{on_eof}
915 $self->{on_eof}($self) 1050 ? $self->{on_eof}($self)
916 } else {
917 $self->_error (0, 1, "Unexpected end-of-file"); 1051 : $self->_error (0, 1, "Unexpected end-of-file");
918 } 1052
1053 return;
919 } 1054 }
920 1055
921 # may need to restart read watcher 1056 # may need to restart read watcher
922 unless ($self->{_rw}) { 1057 unless ($self->{_rw}) {
923 $self->start_read 1058 $self->start_read
935 1070
936sub on_read { 1071sub on_read {
937 my ($self, $cb) = @_; 1072 my ($self, $cb) = @_;
938 1073
939 $self->{on_read} = $cb; 1074 $self->{on_read} = $cb;
940 $self->_drain_rbuf if $cb && !$self->{_in_drain}; 1075 $self->_drain_rbuf if $cb;
941} 1076}
942 1077
943=item $handle->rbuf 1078=item $handle->rbuf
944 1079
945Returns the read buffer (as a modifiable lvalue). 1080Returns the read buffer (as a modifiable lvalue).
997 $cb = ($RH{$type} or Carp::croak "unsupported type passed to AnyEvent::Handle::push_read") 1132 $cb = ($RH{$type} or Carp::croak "unsupported type passed to AnyEvent::Handle::push_read")
998 ->($self, $cb, @_); 1133 ->($self, $cb, @_);
999 } 1134 }
1000 1135
1001 push @{ $self->{_queue} }, $cb; 1136 push @{ $self->{_queue} }, $cb;
1002 $self->_drain_rbuf unless $self->{_in_drain}; 1137 $self->_drain_rbuf;
1003} 1138}
1004 1139
1005sub unshift_read { 1140sub unshift_read {
1006 my $self = shift; 1141 my $self = shift;
1007 my $cb = pop; 1142 my $cb = pop;
1013 ->($self, $cb, @_); 1148 ->($self, $cb, @_);
1014 } 1149 }
1015 1150
1016 1151
1017 unshift @{ $self->{_queue} }, $cb; 1152 unshift @{ $self->{_queue} }, $cb;
1018 $self->_drain_rbuf unless $self->{_in_drain}; 1153 $self->_drain_rbuf;
1019} 1154}
1020 1155
1021=item $handle->push_read (type => @args, $cb) 1156=item $handle->push_read (type => @args, $cb)
1022 1157
1023=item $handle->unshift_read (type => @args, $cb) 1158=item $handle->unshift_read (type => @args, $cb)
1156 return 1; 1291 return 1;
1157 } 1292 }
1158 1293
1159 # reject 1294 # reject
1160 if ($reject && $$rbuf =~ $reject) { 1295 if ($reject && $$rbuf =~ $reject) {
1161 $self->_error (&Errno::EBADMSG); 1296 $self->_error (Errno::EBADMSG);
1162 } 1297 }
1163 1298
1164 # skip 1299 # skip
1165 if ($skip && $$rbuf =~ $skip) { 1300 if ($skip && $$rbuf =~ $skip) {
1166 $data .= substr $$rbuf, 0, $+[0], ""; 1301 $data .= substr $$rbuf, 0, $+[0], "";
1182 my ($self, $cb) = @_; 1317 my ($self, $cb) = @_;
1183 1318
1184 sub { 1319 sub {
1185 unless ($_[0]{rbuf} =~ s/^(0|[1-9][0-9]*)://) { 1320 unless ($_[0]{rbuf} =~ s/^(0|[1-9][0-9]*)://) {
1186 if ($_[0]{rbuf} =~ /[^0-9]/) { 1321 if ($_[0]{rbuf} =~ /[^0-9]/) {
1187 $self->_error (&Errno::EBADMSG); 1322 $self->_error (Errno::EBADMSG);
1188 } 1323 }
1189 return; 1324 return;
1190 } 1325 }
1191 1326
1192 my $len = $1; 1327 my $len = $1;
1195 my $string = $_[1]; 1330 my $string = $_[1];
1196 $_[0]->unshift_read (chunk => 1, sub { 1331 $_[0]->unshift_read (chunk => 1, sub {
1197 if ($_[1] eq ",") { 1332 if ($_[1] eq ",") {
1198 $cb->($_[0], $string); 1333 $cb->($_[0], $string);
1199 } else { 1334 } else {
1200 $self->_error (&Errno::EBADMSG); 1335 $self->_error (Errno::EBADMSG);
1201 } 1336 }
1202 }); 1337 });
1203 }); 1338 });
1204 1339
1205 1 1340 1
1295 $json->incr_skip; 1430 $json->incr_skip;
1296 1431
1297 $self->{rbuf} = $json->incr_text; 1432 $self->{rbuf} = $json->incr_text;
1298 $json->incr_text = ""; 1433 $json->incr_text = "";
1299 1434
1300 $self->_error (&Errno::EBADMSG); 1435 $self->_error (Errno::EBADMSG);
1301 1436
1302 () 1437 ()
1303 } else { 1438 } else {
1304 $self->{rbuf} = ""; 1439 $self->{rbuf} = "";
1305 1440
1342 # read remaining chunk 1477 # read remaining chunk
1343 $_[0]->unshift_read (chunk => $len, sub { 1478 $_[0]->unshift_read (chunk => $len, sub {
1344 if (my $ref = eval { Storable::thaw ($_[1]) }) { 1479 if (my $ref = eval { Storable::thaw ($_[1]) }) {
1345 $cb->($_[0], $ref); 1480 $cb->($_[0], $ref);
1346 } else { 1481 } else {
1347 $self->_error (&Errno::EBADMSG); 1482 $self->_error (Errno::EBADMSG);
1348 } 1483 }
1349 }); 1484 });
1350 } 1485 }
1351 1486
1352 1 1487 1
1416 if ($self->{tls}) { 1551 if ($self->{tls}) {
1417 Net::SSLeay::BIO_write ($self->{_rbio}, $$rbuf); 1552 Net::SSLeay::BIO_write ($self->{_rbio}, $$rbuf);
1418 1553
1419 &_dotls ($self); 1554 &_dotls ($self);
1420 } else { 1555 } else {
1421 $self->_drain_rbuf unless $self->{_in_drain}; 1556 $self->_drain_rbuf;
1422 } 1557 }
1423 1558
1424 } elsif (defined $len) { 1559 } elsif (defined $len) {
1425 delete $self->{_rw}; 1560 delete $self->{_rw};
1426 $self->{_eof} = 1; 1561 $self->{_eof} = 1;
1427 $self->_drain_rbuf unless $self->{_in_drain}; 1562 $self->_drain_rbuf;
1428 1563
1429 } elsif ($! != EAGAIN && $! != EINTR && $! != WSAEWOULDBLOCK) { 1564 } elsif ($! != EAGAIN && $! != EINTR && $! != WSAEWOULDBLOCK) {
1430 return $self->_error ($!, 1); 1565 return $self->_error ($!, 1);
1431 } 1566 }
1432 }); 1567 });
1450 if ($self->{_on_starttls}) { 1585 if ($self->{_on_starttls}) {
1451 (delete $self->{_on_starttls})->($self, undef, $err); 1586 (delete $self->{_on_starttls})->($self, undef, $err);
1452 &_freetls; 1587 &_freetls;
1453 } else { 1588 } else {
1454 &_freetls; 1589 &_freetls;
1455 $self->_error (&Errno::EPROTO, 1, $err); 1590 $self->_error (Errno::EPROTO, 1, $err);
1456 } 1591 }
1457} 1592}
1458 1593
1459# poll the write BIO and send the data if applicable 1594# poll the write BIO and send the data if applicable
1460# also decode read data if possible 1595# also decode read data if possible
1492 $self->{_eof} = 1; 1627 $self->{_eof} = 1;
1493 } 1628 }
1494 } 1629 }
1495 1630
1496 $self->{_tls_rbuf} .= $tmp; 1631 $self->{_tls_rbuf} .= $tmp;
1497 $self->_drain_rbuf unless $self->{_in_drain}; 1632 $self->_drain_rbuf;
1498 $self->{tls} or return; # tls session might have gone away in callback 1633 $self->{tls} or return; # tls session might have gone away in callback
1499 } 1634 }
1500 1635
1501 $tmp = Net::SSLeay::get_error ($self->{tls}, -1); 1636 $tmp = Net::SSLeay::get_error ($self->{tls}, -1);
1502 return $self->_tls_error ($tmp) 1637 return $self->_tls_error ($tmp)
1517 1652
1518Instead of starting TLS negotiation immediately when the AnyEvent::Handle 1653Instead of starting TLS negotiation immediately when the AnyEvent::Handle
1519object is created, you can also do that at a later time by calling 1654object is created, you can also do that at a later time by calling
1520C<starttls>. 1655C<starttls>.
1521 1656
1657Starting TLS is currently an asynchronous operation - when you push some
1658write data and then call C<< ->starttls >> then TLS negotiation will start
1659immediately, after which the queued write data is then sent.
1660
1522The first argument is the same as the C<tls> constructor argument (either 1661The first argument is the same as the C<tls> constructor argument (either
1523C<"connect">, C<"accept"> or an existing Net::SSLeay object). 1662C<"connect">, C<"accept"> or an existing Net::SSLeay object).
1524 1663
1525The second argument is the optional C<AnyEvent::TLS> object that is used 1664The second argument is the optional C<AnyEvent::TLS> object that is used
1526when AnyEvent::Handle has to create its own TLS connection object, or 1665when AnyEvent::Handle has to create its own TLS connection object, or
1530The TLS connection object will end up in C<< $handle->{tls} >>, the TLS 1669The TLS connection object will end up in C<< $handle->{tls} >>, the TLS
1531context in C<< $handle->{tls_ctx} >> after this call and can be used or 1670context in C<< $handle->{tls_ctx} >> after this call and can be used or
1532changed to your liking. Note that the handshake might have already started 1671changed to your liking. Note that the handshake might have already started
1533when this function returns. 1672when this function returns.
1534 1673
1535If it an error to start a TLS handshake more than once per 1674Due to bugs in OpenSSL, it might or might not be possible to do multiple
1536AnyEvent::Handle object (this is due to bugs in OpenSSL). 1675handshakes on the same stream. Best do not attempt to use the stream after
1676stopping TLS.
1537 1677
1538=cut 1678=cut
1539 1679
1540our %TLS_CACHE; #TODO not yet documented, should we? 1680our %TLS_CACHE; #TODO not yet documented, should we?
1541 1681
1542sub starttls { 1682sub starttls {
1543 my ($self, $ssl, $ctx) = @_; 1683 my ($self, $tls, $ctx) = @_;
1684
1685 Carp::croak "It is an error to call starttls on an AnyEvent::Handle object while TLS is already active, caught"
1686 if $self->{tls};
1687
1688 $self->{tls} = $tls;
1689 $self->{tls_ctx} = $ctx if @_ > 2;
1690
1691 return unless $self->{fh};
1544 1692
1545 require Net::SSLeay; 1693 require Net::SSLeay;
1546
1547 Carp::croak "it is an error to call starttls more than once on an AnyEvent::Handle object"
1548 if $self->{tls};
1549 1694
1550 $ERROR_SYSCALL = Net::SSLeay::ERROR_SYSCALL (); 1695 $ERROR_SYSCALL = Net::SSLeay::ERROR_SYSCALL ();
1551 $ERROR_WANT_READ = Net::SSLeay::ERROR_WANT_READ (); 1696 $ERROR_WANT_READ = Net::SSLeay::ERROR_WANT_READ ();
1552 1697
1698 $tls = $self->{tls};
1553 $ctx ||= $self->{tls_ctx}; 1699 $ctx = $self->{tls_ctx};
1700
1701 local $Carp::CarpLevel = 1; # skip ourselves when creating a new context or session
1554 1702
1555 if ("HASH" eq ref $ctx) { 1703 if ("HASH" eq ref $ctx) {
1556 require AnyEvent::TLS; 1704 require AnyEvent::TLS;
1557
1558 local $Carp::CarpLevel = 1; # skip ourselves when creating a new context
1559 1705
1560 if ($ctx->{cache}) { 1706 if ($ctx->{cache}) {
1561 my $key = $ctx+0; 1707 my $key = $ctx+0;
1562 $ctx = $TLS_CACHE{$key} ||= new AnyEvent::TLS %$ctx; 1708 $ctx = $TLS_CACHE{$key} ||= new AnyEvent::TLS %$ctx;
1563 } else { 1709 } else {
1564 $ctx = new AnyEvent::TLS %$ctx; 1710 $ctx = new AnyEvent::TLS %$ctx;
1565 } 1711 }
1566 } 1712 }
1567 1713
1568 $self->{tls_ctx} = $ctx || TLS_CTX (); 1714 $self->{tls_ctx} = $ctx || TLS_CTX ();
1569 $self->{tls} = $ssl = $self->{tls_ctx}->_get_session ($ssl, $self, $self->{peername}); 1715 $self->{tls} = $tls = $self->{tls_ctx}->_get_session ($tls, $self, $self->{peername});
1570 1716
1571 # basically, this is deep magic (because SSL_read should have the same issues) 1717 # basically, this is deep magic (because SSL_read should have the same issues)
1572 # but the openssl maintainers basically said: "trust us, it just works". 1718 # but the openssl maintainers basically said: "trust us, it just works".
1573 # (unfortunately, we have to hardcode constants because the abysmally misdesigned 1719 # (unfortunately, we have to hardcode constants because the abysmally misdesigned
1574 # and mismaintained ssleay-module doesn't even offer them). 1720 # and mismaintained ssleay-module doesn't even offer them).
1581 # and we drive openssl fully in blocking mode here. Or maybe we don't - openssl seems to 1727 # and we drive openssl fully in blocking mode here. Or maybe we don't - openssl seems to
1582 # have identity issues in that area. 1728 # have identity issues in that area.
1583# Net::SSLeay::CTX_set_mode ($ssl, 1729# Net::SSLeay::CTX_set_mode ($ssl,
1584# (eval { local $SIG{__DIE__}; Net::SSLeay::MODE_ENABLE_PARTIAL_WRITE () } || 1) 1730# (eval { local $SIG{__DIE__}; Net::SSLeay::MODE_ENABLE_PARTIAL_WRITE () } || 1)
1585# | (eval { local $SIG{__DIE__}; Net::SSLeay::MODE_ACCEPT_MOVING_WRITE_BUFFER () } || 2)); 1731# | (eval { local $SIG{__DIE__}; Net::SSLeay::MODE_ACCEPT_MOVING_WRITE_BUFFER () } || 2));
1586 Net::SSLeay::CTX_set_mode ($ssl, 1|2); 1732 Net::SSLeay::CTX_set_mode ($tls, 1|2);
1587 1733
1588 $self->{_rbio} = Net::SSLeay::BIO_new (Net::SSLeay::BIO_s_mem ()); 1734 $self->{_rbio} = Net::SSLeay::BIO_new (Net::SSLeay::BIO_s_mem ());
1589 $self->{_wbio} = Net::SSLeay::BIO_new (Net::SSLeay::BIO_s_mem ()); 1735 $self->{_wbio} = Net::SSLeay::BIO_new (Net::SSLeay::BIO_s_mem ());
1590 1736
1591 Net::SSLeay::set_bio ($ssl, $self->{_rbio}, $self->{_wbio}); 1737 Net::SSLeay::set_bio ($tls, $self->{_rbio}, $self->{_wbio});
1592 1738
1593 $self->{_on_starttls} = sub { $_[0]{on_starttls}(@_) } 1739 $self->{_on_starttls} = sub { $_[0]{on_starttls}(@_) }
1594 if $self->{on_starttls}; 1740 if $self->{on_starttls};
1595 1741
1596 &_dotls; # need to trigger the initial handshake 1742 &_dotls; # need to trigger the initial handshake
1599 1745
1600=item $handle->stoptls 1746=item $handle->stoptls
1601 1747
1602Shuts down the SSL connection - this makes a proper EOF handshake by 1748Shuts down the SSL connection - this makes a proper EOF handshake by
1603sending a close notify to the other side, but since OpenSSL doesn't 1749sending a close notify to the other side, but since OpenSSL doesn't
1604support non-blocking shut downs, it is not possible to re-use the stream 1750support non-blocking shut downs, it is not guarenteed that you can re-use
1605afterwards. 1751the stream afterwards.
1606 1752
1607=cut 1753=cut
1608 1754
1609sub stoptls { 1755sub stoptls {
1610 my ($self) = @_; 1756 my ($self) = @_;
1623sub _freetls { 1769sub _freetls {
1624 my ($self) = @_; 1770 my ($self) = @_;
1625 1771
1626 return unless $self->{tls}; 1772 return unless $self->{tls};
1627 1773
1628 $self->{tls_ctx}->_put_session (delete $self->{tls}); 1774 $self->{tls_ctx}->_put_session (delete $self->{tls})
1775 if ref $self->{tls};
1629 1776
1630 delete @$self{qw(_rbio _wbio _tls_wbuf _on_starttls)}; 1777 delete @$self{qw(_rbio _wbio _tls_wbuf _on_starttls)};
1631} 1778}
1632 1779
1633sub DESTROY { 1780sub DESTROY {
1635 1782
1636 &_freetls; 1783 &_freetls;
1637 1784
1638 my $linger = exists $self->{linger} ? $self->{linger} : 3600; 1785 my $linger = exists $self->{linger} ? $self->{linger} : 3600;
1639 1786
1640 if ($linger && length $self->{wbuf}) { 1787 if ($linger && length $self->{wbuf} && $self->{fh}) {
1641 my $fh = delete $self->{fh}; 1788 my $fh = delete $self->{fh};
1642 my $wbuf = delete $self->{wbuf}; 1789 my $wbuf = delete $self->{wbuf};
1643 1790
1644 my @linger; 1791 my @linger;
1645 1792
1660 1807
1661=item $handle->destroy 1808=item $handle->destroy
1662 1809
1663Shuts down the handle object as much as possible - this call ensures that 1810Shuts down the handle object as much as possible - this call ensures that
1664no further callbacks will be invoked and as many resources as possible 1811no further callbacks will be invoked and as many resources as possible
1665will be freed. You must not call any methods on the object afterwards. 1812will be freed. Any method you will call on the handle object after
1813destroying it in this way will be silently ignored (and it will return the
1814empty list).
1666 1815
1667Normally, you can just "forget" any references to an AnyEvent::Handle 1816Normally, you can just "forget" any references to an AnyEvent::Handle
1668object and it will simply shut down. This works in fatal error and EOF 1817object and it will simply shut down. This works in fatal error and EOF
1669callbacks, as well as code outside. It does I<NOT> work in a read or write 1818callbacks, as well as code outside. It does I<NOT> work in a read or write
1670callback, so when you want to destroy the AnyEvent::Handle object from 1819callback, so when you want to destroy the AnyEvent::Handle object from
1671within such an callback. You I<MUST> call C<< ->destroy >> explicitly in 1820within such an callback. You I<MUST> call C<< ->destroy >> explicitly in
1672that case. 1821that case.
1673 1822
1823Destroying the handle object in this way has the advantage that callbacks
1824will be removed as well, so if those are the only reference holders (as
1825is common), then one doesn't need to do anything special to break any
1826reference cycles.
1827
1674The handle might still linger in the background and write out remaining 1828The handle might still linger in the background and write out remaining
1675data, as specified by the C<linger> option, however. 1829data, as specified by the C<linger> option, however.
1676 1830
1677=cut 1831=cut
1678 1832
1679sub destroy { 1833sub destroy {
1680 my ($self) = @_; 1834 my ($self) = @_;
1681 1835
1682 $self->DESTROY; 1836 $self->DESTROY;
1683 %$self = (); 1837 %$self = ();
1838 bless $self, "AnyEvent::Handle::destroyed";
1839}
1840
1841sub AnyEvent::Handle::destroyed::AUTOLOAD {
1842 #nop
1684} 1843}
1685 1844
1686=item AnyEvent::Handle::TLS_CTX 1845=item AnyEvent::Handle::TLS_CTX
1687 1846
1688This function creates and returns the AnyEvent::TLS object used by default 1847This function creates and returns the AnyEvent::TLS object used by default
1745 1904
1746 $handle->on_read (sub { }); 1905 $handle->on_read (sub { });
1747 $handle->on_eof (undef); 1906 $handle->on_eof (undef);
1748 $handle->on_error (sub { 1907 $handle->on_error (sub {
1749 my $data = delete $_[0]{rbuf}; 1908 my $data = delete $_[0]{rbuf};
1750 undef $handle;
1751 }); 1909 });
1752 1910
1753The reason to use C<on_error> is that TCP connections, due to latencies 1911The reason to use C<on_error> is that TCP connections, due to latencies
1754and packets loss, might get closed quite violently with an error, when in 1912and packets loss, might get closed quite violently with an error, when in
1755fact, all data has been received. 1913fact, all data has been received.
1780 1938
1781If your TLS server is a pure TLS server (e.g. HTTPS) that only speaks TLS, 1939If your TLS server is a pure TLS server (e.g. HTTPS) that only speaks TLS,
1782simply connect to it and then create the AnyEvent::Handle with the C<tls> 1940simply connect to it and then create the AnyEvent::Handle with the C<tls>
1783parameter: 1941parameter:
1784 1942
1943 tcp_connect $host, $port, sub {
1944 my ($fh) = @_;
1945
1785 my $handle = new AnyEvent::Handle 1946 my $handle = new AnyEvent::Handle
1786 fh => $fh, 1947 fh => $fh,
1787 tls => "connect", 1948 tls => "connect",
1788 on_error => sub { ... }; 1949 on_error => sub { ... };
1789 1950
1790 $handle->push_write (...); 1951 $handle->push_write (...);
1952 };
1791 1953
1792=item I want to contact a TLS/SSL server, I do care about security. 1954=item I want to contact a TLS/SSL server, I do care about security.
1793 1955
1794Then you #x##TODO# 1956Then you should additionally enable certificate verification, including
1957peername verification, if the protocol you use supports it (see
1958L<AnyEvent::TLS>, C<verify_peername>).
1795 1959
1796 1960E.g. for HTTPS:
1961
1962 tcp_connect $host, $port, sub {
1963 my ($fh) = @_;
1964
1965 my $handle = new AnyEvent::Handle
1966 fh => $fh,
1967 peername => $host,
1968 tls => "connect",
1969 tls_ctx => { verify => 1, verify_peername => "https" },
1970 ...
1971
1972Note that you must specify the hostname you connected to (or whatever
1973"peername" the protocol needs) as the C<peername> argument, otherwise no
1974peername verification will be done.
1975
1976The above will use the system-dependent default set of trusted CA
1977certificates. If you want to check against a specific CA, add the
1978C<ca_file> (or C<ca_cert>) arguments to C<tls_ctx>:
1979
1980 tls_ctx => {
1981 verify => 1,
1982 verify_peername => "https",
1983 ca_file => "my-ca-cert.pem",
1984 },
1985
1986=item I want to create a TLS/SSL server, how do I do that?
1987
1988Well, you first need to get a server certificate and key. You have
1989three options: a) ask a CA (buy one, use cacert.org etc.) b) create a
1990self-signed certificate (cheap. check the search engine of your choice,
1991there are many tutorials on the net) or c) make your own CA (tinyca2 is a
1992nice program for that purpose).
1993
1994Then create a file with your private key (in PEM format, see
1995L<AnyEvent::TLS>), followed by the certificate (also in PEM format). The
1996file should then look like this:
1997
1998 -----BEGIN RSA PRIVATE KEY-----
1999 ...header data
2000 ... lots of base64'y-stuff
2001 -----END RSA PRIVATE KEY-----
2002
2003 -----BEGIN CERTIFICATE-----
2004 ... lots of base64'y-stuff
2005 -----END CERTIFICATE-----
2006
2007The important bits are the "PRIVATE KEY" and "CERTIFICATE" parts. Then
2008specify this file as C<cert_file>:
2009
2010 tcp_server undef, $port, sub {
2011 my ($fh) = @_;
2012
2013 my $handle = new AnyEvent::Handle
2014 fh => $fh,
2015 tls => "accept",
2016 tls_ctx => { cert_file => "my-server-keycert.pem" },
2017 ...
2018
2019When you have intermediate CA certificates that your clients might not
2020know about, just append them to the C<cert_file>.
1797 2021
1798=back 2022=back
1799 2023
1800 2024
1801=head1 SUBCLASSING AnyEvent::Handle 2025=head1 SUBCLASSING AnyEvent::Handle

Diff Legend

Removed lines
+ Added lines
< Changed lines
> Changed lines