1package DJabberd::Callback;
2use strict;
3use Carp qw(croak);
4our $AUTOLOAD;
5
6our $logger = DJabberd::Log->get_logger();
7
8sub new {
9    #my ($class, $meths) = @_;
10    # TODO: track where it was defined at, in debug mode?
11    return bless $_[1], $_[0];
12}
13
14sub reset { $_[0]{_has_been_called} = 0; }
15
16#sub DESTROY {
17#    my $self = shift;
18#    DJabberd->track_destroyed_obj($self);
19#}
20
21sub desc {
22    my $self = shift;
23    return $self;  # TODO: change to "Callback defined at Djabberd.pm, line 23423"
24}
25
26sub already_fired {
27    my $self = shift;
28    return $self->{_has_been_called} ? 1 : 0;
29}
30
31sub AUTOLOAD {
32    my $self = shift;
33    my $meth = $AUTOLOAD;
34    $meth =~ s/.+:://;
35
36    # ignore perl-generated methods
37    return unless $meth =~ /[a-z]/;
38
39    # conditional debug statement -- computing this is costly, so only do this
40    # when we are actually running in debug mode --kane
41    if ($logger->is_debug) {
42        # show who (file:linenumber) called which method on the callback
43        # and what it's arguments were
44        my @c = caller;
45        $logger->debug( '$callback->'."$meth( @_ ) has been called from $c[1]:$c[2]" );
46    }
47
48    if ($self->{_has_been_called}++) {
49        warn "Callback called twice.  ignoring.\n";
50        return;
51    }
52
53    if (my $pre = $self->{_pre}) {
54        $pre->($self, $meth, @_) or return;
55    }
56    my $func = $self->{$meth};
57    unless ($func) {
58        my $avail = join(", ", grep { $_ !~ /^_/ } keys %$self);
59        croak("unknown method ($meth) called on " . $self->desc . "; available methods: $avail");
60    }
61    $func->($self, @_);
62
63    # let our creator know we've fired
64    if (my $postfire = $self->{_post_fire}) {
65        $postfire->($meth);
66    }
67}
68
691;
70