--- AnyEvent/lib/AnyEvent/Handle.pm 2008/05/02 16:07:46 1.9 +++ AnyEvent/lib/AnyEvent/Handle.pm 2008/05/24 15:03:42 1.21 @@ -14,9 +14,11 @@ AnyEvent::Handle - non-blocking I/O on filehandles via AnyEvent +This module is experimental. + =cut -our $VERSION = '0.02'; +our $VERSION = '0.04'; =head1 SYNOPSIS @@ -45,8 +47,8 @@ =head1 DESCRIPTION This module is a helper module to make it easier to do event-based I/O on -filehandles (and sockets, see L for an easy way to make -non-blocking resolves and connects). +filehandles. For utility functions for doing non-blocking connects and accepts +on sockets see L. In the following, when the documentation refers to of "bytes" then this means characters. As sysread and syswrite are used for all I/O, their @@ -72,31 +74,37 @@ NOTE: The filehandle will be set to non-blocking (using AnyEvent::Util::fh_nonblocking). -=item on_error => $cb->($self) [MANDATORY] +=item on_eof => $cb->($self) + +Set the callback to be called on EOF. -This is the fatal error callback, that is called when a fatal error ocurs, -such as not being able to resolve the hostname, failure to connect or a -read error. +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->($self) + +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. -On callback entrance, the value of C<$!> contains the opertaing system +On callback entrance, the value of C<$!> contains the operating system error (or C or C). -=item on_eof => $cb->($self) [MANDATORY] - -Set the callback to be called on EOF. +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. =item on_read => $cb->($self) This sets the default read callback, which is called when data arrives -and no read request is in the queue. If the read callback is C -or has never been set, than AnyEvent::Handle will cease reading from the -filehandle. +and no read request is in the queue. To access (and remove data from) the read buffer, use the C<< ->rbuf >> -method or acces sthe C<$self->{rbuf}> member directly. +method or access the C<$self->{rbuf}> member directly. When an EOF condition is detected then AnyEvent::Handle will first try to feed all the remaining data to the queued callbacks and C before @@ -133,6 +141,26 @@ buffer: If the write reaches this size or gets even samller it is considered empty. +=item tls => "accept" | "connect" | Net::SSLeay::SSL object + +When this parameter is given, it enables TLS (SSL) mode, that means it +will start making tls handshake and will transparently encrypt/decrypt +data. + +For the TLS server side, use C, and for the TLS client side of a +connection, use C mode. + +You can also provide your own TLS connection object, but you have +to make sure that you call either C +or C on it before you pass it to +AnyEvent::Handle. + +=item tls_ctx => $ssl_ctx + +Use the given Net::SSLeay::CTX object to create the new TLS connection +(unless a connection object was specified directly). If this parameter is +missing, then AnyEvent::Handle will use C. + =back =cut @@ -146,12 +174,18 @@ AnyEvent::Util::fh_nonblocking $self->{fh}, 1; - $self->on_error ((delete $self->{on_error}) or Carp::croak "mandatory argument on_error is missing"); - $self->on_eof ((delete $self->{on_eof} ) or Carp::croak "mandatory argument on_eof is missing"); + if ($self->{tls}) { + require Net::SSLeay; + $self->starttls (delete $self->{tls}, delete $self->{tls_ctx}); + } + $self->on_eof (delete $self->{on_eof} ) if $self->{on_eof}; + $self->on_error (delete $self->{on_error}) if $self->{on_error}; $self->on_drain (delete $self->{on_drain}) if $self->{on_drain}; $self->on_read (delete $self->{on_read} ) if $self->{on_read}; + $self->start_read; + $self } @@ -171,7 +205,11 @@ $self->_shutdown; } - $self->{on_error}($self); + if ($self->{on_error}) { + $self->{on_error}($self); + } else { + die "AnyEvent::Handle uncaught fatal error: $!"; + } } =item $fh = $handle->fh @@ -214,7 +252,7 @@ The write queue is very simple: you can add data to its end, and AnyEvent::Handle will automatically try to get rid of it for you. -When data could be writtena nd the write buffer is shorter then the low +When data could be written and the write buffer is shorter then the low water mark, the C callback will be invoked. =over 4 @@ -243,10 +281,8 @@ =cut -sub push_write { - my ($self, $data) = @_; - - $self->{wbuf} .= $data; +sub _drain_wbuf { + my ($self) = @_; unless ($self->{ww}) { Scalar::Util::weaken $self; @@ -256,7 +292,6 @@ if ($len > 0) { substr $self->{wbuf}, 0, $len, ""; - $self->{on_drain}($self) if $self->{low_water_mark} >= length $self->{wbuf} && $self->{on_drain}; @@ -273,6 +308,17 @@ }; } +sub push_write { + my $self = shift; + + if ($self->{filter_w}) { + $self->{filter_w}->($self, \$_[0]); + } else { + $self->{wbuf} .= $_[0]; + $self->_drain_wbuf; + } +} + ############################################################################# =back @@ -351,21 +397,31 @@ =over 4 +=cut + sub _drain_rbuf { my ($self) = @_; - return if exists $self->{in_drain}; + if ( + defined $self->{rbuf_max} + && $self->{rbuf_max} < length $self->{rbuf} + ) { + $! = &Errno::ENOSPC; return $self->error; + } + + return if $self->{in_drain}; local $self->{in_drain} = 1; while (my $len = length $self->{rbuf}) { no strict 'refs'; - if (@{ $self->{queue} }) { - if ($self->{queue}[0]($self)) { - shift @{ $self->{queue} }; - } elsif ($self->{eof}) { - # no progress can be made (not enough data and no data forthcoming) - $! = &Errno::EPIPE; return $self->error; - } else { + if (my $cb = shift @{ $self->{queue} }) { + if (!$cb->($self)) { + if ($self->{eof}) { + # no progress can be made (not enough data and no data forthcoming) + $! = &Errno::EPIPE; return $self->error; + } + + unshift @{ $self->{queue} }, $cb; return; } } elsif ($self->{on_read}) { @@ -389,7 +445,8 @@ if ($self->{eof}) { $self->_shutdown; - $self->{on_eof}($self); + $self->{on_eof}($self) + if $self->{on_eof}; } } @@ -405,31 +462,6 @@ my ($self, $cb) = @_; $self->{on_read} = $cb; - - unless ($self->{rw} || $self->{eof}) { - Scalar::Util::weaken $self; - - $self->{rw} = AnyEvent->io (fh => $self->{fh}, poll => "r", cb => sub { - my $len = sysread $self->{fh}, $self->{rbuf}, $self->{read_size} || 8192, length $self->{rbuf}; - - if ($len > 0) { - if (exists $self->{rbuf_max}) { - if ($self->{rbuf_max} < length $self->{rbuf}) { - $! = &Errno::ENOSPC; return $self->error; - } - } - - } elsif (defined $len) { - $self->{eof} = 1; - delete $self->{rw}; - - } elsif ($! != EAGAIN && $! != EINTR) { - return $self->error; - } - - $self->_drain_rbuf; - }); - } } =item $handle->rbuf @@ -458,7 +490,7 @@ The callback is called each time some additional read data arrives. -It must check wether enough data is in the read buffer already. +It must check whether enough data is in the read buffer already. If not enough data is available, it must return the empty list or a false value, in which case it will be called repeatedly until enough data is @@ -497,7 +529,7 @@ =cut sub _read_chunk($$) { - my ($len, $cb) = @_; + my ($self, $len, $cb) = @_; sub { $len <= length $_[0]{rbuf} or return; @@ -507,16 +539,12 @@ } sub push_read_chunk { - my ($self, $len, $cb) = @_; - - $self->push_read (_read_chunk $len, $cb); + $_[0]->push_read (&_read_chunk); } sub unshift_read_chunk { - my ($self, $len, $cb) = @_; - - $self->unshift_read (_read_chunk $len, $cb); + $_[0]->unshift_read (&_read_chunk); } =item $handle->push_read_line ([$eol, ]$cb->($self, $line, $eol)) @@ -546,31 +574,181 @@ =cut sub _read_line($$) { + my $self = shift; my $cb = pop; my $eol = @_ ? shift : qr|(\015?\012)|; my $pos; - $eol = qr|(\Q$eol\E)| unless ref $eol; - $eol = qr|^(.*?)($eol)|; + $eol = quotemeta $eol unless ref $eol; + $eol = qr|^(.*?)($eol)|s; sub { $_[0]{rbuf} =~ s/$eol// or return; - $cb->($1, $2); + $cb->($_[0], $1, $2); 1 } } sub push_read_line { - my $self = shift; - - $self->push_read (&_read_line); + $_[0]->push_read (&_read_line); } sub unshift_read_line { + $_[0]->unshift_read (&_read_line); +} + +=item $handle->stop_read + +=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 +any queued callbacks will be executed then. To start readign again, call +C. + +=cut + +sub stop_read { + my ($self) = @_; + + delete $self->{rw}; +} + +sub start_read { + my ($self) = @_; + + unless ($self->{rw} || $self->{eof}) { + Scalar::Util::weaken $self; + + $self->{rw} = AnyEvent->io (fh => $self->{fh}, poll => "r", cb => sub { + my $rbuf = $self->{filter_r} ? \my $buf : \$self->{rbuf}; + my $len = sysread $self->{fh}, $$rbuf, $self->{read_size} || 8192, length $$rbuf; + + if ($len > 0) { + $self->{filter_r} + ? $self->{filter_r}->($self, $rbuf) + : $self->_drain_rbuf; + + } elsif (defined $len) { + delete $self->{rw}; + $self->{eof} = 1; + $self->_drain_rbuf; + + } elsif ($! != EAGAIN && $! != EINTR) { + return $self->error; + } + }); + } +} + +sub _dotls { + my ($self) = @_; + + if (length $self->{tls_wbuf}) { + my $len = Net::SSLeay::write ($self->{tls}, $self->{tls_wbuf}); + substr $self->{tls_wbuf}, 0, $len, "" if $len > 0; + } + + if (defined (my $buf = Net::SSLeay::BIO_read ($self->{tls_wbio}))) { + $self->{wbuf} .= $buf; + $self->_drain_wbuf; + } + + if (defined (my $buf = Net::SSLeay::read ($self->{tls}))) { + $self->{rbuf} .= $buf; + $self->_drain_rbuf; + } elsif ( + (my $err = Net::SSLeay::get_error ($self->{tls}, -1)) + != Net::SSLeay::ERROR_WANT_READ () + ) { + if ($err == Net::SSLeay::ERROR_SYSCALL ()) { + $self->error; + } elsif ($err == Net::SSLeay::ERROR_SSL ()) { + $! = &Errno::EIO; + $self->error; + } + + # all others are fine for our purposes + } +} + +# TODO: maybe document... +sub starttls { + my ($self, $ssl, $ctx) = @_; + + if ($ssl eq "accept") { + $ssl = Net::SSLeay::new ($ctx || TLS_CTX ()); + Net::SSLeay::set_accept_state ($ssl); + } elsif ($ssl eq "connect") { + $ssl = Net::SSLeay::new ($ctx || TLS_CTX ()); + Net::SSLeay::set_connect_state ($ssl); + } + + $self->{tls} = $ssl; + + # basically, this is deep magic (because SSL_read should have the same issues) + # but the openssl maintainers basically said: "trust us, it just works". + # (unfortunately, we have to hardcode constants because the abysmally misdesigned + # and mismaintained ssleay-module doesn't even offer them). + Net::SSLeay::CTX_set_mode ($self->{tls}, + (eval { Net::SSLeay::MODE_ENABLE_PARTIAL_WRITE () } || 1) + | (eval { Net::SSLeay::MODE_ACCEPT_MOVING_WRITE_BUFFER () } || 2)); + + $self->{tls_rbio} = Net::SSLeay::BIO_new (Net::SSLeay::BIO_s_mem ()); + $self->{tls_wbio} = Net::SSLeay::BIO_new (Net::SSLeay::BIO_s_mem ()); + + Net::SSLeay::set_bio ($ssl, $self->{tls_rbio}, $self->{tls_wbio}); + + $self->{filter_w} = sub { + $_[0]{tls_wbuf} .= ${$_[1]}; + &_dotls; + }; + $self->{filter_r} = sub { + Net::SSLeay::BIO_write ($_[0]{tls_rbio}, ${$_[1]}); + &_dotls; + }; +} + +sub DESTROY { my $self = shift; - $self->unshift_read (&_read_line); + Net::SSLeay::free (delete $self->{tls}) if $self->{tls}; +} + +=item AnyEvent::Handle::TLS_CTX + +This function creates and returns the Net::SSLeay::CTX object used by +default for TLS mode. + +The context is created like this: + + Net::SSLeay::load_error_strings; + Net::SSLeay::SSLeay_add_ssl_algorithms; + Net::SSLeay::randomize; + + my $CTX = Net::SSLeay::CTX_new; + + Net::SSLeay::CTX_set_options $CTX, Net::SSLeay::OP_ALL + +=cut + +our $TLS_CTX; + +sub TLS_CTX() { + $TLS_CTX || do { + require Net::SSLeay; + + Net::SSLeay::load_error_strings (); + Net::SSLeay::SSLeay_add_ssl_algorithms (); + Net::SSLeay::randomize (); + + $TLS_CTX = Net::SSLeay::CTX_new (); + + Net::SSLeay::CTX_set_options ($TLS_CTX, Net::SSLeay::OP_ALL ()); + + $TLS_CTX + } } =back