1package Class::Trigger;
2use 5.008_001;
3use strict;
4use vars qw($VERSION);
5$VERSION = "0.14";
6
7use Carp ();
8
9my (%Triggers, %TriggerPoints);
10my %Fetch_All_Triggers_Cache;
11
12sub import {
13    my $class = shift;
14    my $pkg = caller(0);
15
16    $TriggerPoints{$pkg} = { map { $_ => 1 } @_ } if @_;
17
18    # export mixin methods
19    no strict 'refs';
20    my @methods = qw(add_trigger call_trigger last_trigger_results);
21    *{"$pkg\::$_"} = \&{$_} for @methods;
22}
23
24sub add_trigger {
25    my $proto = shift;
26
27    my $triggers = __fetch_triggers($proto);
28
29    my %params = @_;
30    my @values = values %params;
31    if (@_ > 2 && (grep { ref && ref eq 'CODE' } @values) == @values) {
32        Carp::croak "mutiple trigger registration in one add_trigger() call is deprecated.";
33    }
34
35    if ($#_ == 1 && ref($_[1]) eq 'CODE') {
36        @_ = (name => $_[0], callback => $_[1]);
37    }
38
39    my %args = ( name => undef, callback => undef, abortable => undef, @_ );
40    my $when = $args{'name'};
41    my $code = $args{'callback'};
42    my $abortable = $args{'abortable'};
43    __validate_triggerpoint( $proto, $when );
44    Carp::croak('add_trigger() needs coderef') unless ref($code) eq 'CODE';
45    push @{ $triggers->{$when} }, [ $code, $abortable ];
46
47    # Clear the cache when class triggers are added.  Because triggers are
48    # inherited adding a trigger to one class may effect others.  Simplest
49    # thing to do is to clear the whole thing.
50    %Fetch_All_Triggers_Cache = () unless ref $proto;
51
52    1;
53}
54
55
56sub last_trigger_results {
57    my $self = shift;
58    my $result_store = ref($self) ? $self : ${Class::Trigger::_trigger_results}->{$self};
59    return $result_store->{'_class_trigger_results'};
60}
61
62sub call_trigger {
63    my $self = shift;
64    my $when = shift;
65
66    my @return;
67
68    my $result_store = ref($self) ? $self : ${Class::Trigger::_trigger_results}->{$self};
69
70    $result_store->{'_class_trigger_results'} = [];
71
72    if (my @triggers = __fetch_all_triggers($self, $when)) { # any triggers?
73        for my $trigger (@triggers) {
74            my @return = $trigger->[0]->($self, @_);
75            push @{$result_store->{'_class_trigger_results'}}, \@return;
76            return undef if ($trigger->[1] and not $return[0]); # only abort on false values.
77        }
78    }
79    else {
80        # if validation is enabled we can only add valid trigger points
81        # so we only need to check in call_trigger() if there's no
82        # trigger with the requested name.
83        __validate_triggerpoint($self, $when);
84    }
85
86    return scalar @{$result_store->{'_class_trigger_results'}};
87}
88
89sub __fetch_all_triggers {
90    my ($obj, $when, $list, $order, $nocache) = @_;
91    $nocache = 0 unless defined $nocache;
92    my $class = ref $obj || $obj;
93    my $return;
94    my $when_key = defined $when ? $when : '';
95
96    unless ($nocache) {
97        return __cached_triggers($obj, $when)
98            if $Fetch_All_Triggers_Cache{$class}{$when_key};
99    }
100
101    unless ($list) {
102        # Absence of the $list parameter conditions the creation of
103        # the unrolled list of triggers. These keep track of the unique
104        # set of triggers being collected for each class and the order
105        # in which to return them (based on hierarchy; base class
106        # triggers are returned ahead of descendant class triggers).
107        $list = {};
108        $order = [];
109        $return = 1;
110    }
111    no strict 'refs';
112    my @classes = @{$class . '::ISA'};
113    push @classes, $class;
114    foreach my $c (@classes) {
115        next if $list->{$c};
116#        if (UNIVERSAL::can($c, 'call_trigger')) {
117        if ($c->can('call_trigger')) {
118            $list->{$c} = [];
119            __fetch_all_triggers($c, $when, $list, $order, 1)
120                unless $c eq $class;
121            if (defined $when && $Triggers{$c}{$when}) {
122                push @$order, $c;
123                $list->{$c} = $Triggers{$c}{$when};
124            }
125        }
126    }
127    if ($return) {
128        my @triggers;
129        foreach my $class (@$order) {
130            push @triggers, @{ $list->{$class} };
131        }
132
133        # Only cache the class triggers, object triggers would
134        # necessitate a much larger cache and they're cheap to
135        # get anyway.
136        $Fetch_All_Triggers_Cache{$class}{$when_key} = \@triggers;
137
138        return __cached_triggers($obj, $when);
139    }
140}
141
142
143sub __cached_triggers {
144    my($proto, $when) = @_;
145    my $class = ref $proto || $proto;
146
147    return @{ $Fetch_All_Triggers_Cache{$class}{$when || ''} },
148           @{ __object_triggers($proto, $when) };
149}
150
151
152sub __object_triggers {
153    my($obj, $when) = @_;
154
155    return [] unless ref $obj && defined $when;
156    return $obj->{__triggers}{$when} || [];
157}
158
159
160sub __validate_triggerpoint {
161    return unless my $points = $TriggerPoints{ref $_[0] || $_[0]};
162    my ($self, $when) = @_;
163    Carp::croak("$when is not valid triggerpoint for ".(ref($self) ? ref($self) : $self))
164        unless $points->{$when};
165}
166
167sub __fetch_triggers {
168    my ($obj, $proto) = @_;
169    # check object based triggers first
170    return ref $obj ? $obj->{__triggers} ||= {} : $Triggers{$obj} ||= {};
171}
172
1731;
174__END__
175
176=head1 NAME
177
178Class::Trigger - Mixin to add / call inheritable triggers
179
180=head1 SYNOPSIS
181
182  package Foo;
183  use Class::Trigger;
184
185  sub foo {
186      my $self = shift;
187      $self->call_trigger('before_foo');
188      # some code ...
189      $self->call_trigger('middle_of_foo');
190      # some code ...
191      $self->call_trigger('after_foo');
192  }
193
194  package main;
195  Foo->add_trigger(before_foo => \&sub1);
196  Foo->add_trigger(after_foo => \&sub2);
197
198  my $foo = Foo->new;
199  $foo->foo;            # then sub1, sub2 called
200
201  # triggers are inheritable
202  package Bar;
203  use base qw(Foo);
204
205  Bar->add_trigger(before_foo => \&sub);
206
207  # triggers can be object based
208  $foo->add_trigger(after_foo => \&sub3);
209  $foo->foo;            # sub3 would appply only to this object
210
211=head1 DESCRIPTION
212
213Class::Trigger is a mixin class to add / call triggers (or hooks)
214that get called at some points you specify.
215
216=head1 METHODS
217
218By using this module, your class is capable of following methods.
219
220=over 4
221
222=item add_trigger
223
224  Foo->add_trigger($triggerpoint => $sub);
225  $foo->add_trigger($triggerpoint => $sub);
226
227
228  Foo->add_trigger( name => $triggerpoint,
229                    callback => sub {return undef},
230                    abortable => 1);
231
232  # no further triggers will be called. Undef will be returned.
233
234
235Adds triggers for trigger point. You can have any number of triggers
236for each point. Each coderef will be passed a reference to the calling object,
237as well as arguments passed in via L<call_trigger>. Return values will be
238captured in I<list context>.
239
240If add_trigger is called with named parameters and the C<abortable>
241parameter is passed a true value, a false return value from trigger
242code will stop processing of this trigger point and return a C<false>
243value to the calling code.
244
245If C<add_trigger> is called without the C<abortable> flag, return
246values will be captured by call_trigger, but failures will be ignored.
247
248If C<add_trigger> is called as object method, whole current trigger
249table will be copied onto the object and the new trigger added to
250that. (The object must be implemented as hash.)
251
252  my $foo = Foo->new;
253
254  # this trigger ($sub_foo) would apply only to $foo object
255  $foo->add_trigger($triggerpoint => $sub_foo);
256  $foo->foo;
257
258  # And not to another $bar object
259  my $bar = Foo->new;
260  $bar->foo;
261
262=item call_trigger
263
264  $foo->call_trigger($triggerpoint, @args);
265
266Calls triggers for trigger point, which were added via C<add_trigger>
267method. Each triggers will be passed a copy of the object as the first argument.
268Remaining arguments passed to C<call_trigger> will be passed on to each trigger.
269Triggers are invoked in the same order they were defined.
270
271If there are no C<abortable> triggers or no C<abortable> trigger point returns
272a false value, C<call_trigger> will return the number of triggers processed.
273
274
275If an C<abortable> trigger returns a false value, call trigger will stop execution
276of the trigger point and return undef.
277
278=item last_trigger_results
279
280    my @results = @{ $foo->last_trigger_results };
281
282Returns a reference to an array of the return values of all triggers called
283for the last trigger point. Results are ordered in the same order the triggers
284were run.
285
286
287=back
288
289=head1 TRIGGER POINTS
290
291By default you can make any number of trigger points, but if you want
292to declare names of trigger points explicitly, you can do it via
293C<import>.
294
295  package Foo;
296  use Class::Trigger qw(foo bar baz);
297
298  package main;
299  Foo->add_trigger(foo  => \&sub1); # okay
300  Foo->add_trigger(hoge => \&sub2); # exception
301
302=head1 FAQ
303
304B<Acknowledgement:> Thanks to everyone at POOP mailing-list
305(http://poop.sourceforge.net/).
306
307=over 4
308
309=item Q.
310
311This module lets me add subs to be run before/after a specific
312subroutine is run.  Yes?
313
314=item A.
315
316You put various call_trigger() method in your class.  Then your class
317users can call add_trigger() method to add subs to be run in points
318just you specify (exactly where you put call_trigger()).
319
320=item Q.
321
322Are you aware of the perl-aspects project and the Aspect module?  Very
323similar to Class::Trigger by the look of it, but its not nearly as
324explicit.  Its not necessary for foo() to actually say "triggers go
325*here*", you just add them.
326
327=item A.
328
329Yep ;)
330
331But the difference with Aspect would be that Class::Trigger is so
332simple that it's easy to learn, and doesn't require 5.6 or over.
333
334=item Q.
335
336How does this compare to Sub::Versive, or Hook::LexWrap?
337
338=item A.
339
340Very similar. But the difference with Class::Trigger would be the
341explicitness of trigger points.
342
343In addition, you can put hooks in any point, rather than pre or post
344of a method.
345
346=item Q.
347
348It looks interesting, but I just can't think of a practical example of
349its use...
350
351=item A.
352
353(by Tony Bowden)
354
355I originally added code like this to Class::DBI to cope with one
356particular case: auto-upkeep of full-text search indices.
357
358So I added functionality in Class::DBI to be able to trigger an
359arbitary subroutine every time something happened - then it was a
360simple matter of setting up triggers on INSERT and UPDATE to reindex
361that row, and on DELETE to remove that index row.
362
363See L<Class::DBI::mysql::FullTextSearch> and its source code to see it
364in action.
365
366=back
367
368=head1 AUTHORS
369
370Original idea by Tony Bowden E<lt>tony@kasei.comE<gt> in Class::DBI.
371
372Code by Tatsuhiko Miyagawa E<lt>miyagawa@bulknews.netE<gt>.
373
374Jesse Vincent added a code to get return values from triggers and
375abortable flag.
376
377=head1 LICENSE
378
379This library is free software; you can redistribute it and/or modify
380it under the same terms as Perl itself.
381
382=head1 SEE ALSO
383
384L<Class::DBI>
385
386=cut
387
388