view release on metacpan or  search on metacpan

lib/DJabberd/Connection.pm  view on Meta::CPAN

    # our previous write wants us to become readable first.
    # we then go back into the write path (by flushing the write
    # buffer) and it then does a read on this socket.
    if (my $ar = $self->{write_when_readable}) {
        $self->{write_when_readable} = 0;
        $self->watch_read($ar->[0]);  # restore previous readability state
        $self->watch_write(1);
        return;
    }

    my $bref;
    if (my $ssl = $self->{ssl}) {
        my $data = Net::SSLeay::read($ssl);

        my $errs = Net::SSLeay::print_errs('SSL_read');
        if ($errs) {
            warn "SSL Read error: $errs\n";
            $self->close;
            return;
        }

        # Net::SSLeays buffers internally, so if we didn't read anything, it's
        # in its buffer
        unless ($data && length $data) {
            # a few of these in a row implies an EOF.  else it could
            # just be the underlying socket was readable, but there
            # wasn't enough of an SSL packet for OpenSSL/etc to return
            # any unencrypted data back to us.
            # We call 'actual_error_on_empty_read' to avoid counting
            # SSL_ERROR_WANT_READ or SSL_ERROR_WANT_WRITE as 'actual' errors
            my $err = DJabberd::Stanza::StartTLS->actual_error_on_empty_read($ssl);
            if ($err) {
                $self->log->warn("SSL Read error: $err (assuming ssl_eof)");
                $self->close('ssl_eof');
            }
            return;
        }
        $bref = \$data;
    } else {
        # non-ssl mode:
        $bref = $self->read(20_000);
    }

    return $self->close unless defined $bref;

    # clients send whitespace between stanzas as keep-alives.  let's just ignore those,
    # not going through the bother to checkout a parser and all.
    return if ! $self->{parser} && $$bref !~ /\S/;

    Carp::confess if ($self->{closed});

    if (XMLDEBUG) {
        my $time = Time::HiRes::time;
        $LOGMAP{$self}->print("$time\t< $$bref\n");
    }

    my $p = $self->{parser} || $self->borrow_a_parser;
    my $len = length $$bref;
    #$self->log->debug("$self->{id} parsing $len bytes...") unless $len == 1;

    # remove invalid low unicode code points which aren't allowed in XML,
    # but both iChat and gaim have been observed to send in the wild, often
    # when copy/pasting from bizarre sources.  this probably isn't compliant,
    # and there's a speed hit, so only regexp them out in quirks mode:
    if ($self->{vhost} && $self->{vhost}{quirksmode}) {
        $$bref =~ s/&\#([\da-f]{0,8});/DJabberd::Util::numeric_entity_clean($1)/ieg;
    }

    eval {
        $p->parse_chunk_scalarref($bref);
    };

    if ($@) {
        # FIXME: give them stream error before closing them,
        # wait until they get the stream error written to them before closing
        $self->discard_parser;
        $self->log->error("$self->{id} disconnected $self because: $@");
        $self->log->warn("$self->{id} parsing *****\n$$bref\n*******\n\n\n");
        $self->close;
        return;
    }

    # if we still have a handler and haven't already closed down (cleanly),
    # then let's consider giving our xml parser/sax pair back, if we're at
    # a good breaking point.
    if ((my $handler = $self->handler) && ! $self->{closed}) {
        my $depth = $handler->depth;
        if ($depth == 0 && $$bref =~ m!>\s*$!) {
            # if no errors and not inside a stanza, return our parser to save memory
            $self->return_parser;
        }
    }
}

sub on_stream_start {
    my DJabberd::Connection $self = shift;
    my $ss = shift;

    die "on_stream_start not defined for $self";
}

# when we're the client of a stream (we're talking first)
sub start_init_stream {
    my DJabberd::Connection  $self = shift;
    my %opts = @_;
    my $extra_attr = delete $opts{'extra_attr'} || "";
    my $to         = delete $opts{'to'} || Carp::croak("need 'to' domain");
    my $xmlns      = delete $opts{'xmlns'} || "jabber:server";
    die if %opts;

    # {=init-version-is-max} -- we must announce the highest version we support
    my $our_version = $self->server->spec_version;
    my $ver_attr    = $our_version->as_attr_string;

    # by default we send the optional to='' attribute in our stream, but we have support for
    # disabling it for our test suite.
    $to = "to='$to'";
    $to = "" if $DJabberd::_T_NO_TO_IN_DIALBACKVERIFY_STREAM;

    # {=xml-lang}
    my $xml = qq{<?xml version="1.0" encoding="UTF-8"?><stream:stream $to xmlns:stream='http://etherx.jabber.org/streams' xmlns='}.exml($xmlns).qq{' xml:lang='en' $extra_attr $ver_attr>};