/usr/local/CPAN/DJabberd/DJabberd/SAXHandler.pm

• package DJabberd::SAXHandler
  • new
  • set_connection
  • cleanup
  • depth
  • start_element
  • characters
  • end_element
  • _nodes_from_events
• EOF

package DJabberd::SAXHandler;
use strict;
use base qw(XML::SAX::Base);
use DJabberd::XMLElement;
use DJabberd::StreamStart;
use Scalar::Util qw(weaken);
use Time::HiRes ();

sub new {
    my ($class, $conn) = @_;
    my $self = $class->SUPER::new;

    if ($conn) {
        $self->{"ds_conn"} = $conn;
        weaken($self->{ds_conn});
    }

    $self->{"capture_depth"} = 0;  # on transition from 1 to 0, stop capturing
    $self->{"on_end_capture"} = undef;  # undef or $subref->($doc)
    $self->{"events"} = [];  # capturing events
    return $self;
}

sub set_connection {
    my ($self, $conn) = @_;
    $self->{ds_conn} = $conn;
    if ($conn) {
        weaken($self->{ds_conn});
    } else {
        # when sax handler is being put back onto the freelist...
        $self->{on_end_capture} = undef;
    }
}

# called when somebody is about to destroy their reference to us, to make
# us clean up.
sub cleanup {
    my $self = shift;
    $self->{on_end_capture} = undef;
}

sub depth {
    return $_[0]{capture_depth};
}

use constant EVT_START_ELEMENT => 1;
use constant EVT_END_ELEMENT   => 2;
use constant EVT_CHARS         => 3;

sub start_element {
    my ($self, $data) = @_;
    my $conn = $self->{ds_conn};

    # {=xml-stream}
    if ($data->{NamespaceURI} eq "http://etherx.jabber.org/streams" &&
        $data->{LocalName} eq "stream") {

        my $ss = DJabberd::StreamStart->new($data);

        # when Connection.pm is prepping a new dummy root node, we legitimately
        # get here without a connection, so we need to test for it:
        $conn->on_stream_start($ss) if $conn;
        return;
    }

    # need a connection past this point.
    return unless $conn;

    # if they're not in a stream yet, bail.
    unless ($conn->{in_stream}) {
        $conn->stream_error('invalid-namespace');
        return;
    }

    if ($self->{capture_depth}) {
        push @{$self->{events}}, [EVT_START_ELEMENT, $data];
        $self->{capture_depth}++;
        return;
    }

    # start capturing...
    $self->{"events"} = [
                         [EVT_START_ELEMENT, $data],
                         ];
    $self->{capture_depth} = 1;

    Scalar::Util::weaken($conn);
    $self->{on_end_capture} = sub {
        my ($doc, $events) = @_;
        my $nodes = _nodes_from_events($events);
        # {=xml-stanza}
        my $t1 = Time::HiRes::time();
        $conn->on_stanza_received($nodes->[0]) if $conn;
        my $td = Time::HiRes::time() - $t1;

        # ring buffers for latency stats:
        if ($td > $DJabberd::Stats::latency_log_threshold) {
            $DJabberd::Stats::stanza_process_latency_log[ $DJabberd::Stats::latency_log_index =
                                                          ($DJabberd::Stats::latency_log_index + 1)
                                                          % $DJabberd::Stats::latency_log_max_size
                                                          ] = [$td, $nodes->[0]->as_xml];
        }

        $DJabberd::Stats::stanza_process_latency[ $DJabberd::Stats::latency_index =
                                                  ($DJabberd::Stats::latency_index + 1)
                                                   % $DJabberd::Stats::latency_max_size
                                                  ] = $td;
    };
    return;
}

sub characters {
    my ($self, $data) = @_;

    if ($self->{capture_depth}) {
        push @{$self->{events}}, [EVT_CHARS, $data];
    }

    # TODO: disconnect client if character data between stanzas?  as
    # long as it's not whitespace, because that's permitted as a
    # keep-alive.

}

sub end_element {
    my ($self, $data) = @_;

    if ($data->{NamespaceURI} eq "http://etherx.jabber.org/streams" &&
        $data->{LocalName} eq "stream") {
        $self->{ds_conn}->end_stream if $self->{ds_conn};
        return;
    }

    if ($self->{capture_depth}) {
        push @{$self->{events}}, [EVT_END_ELEMENT, $data];
        $self->{capture_depth}--;
        return if $self->{capture_depth};
        my $doc = undef;
        if (my $cb = $self->{on_end_capture}) {
            $cb->($doc, $self->{events});
        }
        return;
    }
}

sub _nodes_from_events {
    my ($evlist, $i, $end) = @_;
    $i   ||= 0;
    $end ||= scalar @$evlist;
    my $nodelist = [];    # what we're returning (nodes are text or XMLElement nodes)

    while ($i < $end) {
        my $ev = $evlist->[$i++];

        if ($ev->[0] == EVT_CHARS) {
            my $text = $ev->[1]{Data};
            if (@$nodelist == 0 || ref $nodelist->[-1]) {
                push @$nodelist, $text;
            } else {
                $nodelist->[-1] .= $text;
            }
            next;
        }

        if ($ev->[0] == EVT_START_ELEMENT) {
            my $depth = 1;
            my $start_idx = $i;  # index of first potential body node

            while ($depth && $i < $end) {
                my $child = $evlist->[$i++];

                if ($child->[0] == EVT_START_ELEMENT) {
                    $depth++;
                } elsif ($child->[0] == EVT_END_ELEMENT) {
                    $depth--;
                }
            }
            die "Finished events without reaching depth 0!" if $depth;

            my $end_idx = $i - 1;  # (end - start) == number of child elements

            my $attr_sax = $ev->[1]{Attributes};
            my $attr = {};
            while (my $key = each %$attr_sax) {
                $attr->{$key} = $attr_sax->{$key}{Value};
            }

            push @$nodelist, DJabberd::XMLElement->new($ev->[1]{NamespaceURI},
                                                       $ev->[1]{LocalName},
                                                       $attr,
                                                       _nodes_from_events($evlist, $start_idx, $end_idx),
                                                       undef,
                                                       $ev->[1]{Prefix});
            next;
        }

        die "Unknown event in stream: $ev->[0]\n";
    }
    return $nodelist;
}


1;