# Copyright 2002-2008 Josh Clark and Global Moxie, LLC. This code cannot be 
# redistributed without permission from globalmoxie.com.  For more
# information, consult your Big Medium license.
#
# $Id: Trigger.pm 3043 2008-03-31 14:00:38Z josh $

# this module borrows from the hook/callback methods of
# CGI::Application and Class::Trigger

package BigMed::Trigger;
use base 'Exporter';
our @EXPORT = qw(add_trigger call_trigger);
use Class::ISA;
use strict;
use utf8;
use Carp;

my %INSTALLED_CALLBACKS;
my %CALLBACK_CLASSES;
my %CLASS_CACHE;

sub add_trigger {
    my ($self_or_class, $hook, $callback) = @_;
    die "no callback provided when calling add_callback"
      unless ref $callback eq 'CODE';

    $hook = lc $hook;
    if (ref $self_or_class) { # Install in object
        push @{ $self_or_class->{__INSTALLED_CALLBACKS}{$hook} }, $callback;
    }
    else {  # Install in class
        $INSTALLED_CALLBACKS{$hook} ||= {};
        push @{ $INSTALLED_CALLBACKS{$hook}{$self_or_class} }, $callback;
        $CLASS_CACHE{$hook} = {}; #reset cache for this hook
    }
}

sub call_trigger {
    my ( $self, $hook, @args ) = @_;
    my $app_class = ref $self || $self;
    $hook = lc $hook;
    my %executed_callback; #avoid dupes

    # First, run callbacks installed in the object, if any
    if (   ref $self
        && $self->{__INSTALLED_CALLBACKS}
        && $self->{__INSTALLED_CALLBACKS}{$hook} )
    {
        foreach ( @{ $self->{__INSTALLED_CALLBACKS}{$hook} } ) {
            next if $executed_callback{$_};
            $executed_callback{$_} = $_->( $self, @args ) or return;
        }
    }

    # Static class hooks
    my $rcache = $CLASS_CACHE{$hook} or return 1;
    my $rclass_hooks = $rcache->{$app_class}
      || _cache_class_callbacks( $hook, $app_class );
    foreach ( @{  $rclass_hooks } ) {
        next if $executed_callback{$_};
        $executed_callback{$_} = $_->( $self, @args ) or return;
    }
    return 1;

}

sub _cache_class_callbacks {
    my ($hook, $app_class) = @_;
    my $rhook = $INSTALLED_CALLBACKS{$hook} or return;
    $CALLBACK_CLASSES{$app_class} ||=
      [ Class::ISA::self_and_super_path($app_class) ];
    my @callbacks_for_class;
    foreach my $class (@{ $CALLBACK_CLASSES{$app_class} }) {
        next if !exists $rhook->{$class}; #none here
        my %saw_it;
        foreach (@{ $rhook->{$class} }) {
            next if $saw_it{$_};
            push @callbacks_for_class, $_;
            $saw_it{$_} = 1;
        }
    }
    return ( $CLASS_CACHE{$hook}->{$app_class} = \@callbacks_for_class );
}

1;

__END__

=head1 Name

=head2 BigMed::Trigger

Mixin to add / call inheritable trigger/hook callbacks

=head1 Synopsis

    package Foo;
    use Class::Trigger;
    
    sub foo {
        my $self = shift;
        $self->call_trigger('before_foo');
    
        # some code ...
        $self->call_trigger('middle_of_foo');
    
        # some code ...
        $self->call_trigger('after_foo');
    }
    
    package main;
    Foo->add_trigger( before_foo => \&sub1 );
    Foo->add_trigger( after_foo  => \&sub2 );
    
    my $foo = Foo->new;
    $foo->foo;    # sub1, sub2 called
    
    # triggers are inheritable
    package Bar;
    use base qw(Foo);
    
    my $bar = Bar->new();
    $bar->foo;    # sub1, sub2 called as before
    
    Bar->add_trigger( before_foo => \&sub3 );    # Bar-specific callback
    $bar->foo;                                   # sub1, sub3, sub2 called
    
    $foo->foo;    # still just sub1 and sub2 for Foo objects
    
    # triggers can be object based
    $foo->add_trigger( after_foo => \&sub3 );
    $foo->foo;    # sub3 would apply only to this object
    
=head2 Description

Triggers are callbacks run at specific moments or "hooks" placed within
code. BigMed::Trigger lets you add inheritable, class-specific triggers
to these hooks.

=head2 Trigger Methods

=over 4

=item add_trigger($hook_name, \&callback_routine)

    $self->add_trigger('before_foo', \&callback);
    $class->add_trigger('before_foo', \&callback);

The add_trigger method allows you to register a callback
function that is to be called at the given stage of execution.

The hook name is the internal name for the moment when the callback
should be called.

The callback argument should be a code reference. The routine receives
the object as the first argument, plus any additional arguments
provided to C<call_trigger> (see below).

If multiple callbacks are added to the same hook, they will all be
executed one after the other.  The exact order depends on which class
installed each callback, as described below under B<Callback Ordering>.

Callbacks can either be object-based or class-based, depending
upon whether you call C<add_callback> as an object method or a class
method:

    # add object-based callback
    $self->add_trigger('after_foo', \&callback);

    # add class-based callbacks (objects must be implemented as hash refs)
    $class->add_trigger('after_foo', \&callback);
    My::Project->add_trigger('after_foo', \&callback);

Object-based callbacks are stored in the object itself; when the object
goes out of scope, the callbacks go out too. Class-based callbacks meanwhile
survive for the duration of the running Perl process.

Successful callbacks should return a defined value. An undefined return value
will cause C<call_trigger> to stop running callbacks and return an undefined
value.


=item call_trigger($hook_name)

    $self->call_trigger('before_foo', @args);

The C<call_trigger> method is used to executed the callbacks that have been
registered at the given hook.

The first argument to C<call_trigger> is the hook name. Any remaining arguments
are passed to every callback executed at the hook location.

If all callbacks run successfully, call_trigger returns a true value;
otherwise, returns undef.

=back

=head2 Trigger Order

When multiple callbacks have been registered for a single trigger hook, the
triggers are run from the inside-out, starting with object-based callbacks,
then class-specific callbacks for the current class and then climbing
the inheritance tree for that class.

For example, consider the following inheritance tree:

    BigMed::Data::Foo::Bar  #inherits from BigMed::Data::Foo
    BigMed::Data::Foo       #inherits from BigMed::Data

When a callback is run on an object in the BigMed::Data::Foo::Bar class,
callbacks are run in this order:

=over 4

=item Object-specific triggers

=item BigMed::Data::Foo::Bar triggers

=item BigMed::Data::Foo triggers

=back

Within each level, callbacks are run in the order in which they were
registered.

If any of the callbacks individually return an undefined value, C<call_trigger>
will interrupt the process and return an undef value.

Any callbacks registered by classes outside of the object's inheritance
tree are not executed.

=head1 Author & Copyrights

This module and all Big Medium modules are copyright Josh Clark
and Global Moxie. All rights reserved.

Use of this module and the Big Medium content
management system are governed by Global Moxie's software licenses
and may not be used outside of the terms and conditions outlined
there.

For more information, visit the Global Moxie website at
L<http://globalmoxie.com/>.

Big Medium and Global Moxie are service marks of Global Moxie
and Josh Clark. All rights reserved.

=cut