File Coverage

blib/lib/Class/Trigger.pm
Criterion Covered Total %
statement 70 70 100.0
branch 29 30 96.7
condition 14 16 87.5
subroutine 11 11 100.0
pod 2 2 100.0
total 126 129 97.7


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