File Coverage

blib/lib/DJabberd/Stanza.pm

Criterion	Covered	Total	%
statement	12	83	14.4
branch	0	26	0.0
condition	0	9	0.0
subroutine	4	25	16.0
pod	0	18	0.0
total	16	161	9.9

package DJabberd::Stanza;
use strict;
use base qw(DJabberd::XMLElement);
use Carp qw(croak);
use fields (
            'connection',   # Store the connection the stanza came in on so we can respond.
                            # may be undef, as it's a weakref.  if you want to mess with the
                            # structure, you can't do so unless you're the owner, so clone
                            # it first otherwise.
            '_memo_tojid',   # memoized to jid
            '_memo_fromjid', # memoized from jid
            );

sub downbless {
    my $class = shift;
    if (ref $_[0]) {
        my ($self, $conn) = @_;
        my $new = fields::new($class);
        %$new = %$self; # copy fields
        if ($conn) {
            $new->{connection} = $conn;
            Scalar::Util::weaken($new->{connection});
        }
        return $new;
    } else {
        croak("Bogus use of downbless.");
    }

}

sub as_summary {
    my $self = shift;
    return "[Stanza of type " . $self->element_name . " to " . $self->to_jid->as_string . "]";
}

sub on_recv_from_server {
    my ($self, $conn) = @_;
    $self->deliver($conn->vhost);
}

sub process {
    my ($self, $conn) = @_;
    die "$self ->process not implemented\n";
}

sub connection {
    my $self = shift;
    return $self->{connection};
}

sub set_connection {
    my ($self, $conn) = @_;
    $self->{connection} = $conn;
}

# at this point, it's assumed the stanza has passed filtering checks,
# and should be delivered.
sub deliver {
    my ($stanza, $arg) = @_;

    # arg can be a connection, vhost, or nothing.  TODO: kinda ghetto.  fix callers?
    my $vhost;
    if (UNIVERSAL::isa($arg, "DJabberd::VHost")) {
        $vhost = $arg;
    } elsif (UNIVERSAL::isa($arg, "DJabberd::Connection")) {
        $vhost = $arg->vhost;
    } elsif ($stanza->{connection}) {
        $vhost = $stanza->{connection}->vhost;
    }
    Carp::croak("Can't determine vhost delivering: " . $stanza->as_xml) unless $vhost;

    $vhost->hook_chain_fast("deliver",
                            [ $stanza ],
                            {
                               delivered => sub { },
                               # FIXME: in future, this should note deliver was
                               # complete and the next message to this jid should be dequeued and
                               # subsequently delivered.  (in order deliver)
                               error => sub {
                                   my $reason = $_[1];
                                   $stanza->delivery_failure($vhost, $reason);
                               },
                           },
                           sub {
                               $stanza->delivery_failure($vhost);
                           });
}

# by default, stanzas need to and from coming from a server
sub acceptable_from_server {
    my ($self, $conn) = @_;  # where $conn is a serverin connection
    my ($to, $from) = ($self->to_jid, $self->from_jid);
    return 0 unless $to && $from;
    return 0 unless $conn->peer_domain_is_verified($from->domain);
    #return 0 unless $conn->vhost;  FIXME?  yes?
    return 1;
}

sub delivery_failure {
    my ($self, $vh, $reason) = @_;
    #warn "$self has no ->delivery_failure method implemented\n";
}

sub to {
    my DJabberd::Stanza $self = shift;
    return $self->{attrs}{"{}to"};
}

sub from {
    my DJabberd::Stanza $self = shift;
    return $self->{attrs}{"{}from"};
}

sub to_jid {
    my DJabberd::Stanza $self = shift;
    return $self->{_memo_tojid} ||= DJabberd::JID->new($self->{attrs}{"{}to"});
}

sub from_jid {
    my DJabberd::Stanza $self = shift;
    return $self->{_memo_fromjid} ||= DJabberd::JID->new($self->{attrs}{"{}from"});
}

sub set_from {
    #my ($self, $from) = @_;
    my DJabberd::Stanza $self = $_[0];
    $self->{_memo_fromjid} = undef;
    $self->{attrs}{"{}from"} = ref $_[1] ? $_[1]->as_string : $_[1];
}

sub set_to {
    #my ($self, $to) = @_;
    my DJabberd::Stanza $self = $_[0];
    $self->{_memo_tojid} = undef;
    $self->{attrs}{"{}to"} = ref $_[1] ? $_[1]->as_string : $_[1];
}

sub deliver_when_unavailable {
    0;
}

sub make_response {
    my ($self) = @_;

    # Common to all stanzas is a switching of the from/to addresses.
    my $response = $self->clone;
    my $from = $self->from;
    my $to   = $self->to;

    $response->set_to($from);
    $to ? $response->set_from($to) : delete($response->attrs->{"{}from"});

    $response->set_raw("");

    return $response;
}

sub make_error_response {
    my ($self, $code, $type, $error) = @_;

    my $response = $self->clone;
    my $from = $self->from;
    my $to   = $self->to;

    $response->set_to($from);
    $to ? $response->set_from($to) : delete($response->attrs->{"{}from"});

    my $error_elem = new DJabberd::XMLElement(
        "jabber:server",
        "error",
        {
            "{}code" => $code,
            "{}type" => $type,
        },
        [
            ref $error ? $error : new DJabberd::XMLElement("urn:ietf:params:xml:ns:xmpp-stanzas", $error, {}, []),
        ],
    );

    $response->attrs->{"{}type"} = "error";
    $response->push_child($error_elem);

    return $response;
}

1;