root/Class-Trigger/trunk/lib/Class/Trigger.pm

Revision 2313 (checked in by miyagawa, 13 years ago)

Checking in changes prior to tagging of version 0.12. Changelog diff is:

=== Changes
==================================================================
--- Changes (revision 6808)
+++ Changes (local)
@@ -1,5 +1,8 @@

Revision history for Perl extension Class
Trigger.

+0.12 Mon Aug 20 16:06:50 PDT 2007
+ - Make this a release
+

0.11_03 Wed Jun 20 12:12:36 PDT 2007

- Fixed a bug in backward-compatiblity code to handle multiple

hooks in one add_trigger() call. (Thanks to mark addison)

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