The Perl Toolchain Summit needs more sponsors. If your company depends on Perl, please support this very important event.
package DJabberd::PresenceChecker;
# abstract base class
use strict;
use warnings;
use base 'DJabberd::Plugin';

sub new {
    my ($class) = @_;
    return bless {}, $class;
}

sub vhost { $_[0]->{vhost} }

sub register {
    my ($self, $vhost) = @_;

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

    # this is an odd hook, in that it wants to be called a lot, but the
    # normal hook chain system doesn't support that, so instead
    # this provides a cleaner interface for subclasses, which just call
    # 'add' and 'done', and this takes care of the ugliness of calling
    # the $add_cb callback.
    $vhost->register_hook("PresenceCheck", sub {
        my (undef, $cb, $jid, $add_cb) = @_;
        # cb can 'decline' only

        my $cb2 = DJabberd::Callback->new({
            done     => sub { $cb->decline },
            decline  => sub { $cb->decline },
            declined => sub { $cb->decline },
        });

        $self->check_presence($cb2, $jid, $add_cb);

    });
}

# override this.
sub check_presence {
    my ($self, $cb, $jid, $add_cb) = @_;
    # cb can only '->done/decline'
    $cb->done;
}

1;