view release on metacpan or  search on metacpan

lib/Evented/Object.pm  view on Meta::CPAN

# Copyright (c) 2011-17, Mitchell Cooper
#
# Evented::Object: a simple yet featureful base class event framework.
#
# Evented::Object is based on the libuic UIC::Evented::Object:
# ... which is based on Evented::Object from foxy-java IRC Bot,
# ... which is based on Evented::Object from Arinity IRC Services,
# ... which is based on Evented::Object from ntirc IRC Client,
# ... which is based on IRC::Evented::Object from libirc IRC Library.
#
# Evented::Object and its very detailed documentation can be found
# in their latest versions at https://github.com/cooper/evented-object.
#
package Evented::Object;

use warnings;
use strict;
use utf8;
use 5.010;

# these must be set before loading EventFire.
our ($events, $props, %monitors);
BEGIN {
    $events = 'eventedObject.events';
    $props  = 'eventedObject.props';
}

use Scalar::Util qw(weaken blessed);
use Evented::Object::EventFire;
use Evented::Object::Collection;

our $VERSION = '5.68';

# creates a new evented object.
sub new {
    my ($class, %opts) = @_;
    bless \%opts, $class;
}

#############################
### REGISTERING CALLBACKS ###
#############################

# ->register_callback()
#
# aliases: ->register_event(), ->on()
# attaches an event callback.
#
# $eo->register_callback(myEvent => sub {
#     ...
# }, 'some.callback.name', priority => 200);
#
sub register_callback {
    my ($eo, $event_name, $code, @opts_) = @_;

    # if there is an odd number of options, the first is the callback name.
    # this also implies with_eo.
    my %opts;
    if (@opts_ % 2) {
        %opts = (
            name    => shift @opts_,
            with_eo => 1,
            @opts_
        );
    }
    else {
        %opts = @opts_;
    }

    # no name was provided, so we shall construct one using pure hackery.
    # this is one of the most criminal things I've ever done.
    my @caller = caller;
    if (!defined $opts{name}) {
        state $c    = -1; $c++;
        $opts{name} = "$event_name:$caller[0]($caller[2],$c)";
    }

    # determine the event store.
    my $event_store = _event_store($eo);

    # before/after a callback.
    my $priority = delete $opts{priority} || 0;
    if (defined $opts{before} or defined $opts{after}) {
        $priority = 'nan';
        # nan priority indicates it should be determined at a later time.
    }

    # add the callback.

lib/Evented/Object.pm  view on Meta::CPAN

    return $collection;
}

#####################
### FIRING EVENTS ###
#####################

# ->fire_event()
#
# prepares an event and then fires it.
#
sub fire_event {
    shift->prepare_event(shift, @_)->fire(caller => [caller 1]);
}

# ->fire_events_together()
# fire_events_together()
#
# prepares several events and then fires them together.
#
sub fire_events_together {
    prepare_together(@_)->fire(caller => [caller 1]);
}

# ->fire_once()
#
# prepares an event, fires it, and deletes all callbacks afterward.
#
sub fire_once {
    my ($eo, $event_name, @args) = @_;

    # fire with this caller.
    my $fire = $eo->prepare_event($event_name, @args)->fire(
        caller => [caller 1]
    );

    # delete the event.
    $eo->delete_event($event_name);
    return $fire;

}

########################
### LISTENER OBJECTS ###
########################

# ->add_listener()
#
# adds an object as a listener of another object's events.
# see "listeners" in the documentation.
#
sub add_listener {
    my ($eo, $obj, $prefix) = @_;

    # find listeners list.
    my $listeners = $eo->{$props}{listeners} ||= [];

    # store this listener.
    push @$listeners, [$prefix, $obj];

    # weaken the reference to the listener.
    weaken($listeners->[$#$listeners][1]);

    return 1;
}

# ->delete_listener()
#
# removes an object which was listening to another object's events.
# see "listeners" in the documentation.
#
sub delete_listener {
    my ($eo, $obj) = @_;
    return 1 unless my $listeners = $eo->{$props}{listeners};
    @$listeners = grep {
        ref $_->[1] eq 'ARRAY' and $_->[1] != $obj
    } @$listeners;
    return 1;
}

######################
### CLASS MONITORS ###
######################

# for objective use $eo->monitor_events($pkg)
sub monitor_events  {    add_class_monitor(reverse @_) }
sub stop_monitoring { delete_class_monitor(reverse @_) }

# add_class_monitor()
#
# set the monitor object of a class.
#
# TODO: honestly class monitors need to track individual callbacks so that the
# monitor is notified of all deletes of callbacks added by the class being
# monitored even if the delete action was not committed by that package.
#
sub add_class_monitor {
    my ($pkg, $obj) = @_;

    # ensure it's an evented object.
    return unless $obj->isa(__PACKAGE__);

    # it's already in the list.
    my $m = $monitors{$pkg} ||= [];
    return if grep { $_ == $obj } @$m = grep { defined } @$m;

    # hold a weak reference to the monitor.
    push @$m, $obj;
    weaken($monitors{$pkg}[$#$m]);

    return 1;
}

# delete_class_monitor()
#
# remove a class monitor object from a class.
#
sub delete_class_monitor {
    my ($pkg, $obj) = @_;
    my $m = $monitors{$pkg} or return;
    @$m   = grep { defined && $_ != $obj } @$m;
}

#######################
### CLASS FUNCTIONS ###
#######################

# safe_fire($obj, event => ...)
#
# checks that an object is blessed and that it is an evented object.
# if so, prepares and fires an event with optional arguments.
#
sub safe_fire {
    my $obj = shift;
    return if !blessed $obj || !$obj->isa(__PACKAGE__);
    return $obj->fire_event(@_);
}

#########################
### INTERNAL ROUTINES ###
#########################

# access package storage.
sub _package_store {
    my $package = shift;
    no strict 'refs';
    my $ref = "${package}::__EO__";
    if (!keys %$ref) {
        %$ref = ();
    }
    return *$ref{HASH};
}

# fetch the event store of object or package.
sub _event_store {
    my $eo    = shift;
    return $eo->{$events}   ||= {} if blessed $eo;
    my $store = _package_store($eo);
    return $store->{events} ||= {} if not blessed $eo;
}

# fetch the property store of object or package.
sub _prop_store {
    my $eo    = shift;
    return $eo->{$props}   ||= {} if blessed $eo;
    my $store = _package_store($eo);
    return $store->{props} ||= {} if not blessed $eo;
}

# fetch a callback from its name.
sub _get_callback_named {
    my ($eo, $event_name, $callback_name) = @_;
    foreach my $callback (@{ _get_callbacks($eo, $event_name) }) {
        return $callback if $callback->[2]{name} eq $callback_name
    }
    return;
}

# fetches callbacks of an event.
# internal use only.
sub _get_callbacks {
    my ($eo, $event_name, @args) = @_;
    my (%callbacks, %callback_names);

    # start out with two stores: the object and the package.
    my @stores = (
        [ $event_name => $eo->{$events}             ],
        [ $event_name => _event_store(blessed $eo)  ]
    );


    # if there are any listening objects, add those stores.
    if (my $listeners = $eo->{$props}{listeners}) {
        my @delete;

        LISTENER: foreach my $i (0 .. $#$listeners) {
            my $l = $listeners->[$i] or next;
            my ($prefix, $lis) = @$l;
            my $listener_event_name = $prefix.q(.).$event_name;

            # object has been deallocated by garbage disposal,
            # so we can delete this listener.
            if (!$lis) {
                push @delete, $i;
                next LISTENER;
            }


            push @stores, [ $listener_event_name => $lis->{$events} ];

        }

        # delete listeners if necessary.
        splice @$listeners, $_, 1 foreach @delete;

    }

    # add callbacks from each store.
    foreach my $st (@stores) {
        my ($event_name, $event_store) = @$st;
        my $store = $event_store->{$event_name} or next;
        foreach my $priority (keys %$store) {

            # create a group reference.
            my $group_id = "$eo/$event_name";
            my $group    = [ $eo, $event_name, \@args, $group_id ];
            weaken($group->[0]);

            # add each callback set. inject callback name.
            foreach my $cb_ref (@{ $store->{$priority} }) {
                my %cb = %$cb_ref; # make a copy
                $cb{id} = "$group_id/$cb{name}";
                $callbacks{ $cb{id} } = [ $priority, $group, \%cb ];
                $callback_names{$group_id}{ $cb{name} } = $cb{id};
            }

        }
    }

    return wantarray ? (\%callbacks, \%callback_names) : \%callbacks;
}

# fire a class monitor event.
sub _monitor_fire {
    my ($pkg, $event_name, @args) = @_;
    my $m = $monitors{$pkg} or return;
    safe_fire($_, "monitor:$event_name" => @args) foreach @$m;
}

sub DESTROY { shift->delete_all_events }

###############
### ALIASES ###
###############

sub register_event;
sub register_events;
sub delete_event;

sub on;
sub del;
sub fire;

BEGIN {
    *register_event     = *register_callback;
    *register_events    = *register_callbacks;
    *delete_event       = *delete_callback;
    *on                 = *register_callback;
    *del                = *delete_callback;
    *fire               = *fire_event;
}

1;

=head1 NAME

B<Evented::Object> - base class which allows you to attach callbacks to
objects and then fire events on them.

=head1 SYNOPSIS

 package Person;
 
 use warnings;
 use strict;
 use 5.010;
 use parent 'Evented::Object';