File Coverage

blib/lib/Class/Publisher.pm

Criterion	Covered	Total	%
statement	121	147	82.3
branch	51	70	72.8
condition	32	56	57.1
subroutine	16	21	76.1
pod	7	9	77.7
total	227	303	74.9

# $Id: Publisher.pm,v 1.3 2005/03/25 13:20:21 simonflack Exp $
package Class::Publisher;
use strict;
use Carp;
use Class::ISA;
use Scalar::Util qw/blessed reftype weaken/;
use vars '$VERSION';

$VERSION = '0.2';
my (%S, %P) = ();


# Add one or more subscribers (class name, object or subroutine) to a
# subscribed item (class or object). Return new number of subscribers.
sub add_subscriber {
    my ($item, $event, $subscriber, $use_method) = @_;
    $event = '*' unless defined $event && length $event;
    croak "Invalid subscriber - $subscriber, expected a coderef, object or class name"
        unless _valid_subscriber($subscriber);

    my $subscriber_list = $S {$item} {$event} ||= {};
    weaken($subscriber) if blessed($subscriber);
    my $new_subscriber;
    if ($use_method && (!ref $subscriber || blessed($subscriber))) {
        $new_subscriber = [ $subscriber, $use_method ];
    } else {
        $new_subscriber = $subscriber;
    }

    TRACEF("Adding subscriber [%s] of '%s' on [%s]",
           $subscriber, _event_name($event), _item_name($item));
    $subscriber_list->{$subscriber} = $new_subscriber;

    return scalar keys %$subscriber_list;
}


# Remove one or more subscribers from a subscribed item. Return new
# number of subscribers.
# TODO: Will this work with subroutines?
sub delete_subscriber {
    my ($item, $event, $subscriber) = @_;
    return 0 unless ref $S { $item };
    $event = '*' unless defined $event && length $event;

    if ($subscriber) {
        my @events;
        if (defined $event && length $event) {
            @events = ($event);
        } else {
            @events = _get_registered_events($item);
        }

        foreach my $subscribed_event (@events) {
            TRACEF("Removing subscriber [%s] of '%s' on [%s]",
                   $subscriber,
                   _event_name($subscribed_event),
                   _item_name($item));

            my $removed = delete $S {$item} {$subscribed_event} {$subscriber};
            TRACEF("Found subscriber [%s]; removing", $subscriber);
        }
    }
    return defined wantarray ? 0 + $item -> get_subscribers($event) : undef;
}


# Remove all subscribers from a subscribed item. Return number of
# subscribers removed.
sub delete_all_subscribers {
    my ($item) = @_;
    TRACEF("Removing all subscribers from [%s]", _item_name($item));
    my $rv = defined wantarray ? 0 + $item -> get_subscribers : undef;
    return 0 unless ref $S {$item};
    $S {$item} = {};
    return $rv;
}


# Tell all subscribers that a event-change has occurred. No return
# value.
sub notify_subscribers {
    my ($item, $event, @params) = @_;
    croak "Invalid event name '$event'" if $event && ref $event;
    $event = '*' unless defined $event && length $event;
    TRACEF("Notification from [%s] with event [%s]",
           _item_name($item), _event_name($event));

    my @subscribers = $item -> get_subscribers($event);
    unless ($event eq '*') {
        push @subscribers, $item -> get_subscribers('*');
    }

    my %called;
    foreach my $s (@subscribers) {
        TRACEF("Notifying subscriber [%s]", $s);
        if ($called {$s}++) {
            TRACEF("Already called subscriber [%s]", $s);
            next;
        }
        if (reftype $s && reftype $s eq 'CODE') {
            $s -> ($item, $event, @params);
        }
        else {
            my ($callable, $method) = ($s, 'update');
            if (ref $s && reftype $s eq 'ARRAY' && ! blessed($s)) {
                ($callable, $method) = @$s;
            }
            next unless $callable && $method;
            $callable -> $method($item, $event, @params);
        }
    }
}


# Retrieve *all* subscribers for a particular item. (See docs for what
# *all* means.) Returns a list of subscribers
sub get_subscribers {
    my ($item, $event) = @_;
    TRACEF("Retrieving subscribers of [%s] on [%s]",
           _event_name($event), _item_name($item));

    my @subscribers = ();
    my $class = ref $item;
    if ($class) {
        TRACEF("Retrieving object-specific subscribers from [%s]",
               _item_name($item));
        push @subscribers, _obs_get_subscribers_scoped($item, $event);
    }
    else {
        $class = $item;
    }
    TRACEF("Retrieving class-specific subscribers from [%s] and its "
           . "parents", $class);
    push @subscribers, _obs_get_subscribers_scoped($class, $event),
            _obs_get_parent_subscribers($class, $event);

    my (@filtered, %seen);
    foreach (@subscribers) {
        push @filtered, $_, unless $seen {$_}++;
    }
    TRACEF("Found subscribers [%s]", join '][', @filtered);
    return @filtered;
}


# Copy all subscribers from one item to another. This DOESN'T copy
# subscribers from parents.
sub copy_subscribers {
    my ($item_from, $item_to) = @_;

    my $rv;
    foreach my $event ('', _get_registered_events($item_from)) {
        my @obs = _obs_get_explicit_subscribers_scoped($item_from, $event);
        foreach my $subscriber (@obs) {
            $item_to -> add_subscriber($event, $subscriber);
            $rv++;
        }
    }
    return $rv;
}


sub count_subscribers {
    my ($item, $event) = @_;
    TRACEF("Counting subscribers of [%s] on [%s]",
           _event_name($event), _item_name($item));
    return scalar $item -> get_subscribers($event);
}


# Log::Trace stubs
sub TRACE  {}
sub TRACEF {}

############################################################################
# Private functions

sub _get_registered_events {
    my ($item) = @_;
    return () unless ref $S {$item};
    return grep defined ($_) && length ($_), keys % {$S {$item}};
}

# Find subscribers from parents
sub _obs_get_parent_subscribers {
    my ($item, $event) = @_;
    my $class = ref $item || $item;

    # We only find the parents the first time, so if you muck with
    # @ISA you'll get unexpected behavior...

    unless (ref $P {$class}) {
        my @parent_path = Class::ISA::super_path($class);
        TRACEF("Finding subscribers from parent classes [%s]",
                         join '] [', @parent_path );
        my @subscribed_parents = ();
        foreach my $parent (@parent_path) {
            next if ($parent eq 'Class::Publisher');
            if ($parent -> isa('Class::Publisher')) {
                push @subscribed_parents, $parent;
            }
        }
        push @subscribed_parents, __PACKAGE__;
        $P {$class} = \@subscribed_parents;
        TRACEF("Found subscribed parents for [%s]: [%s]",
                        $class, join '] [', @subscribed_parents);
    }

    my @parent_subscribers = ();
    foreach my $parent (@{$P {$class}}) {
        push @parent_subscribers, _obs_get_subscribers_scoped($parent, $event);
    }
    return @parent_subscribers;
}


# Return subscribers ONLY for the specified item
sub _obs_get_subscribers_scoped {
    my ($item, $event) = @_;
    return () unless (ref $S {$item});

    my @events;
    if (defined $event && length $event) {
        @events = ('', $event);
    } else {
        @events = ('', _get_registered_events($item));
    }

    my @subscribers;
    foreach (@events) {
        next unless (ref $S {$item} {$_});
        push @subscribers, values %{$S {$item} {$_}};
    }
    return @subscribers;
}

# Return subscribers EXPLICITLY registered for the specified item AND event
sub _obs_get_explicit_subscribers_scoped {
    my ($item, $event) = @_;
    return () unless ref $S {$item} && ref $S {$item} {$event};
    return values %{$S {$item} {$event}};
}

# Return subscriber validation errors
sub _valid_subscriber {
    my $s = shift;

    return unless defined $s;
    return 1 if !ref $s && length $s;           # Class
    return 1 if ref $s && reftype $s eq 'CODE'; # Subroutine
    return 1 if blessed ($s);                   # Object
    return 0;
}

# Used in debugging
sub _item_name {
    my ($item) = @_;
    return "Class $item" unless (ref $item);
    my $item_class = ref $item;
    if ($item -> can('id')) {
        return "Object of class $item_class with ID " . $item -> id;
    }
    return "Instance of class $item_class";
}

sub _event_name {
    my ($event) = @_;
    return $event if defined $event && length $event;
    return 'all events';
}

1;

__END__