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