The Perl Toolchain Summit needs more sponsors. If your company depends on Perl, please support this very important event.
package DJabberd::Bot;
use strict;
use warnings;
use base 'DJabberd::Plugin';
use DJabberd::JID;
use Carp;
use Scalar::Util;
use List::Util qw(first);
use DJabberd::BotContext;

our $logger = DJabberd::Log->get_logger();

sub set_config_nodename {
    my ($self, $nodename) = @_;
    $self->{nodename} = $nodename;
}

sub set_config_resource {
    my ($self, $resource) = @_;
    $self->{resource} = $resource;
}

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

    Carp::confess("Bot needs a nodename") unless $self->{nodename};
    $self->{resource} ||= "bot";
}

sub jid {
    return $_[0]->{jid};
}

sub register {
    my ($self, $vhost) = @_;
    $self->{jid} = DJabberd::JID->new("$self->{nodename}\@" . $vhost->server_name . "/$self->{resource}");

    $self->{vhost} = $vhost;
    Scalar::Util::weaken($self->{vhost});

    my $regcb = DJabberd::Callback->new({
        registered => sub {
            $logger->debug("Bot $self->{jid} is now registered");
        },
        error => sub {
            $logger->error("Bot $self->{jid} failed to register");
            },
    });

    $vhost->register_jid($self->{jid}, $self , $regcb);
    DJabberd::Presence->set_local_presence($self->{jid}, DJabberd::Presence->available(from => $self->{jid}));
}

# no-op bot logic:
sub process_text {
    my ($self, $text, $from, $cb) = @_;
    $cb->done;
}

# TODO: not yet used.
sub context_timeout { 300 }

sub get_context {
    my ($self, $method, $fromjid) = @_;
    # TODO: cache these, and time them out according to $self->context_timeout
    if ($method eq "stanza") {
        return DJabberd::BotContext->new($self->{vhost}, $method, $fromjid, $self->jid);
    }
}


############################################################################
# Connection-like methods, for when we're pretending to be a roster item, and registered
# ourselves with jidmap.  (as opposed to being a component)
############################################################################

sub write {
    # currently don't do anything here
    $logger->warn("Ignoring writes");
}

sub is_available { 1 }

sub requested_roster { 0 }

sub send_stanza {
    my ($self, $stanza) = @_;

    if ($stanza->isa('DJabberd::Message')) {
        my ($text, $html);
        # find the plaintext
        {
            my $body = first { $_->element_name eq "body" } $stanza->children_elements
                or return;
            $text = $body->first_child
                or return;
        }
        # find the HTML text
        if (my $htmlnode = first { $_->element eq "{http://jabber.org/protocol/xhtml-im}html" }
            $stanza->children_elements)
        {
            my $bodynode = $htmlnode->first_element;
            if ($bodynode->element eq "{http://www.w3.org/1999/xhtml}body") {
                $html = $bodynode->innards_as_xml;
            }
        }

        my $ctx = $self->get_context("stanza", $stanza->from_jid);
        $ctx->add_text($text, $html);
        $self->process_text($text, $stanza->from_jid, $ctx);
        return;
    }
}

1;