--- AnyEvent/lib/AnyEvent/Handle.pm 2008/05/29 03:45:37 1.49 +++ AnyEvent/lib/AnyEvent/Handle.pm 2008/06/06 15:33:10 1.67 @@ -16,7 +16,7 @@ =cut -our $VERSION = '1.0'; +our $VERSION = 4.15; =head1 SYNOPSIS @@ -77,35 +77,39 @@ =item on_eof => $cb->($handle) -Set the callback to be called on EOF. +Set the callback to be called when an end-of-file condition is detcted, +i.e. in the case of a socket, when the other side has closed the +connection cleanly. While not mandatory, it is highly recommended to set an eof callback, otherwise you might end up with a closed socket while you are still waiting for data. -=item on_error => $cb->($handle) +=item on_error => $cb->($handle, $fatal) -This is the fatal error callback, that is called when, well, a fatal error -occurs, such as not being able to resolve the hostname, failure to connect -or a read error. - -The object will not be in a usable state when this callback has been -called. +This is the error callback, which is called when, well, some error +occured, such as not being able to resolve the hostname, failure to +connect or a read error. + +Some errors are fatal (which is indicated by C<$fatal> being true). On +fatal errors the handle object will be shut down and will not be +usable. Non-fatal errors can be retried by simply returning, but it is +recommended to simply ignore this parameter and instead abondon the handle +object when this callback is invoked. On callback entrance, the value of C<$!> contains the operating system error (or C, C, C or C). -The callback should throw an exception. If it returns, then -AnyEvent::Handle will C for you. - While not mandatory, it is I recommended to set this callback, as you will not be notified of errors otherwise. The default simply calls -die. +C. =item on_read => $cb->($handle) This sets the default read callback, which is called when data arrives -and no read request is in the queue. +and no read request is in the queue (unlike read queue callbacks, this +callback will only be called when at least one octet of data is in the +read buffer). To access (and remove data from) the read buffer, use the C<< ->rbuf >> method or access the C<$handle->{rbuf}> member directly. @@ -165,6 +169,17 @@ buffer: If the write reaches this size or gets even samller it is considered empty. +=item linger => + +If non-zero (default: C<3600>), then the destructor of the +AnyEvent::Handle object will check wether there is still outstanding write +data and will install a watcher that will write out this data. No errors +will be reported (this mostly matches how the operating system treats +outstanding data at socket close time). + +This will not work for partial TLS data that could not yet been +encoded. This data will be lost. + =item tls => "accept" | "connect" | Net::SSLeay::SSL object When this parameter is given, it enables TLS (SSL) mode, that means it @@ -224,15 +239,13 @@ $self->starttls (delete $self->{tls}, delete $self->{tls_ctx}); } -# $self->on_eof (delete $self->{on_eof} ) if $self->{on_eof}; # nop -# $self->on_error (delete $self->{on_error}) if $self->{on_error}; # nop -# $self->on_read (delete $self->{on_read} ) if $self->{on_read}; # nop - $self->on_drain (delete $self->{on_drain}) if $self->{on_drain}; - $self->{_activity} = AnyEvent->now; $self->_timeout; - $self->start_read; + $self->on_drain (delete $self->{on_drain}) if $self->{on_drain}; + + $self->start_read + if $self->{on_read}; $self } @@ -244,20 +257,23 @@ delete $self->{_rw}; delete $self->{_ww}; delete $self->{fh}; + + $self->stoptls; } -sub error { - my ($self) = @_; +sub _error { + my ($self, $errno, $fatal) = @_; - { - local $!; - $self->_shutdown; - } + $self->_shutdown + if $fatal; - $self->{on_error}($self) - if $self->{on_error}; + $! = $errno; - Carp::croak "AnyEvent::Handle uncaught fatal error: $!"; + if ($self->{on_error}) { + $self->{on_error}($self, $fatal); + } else { + Carp::croak "AnyEvent::Handle uncaught error: $!"; + } } =item $fh = $handle->fh @@ -333,11 +349,10 @@ if ($self->{on_timeout}) { $self->{on_timeout}($self); } else { - $! = Errno::ETIMEDOUT; - $self->error; + $self->_error (&Errno::ETIMEDOUT); } - # callbakx could have changed timeout value, optimise + # callback could have changed timeout value, optimise return unless $self->{timeout}; # calculate new after @@ -345,6 +360,7 @@ } Scalar::Util::weaken $self; + return unless $self; # ->error could have destroyed $self $self->{_tw} ||= AnyEvent->timer (after => $after, cb => sub { delete $self->{_tw}; @@ -417,7 +433,7 @@ delete $self->{_ww} unless length $self->{wbuf}; } elsif ($! != EAGAIN && $! != EINTR && $! != WSAEWOULDBLOCK) { - $self->error; + $self->_error ($!, 1); } }; @@ -456,8 +472,6 @@ =item $handle->push_write (type => @args) -=item $handle->unshift_write (type => @args) - Instead of formatting your data yourself, you can also let this module do the job by specifying a type and type-specific arguments. @@ -471,8 +485,6 @@ Formats the given value as netstring (http://cr.yp.to/proto/netstrings.txt, this is not a recommendation to use them). -=back - =cut register_write_type netstring => sub { @@ -481,6 +493,21 @@ sprintf "%d:%s,", (length $string), $string }; +=item packstring => $format, $data + +An octet string prefixed with an encoded length. The encoding C<$format> +uses the same format as a Perl C format, but must specify a single +integer only (only one of C is allowed, plus an +optional C, C<< < >> or C<< > >> modifier). + +=cut + +register_write_type packstring => sub { + my ($self, $format, $string) = @_; + + pack "$format/a*", $string +}; + =item json => $array_or_hashref Encodes the given hash or array reference into a JSON object. Unless you @@ -522,6 +549,23 @@ : JSON::encode_json ($ref) }; +=item storable => $reference + +Freezes the given reference using L and writes it to the +handle. Uses the C format. + +=cut + +register_write_type storable => sub { + my ($self, $ref) = @_; + + require Storable; + + pack "w/a*", Storable::nfreeze ($ref) +}; + +=back + =item AnyEvent::Handle::register_write_type type => $coderef->($handle, @args) This function (not method) lets you add your own types to C. @@ -556,8 +600,8 @@ In the more complex case, you want to queue multiple callbacks. In this case, AnyEvent::Handle will call the first queued callback each time new -data arrives and removes it when it has done its job (see C, -below). +data arrives (also the first time it is queued) and removes it when it has +done its job (see C, below). This way you can, for example, push three line-reads, followed by reading a chunk of data, and AnyEvent::Handle will execute them in order. @@ -568,12 +612,12 @@ # in the default state, expect some header bytes $handle->on_read (sub { # some data is here, now queue the length-header-read (4 octets) - shift->unshift_read_chunk (4, sub { + shift->unshift_read (chunk => 4, sub { # header arrived, decode my $len = unpack "N", $_[1]; # now read the payload - shift->unshift_read_chunk ($len, sub { + shift->unshift_read (chunk => $len, sub { my $xml = $_[1]; # handle xml }); @@ -590,13 +634,13 @@ $handle->push_write ("request 1\015\012"); # we expect "ERROR" or "OK" as response, so push a line read - $handle->push_read_line (sub { + $handle->push_read (line => sub { # if we got an "OK", we have to _prepend_ another line, # so it will be read before the second request reads its 64 bytes # which are already in the queue when this callback is called # we don't do this in case we got an error if ($_[1] eq "OK") { - $_[0]->unshift_read_line (sub { + $_[0]->unshift_read (line => sub { my $response = $_[1]; ... }); @@ -607,7 +651,7 @@ $handle->push_write ("request 2\015\012"); # simply read 64 bytes, always - $handle->push_read_chunk (64, sub { + $handle->push_read (chunk => 64, sub { my $response = $_[1]; ... }); @@ -619,52 +663,62 @@ sub _drain_rbuf { my ($self) = @_; + local $self->{_in_drain} = 1; + if ( defined $self->{rbuf_max} && $self->{rbuf_max} < length $self->{rbuf} ) { - $! = &Errno::ENOSPC; - $self->error; + return $self->_error (&Errno::ENOSPC, 1); } - return if $self->{in_drain}; - local $self->{in_drain} = 1; - - while (my $len = length $self->{rbuf}) { + while () { no strict 'refs'; + + my $len = length $self->{rbuf}; + if (my $cb = shift @{ $self->{_queue} }) { unless ($cb->($self)) { if ($self->{_eof}) { # no progress can be made (not enough data and no data forthcoming) - $! = &Errno::EPIPE; - $self->error; + $self->_error (&Errno::EPIPE, 1), last; } unshift @{ $self->{_queue} }, $cb; - return; + last; } } elsif ($self->{on_read}) { + last unless $len; + $self->{on_read}($self); if ( - $self->{_eof} # if no further data will arrive - && $len == length $self->{rbuf} # and no data has been consumed - && !@{ $self->{_queue} } # and the queue is still empty - && $self->{on_read} # and we still want to read data + $len == length $self->{rbuf} # if no data has been consumed + && !@{ $self->{_queue} } # and the queue is still empty + && $self->{on_read} # but we still have on_read ) { - # then no progress can be made - $! = &Errno::EPIPE; - $self->error; + # no further data will arrive + # so no progress can be made + $self->_error (&Errno::EPIPE, 1), last + if $self->{_eof}; + + last; # more data might arrive } } else { # read side becomes idle delete $self->{_rw}; - return; + last; } } $self->{on_eof}($self) if $self->{_eof} && $self->{on_eof}; + + # may need to restart read watcher + unless ($self->{_rw}) { + $self->start_read + if $self->{on_read} || @{ $self->{_queue} }; + } } =item $handle->on_read ($cb) @@ -679,6 +733,7 @@ my ($self, $cb) = @_; $self->{on_read} = $cb; + $self->_drain_rbuf if $cb && !$self->{_in_drain}; } =item $handle->rbuf @@ -737,7 +792,7 @@ } push @{ $self->{_queue} }, $cb; - $self->_drain_rbuf; + $self->_drain_rbuf unless $self->{_in_drain}; } sub unshift_read { @@ -753,7 +808,7 @@ unshift @{ $self->{_queue} }, $cb; - $self->_drain_rbuf; + $self->_drain_rbuf unless $self->{_in_drain}; } =item $handle->push_read (type => @args, $cb) @@ -849,44 +904,6 @@ $self->unshift_read (line => @_); } -=item netstring => $cb->($handle, $string) - -A netstring (http://cr.yp.to/proto/netstrings.txt, this is not an endorsement). - -Throws an error with C<$!> set to EBADMSG on format violations. - -=cut - -register_read_type netstring => sub { - my ($self, $cb) = @_; - - sub { - unless ($_[0]{rbuf} =~ s/^(0|[1-9][0-9]*)://) { - if ($_[0]{rbuf} =~ /[^0-9]/) { - $! = &Errno::EBADMSG; - $self->error; - } - return; - } - - my $len = $1; - - $self->unshift_read (chunk => $len, sub { - my $string = $_[1]; - $_[0]->unshift_read (chunk => 1, sub { - if ($_[1] eq ",") { - $cb->($_[0], $string); - } else { - $! = &Errno::EBADMSG; - $self->error; - } - }); - }); - - 1 - } -}; - =item regex => $accept[, $reject[, $skip], $cb->($handle, $data) Makes a regex match against the regex object C<$accept> and returns @@ -945,8 +962,7 @@ # reject if ($reject && $$rbuf =~ $reject) { - $! = &Errno::EBADMSG; - $self->error; + $self->_error (&Errno::EBADMSG); } # skip @@ -958,6 +974,78 @@ } }; +=item netstring => $cb->($handle, $string) + +A netstring (http://cr.yp.to/proto/netstrings.txt, this is not an endorsement). + +Throws an error with C<$!> set to EBADMSG on format violations. + +=cut + +register_read_type netstring => sub { + my ($self, $cb) = @_; + + sub { + unless ($_[0]{rbuf} =~ s/^(0|[1-9][0-9]*)://) { + if ($_[0]{rbuf} =~ /[^0-9]/) { + $self->_error (&Errno::EBADMSG); + } + return; + } + + my $len = $1; + + $self->unshift_read (chunk => $len, sub { + my $string = $_[1]; + $_[0]->unshift_read (chunk => 1, sub { + if ($_[1] eq ",") { + $cb->($_[0], $string); + } else { + $self->_error (&Errno::EBADMSG); + } + }); + }); + + 1 + } +}; + +=item packstring => $format, $cb->($handle, $string) + +An octet string prefixed with an encoded length. The encoding C<$format> +uses the same format as a Perl C format, but must specify a single +integer only (only one of C is allowed, plus an +optional C, C<< < >> or C<< > >> modifier). + +DNS over TCP uses a prefix of C, EPP uses a prefix of C. + +Example: read a block of data prefixed by its length in BER-encoded +format (very efficient). + + $handle->push_read (packstring => "w", sub { + my ($handle, $data) = @_; + }); + +=cut + +register_read_type packstring => sub { + my ($self, $cb, $format) = @_; + + sub { + # when we can use 5.10 we can use ".", but for 5.8 we use the re-pack method + defined (my $len = eval { unpack $format, $_[0]->{rbuf} }) + or return; + + # remove prefix + substr $_[0]->{rbuf}, 0, (length pack $format, $len), ""; + + # read rest + $_[0]->unshift_read (chunk => $len, $cb); + + 1 + } +}; + =item json => $cb->($handle, $hash_or_arrayref) Reads a JSON object or array, decodes it and passes it to the callback. @@ -977,7 +1065,7 @@ =cut register_read_type json => sub { - my ($self, $cb, $accept, $reject, $skip) = @_; + my ($self, $cb) = @_; require JSON; @@ -1002,6 +1090,40 @@ } }; +=item storable => $cb->($handle, $ref) + +Deserialises a L frozen representation as written by the +C write type (BER-encoded length prefix followed by nfreeze'd +data). + +Raises C error if the data could not be decoded. + +=cut + +register_read_type storable => sub { + my ($self, $cb) = @_; + + require Storable; + + sub { + # when we can use 5.10 we can use ".", but for 5.8 we use the re-pack method + defined (my $len = eval { unpack "w", $_[0]->{rbuf} }) + or return; + + # remove prefix + substr $_[0]->{rbuf}, 0, (length pack "w", $len), ""; + + # read rest + $_[0]->unshift_read (chunk => $len, sub { + if (my $ref = eval { Storable::thaw ($_[1]) }) { + $cb->($_[0], $ref); + } else { + $self->_error (&Errno::EBADMSG); + } + }); + } +}; + =back =item AnyEvent::Handle::register_read_type type => $coderef->($handle, $cb, @args) @@ -1029,10 +1151,15 @@ =item $handle->start_read In rare cases you actually do not want to read anything from the -socket. In this case you can call C. Neither C no +socket. In this case you can call C. Neither C nor any queued callbacks will be executed then. To start reading again, call C. +Note that AnyEvent::Handle will automatically C for you when +you change the C callback or push/unshift a read callback, and it +will automatically C for you when neither C is set nor +there are any read requests in the queue. + =cut sub stop_read { @@ -1056,15 +1183,15 @@ $self->{filter_r} ? $self->{filter_r}($self, $rbuf) - : $self->_drain_rbuf; + : $self->{_in_drain} || $self->_drain_rbuf; } elsif (defined $len) { delete $self->{_rw}; $self->{_eof} = 1; - $self->_drain_rbuf; + $self->_drain_rbuf unless $self->{_in_drain}; } elsif ($! != EAGAIN && $! != EINTR && $! != WSAEWOULDBLOCK) { - return $self->error; + return $self->_error ($!, 1); } }); } @@ -1073,30 +1200,38 @@ sub _dotls { my ($self) = @_; + my $buf; + if (length $self->{_tls_wbuf}) { while ((my $len = Net::SSLeay::write ($self->{tls}, $self->{_tls_wbuf})) > 0) { substr $self->{_tls_wbuf}, 0, $len, ""; } } - if (defined (my $buf = Net::SSLeay::BIO_read ($self->{_wbio}))) { + if (length ($buf = Net::SSLeay::BIO_read ($self->{_wbio}))) { $self->{wbuf} .= $buf; $self->_drain_wbuf; } - while (defined (my $buf = Net::SSLeay::read ($self->{tls}))) { - $self->{rbuf} .= $buf; - $self->_drain_rbuf; + while (defined ($buf = Net::SSLeay::read ($self->{tls}))) { + if (length $buf) { + $self->{rbuf} .= $buf; + $self->_drain_rbuf unless $self->{_in_drain}; + } else { + # let's treat SSL-eof as we treat normal EOF + $self->{_eof} = 1; + $self->_shutdown; + return; + } } my $err = Net::SSLeay::get_error ($self->{tls}, -1); if ($err!= Net::SSLeay::ERROR_WANT_READ ()) { if ($err == Net::SSLeay::ERROR_SYSCALL ()) { - $self->error; + return $self->_error ($!, 1); } elsif ($err == Net::SSLeay::ERROR_SSL ()) { - $! = &Errno::EIO; - $self->error; + return $self->_error (&Errno::EIO, 1); } # all others are fine for our purposes @@ -1121,7 +1256,6 @@ =cut -# TODO: maybe document... sub starttls { my ($self, $ssl, $ctx) = @_; @@ -1184,6 +1318,28 @@ my $self = shift; $self->stoptls; + + my $linger = exists $self->{linger} ? $self->{linger} : 3600; + + if ($linger && length $self->{wbuf}) { + my $fh = delete $self->{fh}; + my $wbuf = delete $self->{wbuf}; + + my @linger; + + push @linger, AnyEvent->io (fh => $fh, poll => "w", cb => sub { + my $len = syswrite $fh, $wbuf, length $wbuf; + + if ($len > 0) { + substr $wbuf, 0, $len, ""; + } else { + @linger = (); # end + } + }); + push @linger, AnyEvent->timer (after => $linger, cb => sub { + @linger = (); + }); + } } =item AnyEvent::Handle::TLS_CTX