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