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

Revision 413 (checked in by miyagawa, 19 years ago)

add FAQ

  • 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.03';
6
7 use Class::Data::Inheritable;
8 use Carp ();
9
10 sub import {
11     my $class = shift;
12     my $pkg = caller(0);
13
14     # XXX 5.005_03 isa() is broken with MI
15     unless ($pkg->can('mk_classdata')) {
16         no strict 'refs';
17         push @{"$pkg\::ISA"}, 'Class::Data::Inheritable';
18     }
19
20     $pkg->mk_classdata('__triggers');
21     $pkg->mk_classdata('__triggerpoints');
22
23     $pkg->__triggerpoints({ map { $_ => 1 } @_ }) if @_;
24
25     # export mixin methods
26     no strict 'refs';
27     *{"$pkg\::add_trigger"}  = \&add_trigger;
28     *{"$pkg\::call_trigger"} = \&call_trigger;
29 }
30
31 sub add_trigger {
32     my $proto = shift;
33
34     # should be deep copy of the hash: for inheritance
35     my %triggers = __deep_dereference(__fetch_triggers($proto));
36     while (my($when, $code) = splice @_, 0, 2) {
37         __validate_triggerpoint($proto, $when);
38         unless (ref($code) eq 'CODE') {
39             Carp::croak('add_trigger() needs coderef');
40         }
41         push @{$triggers{$when}}, $code;
42     }
43     __update_triggers($proto, \%triggers);
44 }
45
46 sub call_trigger {
47     my($self, $when) = @_;
48     __validate_triggerpoint(ref $self, $when);
49     my $all_triggers = __fetch_triggers($self);
50     my $triggers = $all_triggers->{$when} || [];
51     $_->($self) for @{$triggers};
52 }
53
54 sub __validate_triggerpoint {
55     my($class, $when) = @_;
56     my $points = $class->__triggerpoints;
57     if ($points && ! defined $points->{$when}) {
58         Carp::croak("$when is not valid triggerpoint for $class");
59     }
60 }
61
62 sub __fetch_triggers {
63     my $proto = shift;
64     if (ref $proto) {
65         # first check object based triggers
66         return $proto->{__triggers} if defined $proto->{__triggers};
67     }
68     return $proto->__triggers || {};
69 }
70
71 sub __update_triggers {
72     my($proto, $triggers) = @_;
73     if (ref $proto) {
74         # object attributes
75         $proto->{__triggers} = $triggers;
76     }
77     else {
78         # class data inheritable
79         $proto->__triggers($triggers);
80     }
81 }
82
83 sub __deep_dereference {
84     my $hashref = shift;
85     my %copy;
86     while (my($key, $arrayref) = each %$hashref) {
87         $copy{$key} = [ @$arrayref ];
88     }
89     return %copy;
90 }
91
92 1;
93 __END__
94
95 =head1 NAME
96
97 Class::Trigger - Mixin to add / call inheritable triggers
98
99 =head1 SYNOPSIS
100
101   package Foo;
102   use Class::Trigger;
103
104   sub foo {
105       my $self = shift;
106       $self->call_trigger('before_foo');
107       $self->do_foo;
108       $self->call_trigger('after_foo');
109   }
110
111   package main;
112   Foo->add_trigger(before_foo => \&sub1);
113   Foo->add_trigger(after_foo => \&sub2);
114
115   my $foo = Foo->new;
116   $foo->foo;                    # then sub1, sub2 called
117
118   # triggers are inheritable
119   package Bar;
120   use base qw(Foo);
121
122   Bar->add_trigger(before_foo => \&sub);
123
124   # triggers can be object based
125   $foo->add_hook(after_foo => \&sub3);
126   $foo->foo;                    # sub3 would appply only to this object
127
128 =head1 DESCRIPTION
129
130 Class::Trigger is a mixin class to add / call triggers (or hooks)
131 that get called at some points you specify.
132
133 =head1 METHODS
134
135 By using this module, your class is capable of following two methods.
136
137 =over 4
138
139 =item add_trigger
140
141   Foo->add_trigger($triggerpoint => $sub);
142   $foo->add_trigger($triggerpoint => $sub);
143
144 Adds triggers for trigger point. You can have any number of triggers
145 for each point. Each coderef will be passed a copy of the object, and
146 return values will be ignored.
147
148 If C<add_trigger> is called as object method, whole trigger table will
149 be copied onto the object. Then the object should be implemented as
150 hash.
151
152   my $foo = Foo->new;
153
154   # this trigger ($sub_foo) would apply only to $foo object
155   $foo->add_trigger($triggerpoint => $sub_foo);
156   $foo->foo;
157
158   # And not to another $bar object
159   my $bar = Foo->new;
160   $bar->foo;
161
162 =item call_trigger
163
164   $foo->call_trigger($triggerpoint);
165
166 Calls triggers for trigger point, which were added via C<add_trigger>
167 method. Each triggers will be passed a copy of the object.
168
169 =back
170
171 =head1 TRIGGER POINTS
172
173 By default you can make any number of trigger points, but if you want
174 to declare names of trigger points explicitly, you can do it via
175 C<import>.
176
177   package Foo;
178   use Class::Trigger qw(foo bar baz);
179
180   package main;
181   Foo->add_trigger(foo  => \&sub1); # okay
182   Foo->add_trigger(hoge => \&sub2); # exception
183
184 =head1 FAQ
185
186 B<Acknowledgement:> Thanks to everyone at POOP mailing-list
187 (http://poop.sourceforge.net/).
188
189 =over 4
190
191 =item Q.
192
193 This module lets me add subs to be run before/after a specific
194 subroutine is run.  Yes?
195
196 =item A.
197
198 You put various call_trigger() method in your class.  Then your class
199 users can call add_trigger() method to add subs to be run in points
200 just you specify (exactly where you put call_trigger()).
201
202 =item Q.
203
204 Are you aware of the perl-aspects project and the Aspect module?  Very
205 similar to Class::Trigger by the look of it, but its not nearly as
206 explicit.  Its not necessary for foo() to actually say "triggers go
207 *here*", you just add them.
208
209 =item A.
210
211 Yep ;)
212
213 But the difference with Aspect would be that Class::Trigger is so
214 simple that it's easy to learn, and doesn't require 5.6 or over.
215
216 =item Q.
217
218 How does this compare to Sub::Versive, or Hook::LexWrap?
219
220 =item A.
221
222 Very similar. But the difference with Class::Trigger would be the
223 explicitness of trigger points.
224
225 In addition, you can put hooks in any point, rather than pre or post
226 of a method.
227
228 =item Q.
229
230 It looks interesting, but I just can't think of a practical example of
231 its use...
232
233 =item A.
234
235 (by Tony Bowden)
236
237 I originally added code like this to Class::DBI to cope with one
238 particular case: auto-upkeep of full-text search indices.
239
240 So I added functionality in Class::DBI to be able to trigger an
241 arbitary subroutine every time something happened - then it was a
242 simple matter of setting up triggers on INSERT and UPDATE to reindex
243 that row, and on DELETE to remove that index row.
244
245 See L<Class::DBI::mysql::FullTextSearch> and its source code to see it
246 in action.
247
248 =back
249
250 =head1 AUTHOR
251
252 Original idea by Tony Bowden E<lt>tony@kasei.comE<gt> in Class::DBI.
253
254 Code by Tatsuhiko Miyagawa E<lt>miyagawa@bulknews.netE<gt>.
255
256 This library is free software; you can redistribute it and/or modify
257 it under the same terms as Perl itself.
258
259 =head1 SEE ALSO
260
261 L<Class::Data::Inheritable>
262
263 =cut
264
Note: See TracBrowser for help on using the browser.