File Coverage

blib/lib/Net/Analysis/Dispatcher.pm

Criterion	Covered	Total	%
statement	61	66	92.4
branch	13	18	72.2
condition	1	2	50.0
subroutine	12	12	100.0
pod	3	4	75.0
total	90	102	88.2

package Net::Analysis::Dispatcher;
# $Id: Dispatcher.pm 131 2005-10-02 17:24:31Z abworrall $

use 5.008000;
our $VERSION = '0.01';
use strict;
use warnings;
use overload q("") => sub { $_[0]->as_string() }; # OO style stringify
use Carp qw(carp croak);

use Params::Validate qw(:all);

# {{{ POD

=head1 NAME

Net::Analysis::Dispatcher - handle the event stuff for the proto analysers

=head1 SYNOPSIS

  use Net::Analysis::Dispatcher;

  my $d = Net::Analysis::Dispatcher->new();
  my $listener = Net::Analysis::Listener::TCP->new();
  $d->add_listener (listener => $listener);

=head1 DESCRIPTION

This class is used to register listener objects. Whenever any of the objects
emit an event, the dispatcher is used to make sure other interested listeners
receive the event.

=cut

# }}}

# {{{ new

# {{{ POD

=head2 new ()

Takes no arguments, tells no lies.

=cut

# }}}

sub new {
    my ($class) = shift;

    my %h;

    $h{listeners} = []; # List of objects that are listening to events

    my ($self) = bless (\%h, $class);

    return $self;
}

# }}}

# {{{ add_listener

=head2 add_listener (listener => $obj, config => $hash)

This method adds a new listener to the list of things to be notified of each
event.

If the listener object has a field C, then we attempt to put the listener
in that position in the event queue. Valid values are C and C, to
receive events first and last. Listener::TCP likes to be first, since it adds
extra info to the C that other modules might like to see.

If a listener has already claimed the first or last spot, then we croak with an
error.

=cut

sub add_listener {
    my ($self) = shift;

    my %h = validate (@_, { listener => 1, #{ can => "emit" }, <-- broken :(
                            config   => { default => {} },
                          });

    # XXXX workaround issue where Params::Validate rejects mocked methods
    if (!$h{listener}->can('emit')) {
        carp "add_listener needs an object that can ->emit() !\n";
        return undef;
    }

    if (exists $h{listener}{pos}) {
        if ($h{listener}{pos} !~ /^(first|last)$/) {
            croak "$h{listener} has invalid pos; $h{listener}{pos}\n";
        }
        if (exists $self->{pos}{$h{listener}{pos}}) {
            croak "position '$h{listener}{pos}' taken; bad $h{listener}\n";
        }
        $self->{pos}{$h{listener}{pos}} = $h{listener};

    } else {
        push (@{$self->{listeners}}, $h{listener});
    }
}

# }}}
# {{{ emit_event

=head2 emit_event (name => 'event_name', args => $hash)

The name must be a valid Perl function name. By convention, it should start
with the name of the module that is emitting the event (e.g.
C).

Where your code is emitting events, it must must document the args in detail,
so that listeners will know what to do with them.

This method runs through the listener list, and if appropriate, invokes the
listening method for each listener.

A listener gets the event if it has a method which has the same name as the
C.

=cut

sub emit_event {
    my $self = shift;

    my %h = @_;
    $h{args} ||= {};

    if ($self->{_i_am_invoking}) {
#        warn "Argh, circular mayhem ($h{name})\n"; exit;
    }

## Adverse performance impacts, so commented out
#    my %h = validate (@_, { name => { regex => qr/^[a-z][a-z0-9_]+$/ },
#                            args => { default => {} },
#                          });

    # If we have any listeners that wanted a special place in the queue, then
    #  give it to them. This stuff will only trigger on the very first event.
    if (exists $self->{pos}{first}) {
        unshift (@{$self->{listeners}}, delete ($self->{pos}{first}));
    }
    if (exists $self->{pos}{last}) {
        push (@{$self->{listeners}}, delete ($self->{pos}{last}));
    }

    $self->_invoke_callbacks (\%h);
}

# }}}

# {{{ as_string

sub as_string {
    my ($self) = @_;
    my $s = '';

    $s .= "Dispatching to [".join(',', map {"$_"} @{$self->{listeners}})."]";

    return $s;
}

# }}}

# {{{ _invoke_callbacks

sub _invoke_callbacks {
    my $self = shift;
    my ($h) = @_;

    $self->{_i_am_invoking} = 1;

    # Memoise this iteration & 'can' call ? Results won't change !
    foreach my $l (@{$self->{listeners}}) {
        my $method = $h->{name};
        if ($l->can($method)) {
            eval {
                $l->$method($h->{args});
            }; if ($@) {
                carp ("Listener '$l' die()d on method $h->{name}:\n$@");
            }
        }
    }

    delete ($self->{_i_am_invoking});
}

# }}}


1;
__END__