[ViewVC] Diff of: cvs/AnyEvent/lib/AnyEvent/Handle.pm

Comparing AnyEvent/lib/AnyEvent/Handle.pm (file contents):
Revision 1.233 by root, Thu Apr 5 06:14:10 2012 UTC vs.
Revision 1.253 by root, Fri Feb 7 15:06:01 2020 UTC

    $cv->recv;
 =head1 DESCRIPTION
-This is a helper module to make it easier to do event-based I/O on
+This is a helper module to make it easier to do event-based I/O
-stream-based filehandles (sockets, pipes, and other stream things).
+on stream-based filehandles (sockets, pipes, and other stream
+things). Specifically, it doesn't work as expected on files, packet-based
+sockets or similar things.
 The L<AnyEvent::Intro> tutorial contains some well-documented
 AnyEvent::Handle examples.
 In the following, where the documentation refers to "bytes", it means
 package AnyEvent::Handle;
 use Scalar::Util ();
 use List::Util ();
 use Carp ();
-use Errno qw(EAGAIN EINTR);
+use Errno qw(EAGAIN EWOULDBLOCK EINTR);
 use AnyEvent (); BEGIN { AnyEvent::common_sense }
 use AnyEvent::Util qw(WSAEWOULDBLOCK);
 our $VERSION = $AnyEvent::VERSION;
 =item fh => $filehandle     [C<fh> or C<connect> MANDATORY]
 The filehandle this L<AnyEvent::Handle> object will operate on.
 NOTE: The filehandle will be set to non-blocking mode (using
-C<AnyEvent::Util::fh_nonblocking>) by the constructor and needs to stay in
+C<AnyEvent::fh_unblock>) by the constructor and needs to stay in
 that mode.
 =item connect => [$host, $service]      [C<fh> or C<connect> MANDATORY]
 Try to connect to the specified host and service (port), using
 The peer's numeric host and port (the socket peername) are passed as
 parameters, together with a retry callback. At the time it is called the
 read and write queues, EOF status, TLS status and similar properties of
 the handle will have been reset.
-It is not allowed to use the read or write queues while the handle object
-is connecting.
 If, for some reason, the handle is not acceptable, calling C<$retry> will
 continue with the next connection target (in case of multi-homed hosts or
 SRV records there can be multiple connection endpoints). The C<$retry>
 callback can be invoked after the connect callback returns, i.e. one can
 appropriate error message.
 TLS mode requires Net::SSLeay to be installed (it will be loaded
 automatically when you try to create a TLS handle): this module doesn't
 have a dependency on that module, so if your module requires it, you have
-to add the dependency yourself.
+to add the dependency yourself. If Net::SSLeay cannot be loaded or is too
+old, you get an C<EPROTO> error.
 Unlike TCP, TLS has a server and client side: for the TLS server side, use
 C<accept>, and for the TLS client side of a connection, use C<connect>
 mode.
 callback.
 This callback will only be called on TLS shutdowns, not when the
 underlying handle signals EOF.
-=item json => JSON or JSON::XS object
+=item json => L<JSON>, L<JSON::PP> or L<JSON::XS> object
 This is the json coder object used by the C<json> read and write types.
 If you don't supply it, then AnyEvent::Handle will create and use a
-suitable one (on demand), which will write and expect UTF-8 encoded JSON
+suitable one (on demand), which will write and expect UTF-8 encoded
+JSON texts (either using L<JSON::XS> or L<JSON>). The written texts are
+guaranteed not to contain any newline character.
+For security reasons, this encoder will likely I<not> handle numbers and
+strings, only arrays and objects/hashes. The reason is that originally
+JSON was self-delimited, but Dougles Crockford thought it was a splendid
+idea to redefine JSON incompatibly, so this is no longer true.
+For protocols that used back-to-back JSON texts, this might lead to
+run-ins, where two or more JSON texts will be interpreted as one JSON
-texts.
+text.
+For this reason, if the default encoder uses L<JSON::XS>, it will default
+to not allowing anything but arrays and objects/hashes, at least for the
+forseeable future (it will change at some point). This might or might not
+be true for the L<JSON> module, so this might cause a security issue.
+If you depend on either behaviour, you should create your own json object
+and pass it in explicitly.
+=item cbor => L<CBOR::XS> object
+This is the cbor coder object used by the C<cbor> read and write types.
+If you don't supply it, then AnyEvent::Handle will create and use a
+suitable one (on demand), which will write CBOR without using extensions,
+if possible.
-Note that you are responsible to depend on the JSON module if you want to
+Note that you are responsible to depend on the L<CBOR::XS> module if you
-use this functionality, as AnyEvent does not have a dependency itself.
+want to use this functionality, as AnyEvent does not have a dependency on
+it itself.
 =back
 =cut
    # with AnyEvent::Handle, do them a favour.
    my $type = getsockopt $self->{fh}, Socket::SOL_SOCKET (), Socket::SO_TYPE ();
    Carp::croak "AnyEvent::Handle: only stream sockets supported, anything else will NOT work!"
       if Socket::SOCK_STREAM () != (unpack "I", $type) && defined $type;
-   AnyEvent::Util::fh_nonblocking $self->{fh}, 1;
+   AnyEvent::fh_unblock $self->{fh};
    $self->{_activity}  =
    $self->{_ractivity} =
    $self->{_wactivity} = AE::now;
    $_[0]{oobinline} = $_[1];
    eval {
       local $SIG{__DIE__};
       setsockopt $_[0]{fh}, Socket::SOL_SOCKET (), Socket::SO_OOBINLINE (), int $_[1]
-         if $_[0]{fh};
-   };
-}
-=item $handle->keepalive ($boolean)
-Enables or disables the C<keepalive> setting (see constructor argument of
-the same name for details).
-=cut
-sub keepalive {
-   $_[0]{keepalive} = $_[1];
-   eval {
-      local $SIG{__DIE__};
-      setsockopt $_[0]{fh}, Socket::SOL_SOCKET (), Socket::SO_KEEPALIVE (), int $_[1]
          if $_[0]{fh};
    };
 }
 =item $handle->on_starttls ($cb)
             $self->{on_drain}($self)
                if $self->{low_water_mark} >= (length $self->{wbuf}) + (length $self->{_tls_wbuf})
                   && $self->{on_drain};
             delete $self->{_ww} unless length $self->{wbuf};
-         } elsif ($! != EAGAIN && $! != EINTR && $! != WSAEWOULDBLOCK) {
+         } elsif ($! != EAGAIN && $! != EINTR && $! != EWOULDBLOCK && $! != WSAEWOULDBLOCK) {
             $self->_error ($!, 1);
          }
       };
       # try to write data immediately
 Encodes the given hash or array reference into a JSON object. Unless you
 provide your own JSON object, this means it will be encoded to JSON text
 in UTF-8.
+The default encoder might or might not handle every type of JSON value -
+it might be limited to arrays and objects for security reasons. See the
+C<json> constructor attribute for more details.
-JSON objects (and arrays) are self-delimiting, so you can write JSON at
+JSON objects (and arrays) are self-delimiting, so if you only use arrays
-one end of a handle and read them at the other end without using any
+and hashes, you can write JSON at one end of a handle and read them at the
-additional framing.
+other end without using any additional framing.
-The generated JSON text is guaranteed not to contain any newlines: While
+The JSON text generated by the default encoder is guaranteed not to
-this module doesn't need delimiters after or between JSON texts to be
+contain any newlines: While this module doesn't need delimiters after or
-able to read them, many other languages depend on that.
+between JSON texts to be able to read them, many other languages depend on
+them.
-A simple RPC protocol that interoperates easily with others is to send
+A simple RPC protocol that interoperates easily with other languages is
-JSON arrays (or objects, although arrays are usually the better choice as
+to send JSON arrays (or objects, although arrays are usually the better
-they mimic how function argument passing works) and a newline after each
+choice as they mimic how function argument passing works) and a newline
-JSON text:
+after each JSON text:
    $handle->push_write (json => ["method", "arg1", "arg2"]); # whatever
    $handle->push_write ("\012");
 An AnyEvent::Handle receiver would simply use the C<json> read type and
    $handle->push_read (json => sub { my $array = $_[1]; ... });
 Other languages could read single lines terminated by a newline and pass
 this line into their JSON decoder of choice.
+=item cbor => $perl_scalar
+Encodes the given scalar into a CBOR value. Unless you provide your own
+L<CBOR::XS> object, this means it will be encoded to a CBOR string not
+using any extensions, if possible.
+CBOR values are self-delimiting, so you can write CBOR at one end of
+a handle and read them at the other end without using any additional
+framing.
+A simple nd very very fast RPC protocol that interoperates with
+other languages is to send CBOR and receive CBOR values (arrays are
+recommended):
+   $handle->push_write (cbor => ["method", "arg1", "arg2"]); # whatever
+An AnyEvent::Handle receiver would simply use the C<cbor> read type:
+   $handle->push_read (cbor => sub { my $array = $_[1]; ... });
 =cut
 sub json_coder() {
    eval { require JSON::XS; JSON::XS->new->utf8 }
-      || do { require JSON; JSON->new->utf8 }
+      || do { require JSON::PP; JSON::PP->new->utf8 }
 }
 register_write_type json => sub {
    my ($self, $ref) = @_;
-   my $json = $self->{json} ||= json_coder;
+   ($self->{json} ||= json_coder)
-   $json->encode ($ref)
+      ->encode ($ref)
+};
+sub cbor_coder() {
+   require CBOR::XS;
+   CBOR::XS->new
+}
+register_write_type cbor => sub {
+   my ($self, $scalar) = @_;
+   ($self->{cbor} ||= cbor_coder)
+      ->encode ($scalar)
 };
 =item storable => $reference
 Freezes the given reference using L<Storable> and writes it to the
 register_read_type line => sub {
    my ($self, $cb, $eol) = @_;
    if (@_ < 3) {
-      # this is more than twice as fast as the generic code below
+      # this is faster then the generic code below
       sub {
-         $_[0]{rbuf} =~ s/^([^\015\012]*)(\015?\012)// or return;
+         (my $pos = index $_[0]{rbuf}, "\012") >= 0
+            or return;
+         (my $str = substr $_[0]{rbuf}, 0, $pos + 1, "") =~ s/(\015?\012)\Z// or die;
-         $cb->($_[0], "$1", "$2");
+         $cb->($_[0], $str, "$1");
          1
       }
    } else {
       $eol = quotemeta $eol unless ref $eol;
       $eol = qr|^(.*?)($eol)|s;
 };
 =item regex => $accept[, $reject[, $skip], $cb->($handle, $data)
 Makes a regex match against the regex object C<$accept> and returns
-everything up to and including the match.
+everything up to and including the match. All the usual regex variables
+($1, %+ etc.) from the regex match are available in the callback.
 Example: read a single line terminated by '\n'.
    $handle->push_read (regex => qr<\n>, sub { ... });
 =item json => $cb->($handle, $hash_or_arrayref)
 Reads a JSON object or array, decodes it and passes it to the
 callback. When a parse error occurs, an C<EBADMSG> error will be raised.
-If a C<json> object was passed to the constructor, then that will be used
+If a C<json> object was passed to the constructor, then that will be
-for the final decode, otherwise it will create a JSON coder expecting UTF-8.
+used for the final decode, otherwise it will create a L<JSON::XS> or
+L<JSON::PP> coder object expecting UTF-8.
 This read type uses the incremental parser available with JSON version
-2.09 (and JSON::XS version 2.2) and above. You have to provide a
+2.09 (and JSON::XS version 2.2) and above.
-dependency on your own: this module will load the JSON module, but
-AnyEvent does not depend on it itself.
 Since JSON texts are fully self-delimiting, the C<json> read and write
 types are an ideal simple RPC protocol: just exchange JSON datagrams. See
 the C<json> write type description, above, for an actual example.
    my ($self, $cb) = @_;
    my $json = $self->{json} ||= json_coder;
    my $data;
-   my $rbuf = \$self->{rbuf};
    sub {
       my $ref = eval { $json->incr_parse ($_[0]{rbuf}) };
       if ($ref) {
          ()
       } else {
          $_[0]{rbuf} = "";
+         ()
+      }
+   }
+};
+=item cbor => $cb->($handle, $scalar)
+Reads a CBOR value, decodes it and passes it to the callback. When a parse
+error occurs, an C<EBADMSG> error will be raised.
+If a L<CBOR::XS> object was passed to the constructor, then that will be
+used for the final decode, otherwise it will create a CBOR coder without
+enabling any options.
+You have to provide a dependency to L<CBOR::XS> on your own: this module
+will load the L<CBOR::XS> module, but AnyEvent does not depend on it
+itself.
+Since CBOR values are fully self-delimiting, the C<cbor> read and write
+types are an ideal simple RPC protocol: just exchange CBOR datagrams. See
+the C<cbor> write type description, above, for an actual example.
+=cut
+register_read_type cbor => sub {
+   my ($self, $cb) = @_;
+   my $cbor = $self->{cbor} ||= cbor_coder;
+   my $data;
+   sub {
+      my (@value) = eval { $cbor->incr_parse ($_[0]{rbuf}) };
+      if (@value) {
+         $cb->($_[0], @value);
+         1
+      } elsif ($@) {
+         # error case
+         $cbor->incr_reset;
+         $_[0]->_error (Errno::EBADMSG);
+         ()
+      } else {
          ()
       }
    }
 };
          });
       }
       1
    }
+};
+=item tls_detect => $cb->($handle, $detect, $major, $minor)
+Checks the input stream for a valid SSL or TLS handshake TLSPaintext
+record without consuming anything. Only SSL version 3 or higher
+is handled, up to the fictituous protocol 4.x (but both SSL3+ and
+SSL2-compatible framing is supported).
+If it detects that the input data is likely TLS, it calls the callback
+with a true value for C<$detect> and the (on-wire) TLS version as second
+and third argument (C<$major> is C<3>, and C<$minor> is 0..4 for SSL
+3.0, TLS 1.0, 1.1, 1.2 and 1.3, respectively).  If it detects the input
+to be definitely not TLS, it calls the callback with a false value for
+C<$detect>.
+The callback could use this information to decide whether or not to start
+TLS negotiation.
+In all cases the data read so far is passed to the following read
+handlers.
+Usually you want to use the C<tls_autostart> read type instead.
+If you want to design a protocol that works in the presence of TLS
+dtection, make sure that any non-TLS data doesn't start with the octet 22
+(ASCII SYN, 16 hex) or 128-255 (i.e. highest bit set). The checks this
+read type does are a bit more strict, but might losen in the future to
+accomodate protocol changes.
+This read type does not rely on L<AnyEvent::TLS> (and thus, not on
+L<Net::SSLeay>).
+=item tls_autostart => [$tls_ctx, ]$tls
+Tries to detect a valid SSL or TLS handshake. If one is detected, it tries
+to start tls by calling C<starttls> with the given arguments.
+In practise, C<$tls> must be C<accept>, or a Net::SSLeay context that has
+been configured to accept, as servers do not normally send a handshake on
+their own and ths cannot be detected in this way.
+See C<tls_detect> above for more details.
+Example: give the client a chance to start TLS before accepting a text
+line.
+   $hdl->push_read (tls_autostart => "accept");
+   $hdl->push_read (line => sub {
+      print "received ", ($_[0]{tls} ? "encrypted" : "cleartext"), " <$_[1]>\n";
+   });
+=cut
+register_read_type tls_detect => sub {
+   my ($self, $cb) = @_;
+   sub {
+      # this regex matches a full or partial tls record
+      if (
+         # ssl3+: type(22=handshake) major(=3) minor(any) length_hi
+         $self->{rbuf} =~ /^(?:\z| \x16 (\z| [\x03\x04] (?:\z| . (?:\z| [\x00-\x40] ))))/xs
+         # ssl2 comapatible: len_hi len_lo type(1) major minor dummy(forlength)
+         or $self->{rbuf} =~ /^(?:\z| [\x80-\xff] (?:\z| . (?:\z| \x01 (\z| [\x03\x04] (?:\z| . (?:\z| . ))))))/xs
+      ) {
+         return if 3 != length $1; # partial match, can't decide yet
+         # full match, valid TLS record
+         my ($major, $minor) = unpack "CC", $1;
+         $cb->($self, "accept", $major, $minor);
+      } else {
+         # mismatch == guaranteed not TLS
+         $cb->($self, undef);
+      }
+      1
+   }
+};
+register_read_type tls_autostart => sub {
+   my ($self, @tls) = @_;
+   $RH{tls_detect}($self, sub {
+      return unless $_[1];
+      $_[0]->starttls (@tls);
+   })
 };
 =back
 =item custom read types - Package::anyevent_read_type $handle, $cb, @args
          } elsif (defined $len) {
             delete $self->{_rw};
             $self->{_eof} = 1;
             $self->_drain_rbuf;
-         } elsif ($! != EAGAIN && $! != EINTR && $! != WSAEWOULDBLOCK) {
+         } elsif ($! != EAGAIN && $! != EINTR && $! != EWOULDBLOCK && $! != WSAEWOULDBLOCK) {
             return $self->_error ($!, 1);
          }
       };
    }
 }
    }
 }
 # poll the write BIO and send the data if applicable
 # also decode read data if possible
-# this is basiclaly our TLS state machine
+# this is basically our TLS state machine
 # more efficient implementations are possible with openssl,
 # but not with the buggy and incomplete Net::SSLeay.
 sub _dotls {
    my ($self) = @_;
    my $tmp;
-   if (length $self->{_tls_wbuf}) {
+   while (length $self->{_tls_wbuf}) {
-      while (($tmp = Net::SSLeay::write ($self->{tls}, $self->{_tls_wbuf})) > 0) {
+      if (($tmp = Net::SSLeay::write ($self->{tls}, $self->{_tls_wbuf})) <= 0) {
-         substr $self->{_tls_wbuf}, 0, $tmp, "";
+         $tmp = Net::SSLeay::get_error ($self->{tls}, $tmp);
+         return $self->_tls_error ($tmp)
+            if $tmp != $ERROR_WANT_READ
+               && ($tmp != $ERROR_SYSCALL || $!);
+         last;
       }
-      $tmp = Net::SSLeay::get_error ($self->{tls}, $tmp);
+      substr $self->{_tls_wbuf}, 0, $tmp, "";
-      return $self->_tls_error ($tmp)
-         if $tmp != $ERROR_WANT_READ
-            && ($tmp != $ERROR_SYSCALL || $!);
    }
    while (defined ($tmp = Net::SSLeay::read ($self->{tls}))) {
       unless (length $tmp) {
          $self->{_on_starttls}
       $self->{_tls_rbuf} .= $tmp;
       $self->_drain_rbuf;
       $self->{tls} or return; # tls session might have gone away in callback
    }
-   $tmp = Net::SSLeay::get_error ($self->{tls}, -1);
+   $tmp = Net::SSLeay::get_error ($self->{tls}, -1); # -1 is not neccessarily correct, but Net::SSLeay doesn't tell us
    return $self->_tls_error ($tmp)
       if $tmp != $ERROR_WANT_READ
          && ($tmp != $ERROR_SYSCALL || $!);
    while (length ($tmp = Net::SSLeay::BIO_read ($self->{_wbio}))) {
 =item $handle->starttls ($tls[, $tls_ctx])
 Instead of starting TLS negotiation immediately when the AnyEvent::Handle
 object is created, you can also do that at a later time by calling
-C<starttls>.
+C<starttls>. See the C<tls> constructor argument for general info.
 Starting TLS is currently an asynchronous operation - when you push some
 write data and then call C<< ->starttls >> then TLS negotiation will start
-immediately, after which the queued write data is then sent.
+immediately, after which the queued write data is then sent. This might
+change in future versions, so best make sure you have no outstanding write
+data when calling this method.
 The first argument is the same as the C<tls> constructor argument (either
 C<"connect">, C<"accept"> or an existing Net::SSLeay object).
 The second argument is the optional C<AnyEvent::TLS> object that is used
    my ($self, $tls, $ctx) = @_;
    Carp::croak "It is an error to call starttls on an AnyEvent::Handle object while TLS is already active, caught"
       if $self->{tls};
+   unless (defined $AnyEvent::TLS::VERSION) {
+      eval {
+         require Net::SSLeay;
+         require AnyEvent::TLS;
+         1
+      } or return $self->_error (Errno::EPROTO, 1, "TLS support not available on this system");
+   }
    $self->{tls}     = $tls;
    $self->{tls_ctx} = $ctx if @_ > 2;
    return unless $self->{fh};
-   require Net::SSLeay;
    $ERROR_SYSCALL   = Net::SSLeay::ERROR_SYSCALL     ();
    $ERROR_WANT_READ = Net::SSLeay::ERROR_WANT_READ   ();
    $tls = delete $self->{tls};
    $ctx = $self->{tls_ctx};
    local $Carp::CarpLevel = 1; # skip ourselves when creating a new context or session
    if ("HASH" eq ref $ctx) {
-      require AnyEvent::TLS;
       if ($ctx->{cache}) {
          my $key = $ctx+0;
          $ctx = $TLS_CACHE{$key} ||= new AnyEvent::TLS %$ctx;
       } else {
          $ctx = new AnyEvent::TLS %$ctx;
    $self->{tls}     = $tls = $self->{tls_ctx}->_get_session ($tls, $self, $self->{peername});
    # 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).
+   # and mismaintained ssleay-module didn't offer them for a decade or so).
    # http://www.mail-archive.com/openssl-dev@openssl.org/msg22420.html
    #
    # in short: this is a mess.
    #
    # note that we do not try to keep the length constant between writes as we are required to do.
    # we assume that most (but not all) of this insanity only applies to non-blocking cases,
    # and we drive openssl fully in blocking mode here. Or maybe we don't - openssl seems to
    # have identity issues in that area.
-#   Net::SSLeay::CTX_set_mode ($ssl,
+#   Net::SSLeay::set_mode ($ssl,
 #      (eval { local $SIG{__DIE__}; Net::SSLeay::MODE_ENABLE_PARTIAL_WRITE () } || 1)
 #      | (eval { local $SIG{__DIE__}; Net::SSLeay::MODE_ACCEPT_MOVING_WRITE_BUFFER () } || 2));
-   Net::SSLeay::CTX_set_mode ($tls, 1|2);
+   Net::SSLeay::set_mode ($tls, 1|2);
    $self->{_rbio} = Net::SSLeay::BIO_new (Net::SSLeay::BIO_s_mem ());
    $self->{_wbio} = Net::SSLeay::BIO_new (Net::SSLeay::BIO_s_mem ());
    Net::SSLeay::BIO_write ($self->{_rbio}, $self->{rbuf});
    return unless $self->{tls};
    $self->{tls_ctx}->_put_session (delete $self->{tls})
       if $self->{tls} > 0;
    delete @$self{qw(_rbio _wbio _tls_wbuf _on_starttls)};
 }
 =item $handle->resettls
       push @linger, AE::io $fh, 1, sub {
          my $len = syswrite $fh, $wbuf, length $wbuf;
          if ($len > 0) {
             substr $wbuf, 0, $len, "";
-         } elsif (defined $len || ($! != EAGAIN && $! != EINTR && $! != WSAEWOULDBLOCK)) {
+         } elsif (defined $len || ($! != EAGAIN && $! != EINTR && $! != EWOULDBLOCK && $! != WSAEWOULDBLOCK)) {
             @linger = (); # end
          }
       };
       push @linger, AE::timer $linger, 0, sub {
          @linger = ();
 handles requests until the server gets some QUIT command, causing it to
 close the connection first (highly desirable for a busy TCP server). A
 client dropping the connection is an error, which means this variant can
 detect an unexpected detection close.
-To handle this case, always make sure you have a on-empty read queue, by
+To handle this case, always make sure you have a non-empty read queue, by
 pushing the "read request start" handler on it:
    # we assume a request starts with a single line
    my @start_request; @start_request = (line => sub {
       my ($hdl, $line) = @_;

Diff Legend

-–
+Removed lines
-+
+Added lines
-<
+Changed lines
->
+Changed lines

Comparing AnyEvent/lib/AnyEvent/Handle.pm (file contents): Revision 1.233 by root, Thu Apr 5 06:14:10 2012 UTC vs. Revision 1.253 by root, Fri Feb 7 15:06:01 2020 UTC

Diff Legend

Comparing AnyEvent/lib/AnyEvent/Handle.pm (file contents):
Revision 1.233 by root, Thu Apr 5 06:14:10 2012 UTC vs.
Revision 1.253 by root, Fri Feb 7 15:06:01 2020 UTC