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

Comparing AnyEvent/lib/AnyEvent/Handle.pm (file contents):
Revision 1.235 by root, Tue May 8 19:41:22 2012 UTC vs.
Revision 1.245 by root, Tue Jun 16 03:22:20 2015 UTC

 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
 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;
             $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..3 for SSL
+3.0, TLS 1.0, 1.1 and 1.2, 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[, $tls_ctx]
+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_detect => "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 * 0.1);
+      } 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);
          }
       };
    }
 }
 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}))) {
       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 = ();

Diff Legend

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

Comparing AnyEvent/lib/AnyEvent/Handle.pm (file contents): Revision 1.235 by root, Tue May 8 19:41:22 2012 UTC vs. Revision 1.245 by root, Tue Jun 16 03:22:20 2015 UTC

Diff Legend

Comparing AnyEvent/lib/AnyEvent/Handle.pm (file contents):
Revision 1.235 by root, Tue May 8 19:41:22 2012 UTC vs.
Revision 1.245 by root, Tue Jun 16 03:22:20 2015 UTC