Profile of /project/perl/lib/Class/Trigger.pm

File	/project/perl/lib/Class/Trigger.pm
Statements Executed	41754
Statement Execution Time	410ms

Subroutines — ordered by exclusive time
Calls	P	F	Exclusive Time	Inclusive Time	Subroutine
2310	2	1	344ms	378ms	Class::Trigger::::__fetch_all_triggersClass::Trigger::__fetch_all_triggers
462	2	1	28.1ms	465ms	Class::Trigger::::call_triggerClass::Trigger::call_trigger
15	1	1	1.26ms	1.70ms	Class::Trigger::::add_triggerClass::Trigger::add_trigger
15	1	1	268µs	268µs	Class::Trigger::::__fetch_triggersClass::Trigger::__fetch_triggers
15	1	1	178µs	178µs	Class::Trigger::__validate_triggerpoint
1	1	1	88µs	88µs	Class::Trigger::::importClass::Trigger::import
0	0	0	0s	0s	Class::Trigger::::BEGINClass::Trigger::BEGIN

Call graph for these subroutines as a Graphviz dot language file.

Line	State ments	Time on line	Calls	Time in subs	Code
1					package Class::Trigger;
2
3	3	98µs	1	27µs	use strict; # spent 27µs making 1 call to strict::import
4	3	99µs	1	137µs	use vars qw($VERSION); # spent 137µs making 1 call to vars::import
5	1	5µs			$VERSION = "0.11";
6
7	3	204µs			use Carp ();
8
9	1	5µs			my (%Triggers, %TriggerPoints);
10
11					# spent 88µs within Class::Trigger::import which was called # once (88µs+0s) by base::import at line 5 of Class/DBI.pm sub import {
12	6	95µs			my $class = shift;
13					my $pkg = caller(0);
14
15					$TriggerPoints{$pkg} = { map { $_ => 1 } @_ } if @_;
16
17					# export mixin methods
18	3	666µs	1	110µs	no strict 'refs'; # spent 110µs making 1 call to strict::unimport
19					my @methods = qw(add_trigger call_trigger);
20					*{"$pkg\::$_"} = \&{$_} for @methods;
21					}
22
23					# spent 1.70ms (1.26+446µs) within Class::Trigger::add_trigger which was called 15 times, avg 113µs/call: # 15 times (1.26ms+446µs) by Class::DBI::add_trigger at line 1019 of Class/DBI.pm, avg 113µs/call sub add_trigger {
24	105	1.17ms			my $proto = shift;
25
26					my $triggers = __fetch_triggers($proto); # spent 268µs making 15 calls to Class::Trigger::__fetch_triggers, avg 18µs/call
27					while (my($when, $code) = splice @_, 0, 2) {
28					__validate_triggerpoint($proto, $when); # spent 178µs making 15 calls to Class::Trigger::__validate_triggerpoint, avg 12µs/call
29					Carp::croak('add_trigger() needs coderef') unless ref($code) eq 'CODE';
30					push @{$triggers->{$when}}, $code;
31					}
32
33					1;
34					}
35
36					# spent 465ms (28.1+437) within Class::Trigger::call_trigger which was called 462 times, avg 1.01ms/call: # 461 times (28.0ms+433ms) by Class::DBI::construct at line 717 of Class/DBI.pm, avg 1000µs/call # once (71µs+4.14ms) by Class::DBI::_flesh at line 859 of Class/DBI.pm sub call_trigger {
37	1386	27.7ms			my $self = shift;
38					my $when = shift;
39
40					if (my @triggers = __fetch_all_triggers($self, $when)) { # any triggers? # spent 378ms making 462 calls to Class::Trigger::__fetch_all_triggers, avg 817µs/call # spent 59.6ms making 462 calls to Class::DBI::Relationship::HasA::__ANON__[Class/DBI/Relationship/HasA.pm:77], avg 129µs/call
41					$_->($self, @_) for @triggers;
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					__validate_triggerpoint($self, $when);
48					}
49					}
50
51					# spent 378ms (344+34.0) within Class::Trigger::__fetch_all_triggers which was called 2310 times, avg 163µs/call: # 1848 times (228ms+-228ms) by Class::Trigger::__fetch_all_triggers at line 72, avg 0s/call # 462 times (115ms+262ms) by Class::Trigger::call_trigger at line 40, avg 817µs/call sub __fetch_all_triggers {
52	40194	379ms			my ($obj, $when, $list, $order) = @_;
53					my $class = ref $obj \|\| $obj;
54					my $return;
55					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					$list = {};
62					$order = [];
63					$return = 1;
64					}
65	3	577µs	1	95µs	no strict 'refs'; # spent 95µs making 1 call to strict::unimport
66					my @classes = @{$class . '::ISA'};
67					push @classes, $class;
68					foreach my $c (@classes) {
69					next if $list->{$c};
70					if (UNIVERSAL::can($c, 'call_trigger')) { # spent 34.0ms making 3696 calls to UNIVERSAL::can, avg 9µs/call
71					$list->{$c} = [];
72					__fetch_all_triggers($c, $when, $list, $order) # spent 656ms making 1848 calls to Class::Trigger::__fetch_all_triggers, avg 355µs/call, recursion: max depth 4, time 656ms
73					unless $c eq $class;
74					if (defined $when && $Triggers{$c}{$when}) {
75					push @$order, $c;
76					$list->{$c} = $Triggers{$c}{$when};
77					}
78					}
79					}
80					if ($return) {
81					my @triggers;
82					foreach my $class (@$order) {
83					push @triggers, @{ $list->{$class} };
84					}
85					if (ref $obj && defined $when) {
86					my $obj_triggers = $obj->{__triggers}{$when};
87					push @triggers, @$obj_triggers if $obj_triggers;
88					}
89					return @triggers;
90					}
91					}
92
93					# spent 178µs within Class::Trigger::__validate_triggerpoint which was called 15 times, avg 12µs/call: # 15 times (178µs+0s) by Class::Trigger::add_trigger at line 28, avg 12µs/call sub __validate_triggerpoint {
94	15	209µs			return unless my $points = $TriggerPoints{ref $_[0] \|\| $_[0]};
95					my ($self, $when) = @_;
96					Carp::croak("$when is not valid triggerpoint for ".(ref($self) ? ref($self) : $self))
97					unless $points->{$when};
98					}
99
100					# spent 268µs within Class::Trigger::__fetch_triggers which was called 15 times, avg 18µs/call: # 15 times (268µs+0s) by Class::Trigger::add_trigger at line 26, avg 18µs/call sub __fetch_triggers {
101	30	351µs			my ($obj, $proto) = @_;
102					# check object based triggers first
103					return ref $obj ? $obj->{__triggers} \|\|= {} : $Triggers{$obj} \|\|= {};
104					}
105
106	1	13µs			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