← Index
NYTProf Performance Profile   « block view • line view • sub view »
For ddd2.pl
  Run on Tue May 25 16:52:24 2010
Reported on Tue May 25 16:57:03 2010

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
231021344ms378msClass::Trigger::::__fetch_all_triggersClass::Trigger::__fetch_all_triggers
4622128.1ms465msClass::Trigger::::call_triggerClass::Trigger::call_trigger
15111.26ms1.70msClass::Trigger::::add_triggerClass::Trigger::add_trigger
1511268µs268µsClass::Trigger::::__fetch_triggersClass::Trigger::__fetch_triggers
1511178µs178µsClass::Trigger::::__validate_triggerpointClass::Trigger::__validate_triggerpoint
11188µs88µsClass::Trigger::::importClass::Trigger::import
0000s0sClass::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
1package Class::Trigger;
2
3398µs127µsuse strict;
# spent 27µs making 1 call to strict::import
4399µs1137µsuse vars qw($VERSION);
# spent 137µs making 1 call to vars::import
515µs$VERSION = "0.11";
6
73204µsuse Carp ();
8
915µsmy (%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 {
1216µs my $class = shift;
1316µs my $pkg = caller(0);
14
1515µs $TriggerPoints{$pkg} = { map { $_ => 1 } @_ } if @_;
16
17 # export mixin methods
183666µs1110µs no strict 'refs';
# spent 110µs making 1 call to strict::unimport
1917µs my @methods = qw(add_trigger call_trigger);
20271µs *{"$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 {
241575µs my $proto = shift;
25
2615226µs15268µs my $triggers = __fetch_triggers($proto);
# spent 268µs making 15 calls to Class::Trigger::__fetch_triggers, avg 18µs/call
2715157µs while (my($when, $code) = splice @_, 0, 2) {
2815230µs15178µs __validate_triggerpoint($proto, $when);
# spent 178µs making 15 calls to Class::Trigger::__validate_triggerpoint, avg 12µs/call
291593µs Carp::croak('add_trigger() needs coderef') unless ref($code) eq 'CODE';
3015197µs push @{$triggers->{$when}}, $code;
31 }
32
3315194µs 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 {
374622.25ms my $self = shift;
384622.26ms my $when = shift;
39
4046223.2ms924437ms 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 {
52231012.8ms my ($obj, $when, $list, $order) = @_;
53231010.8ms my $class = ref $obj || $obj;
5423109.88ms my $return;
55231012.3ms 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).
614622.43ms $list = {};
624622.30ms $order = [];
634622.05ms $return = 1;
64 }
653577µs195µs no strict 'refs';
# spent 95µs making 1 call to strict::unimport
66231022.0ms my @classes = @{$class . '::ISA'};
67231011.7ms push @classes, $class;
68231032.5ms foreach my $c (@classes) {
69554427.6ms next if $list->{$c};
703696110ms369634.0ms if (UNIVERSAL::can($c, 'call_trigger')) {
# spent 34.0ms making 3696 calls to UNIVERSAL::can, avg 9µs/call
71231016.5ms $list->{$c} = [];
72231030.8ms18480s __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;
74231015.1ms if (defined $when && $Triggers{$c}{$when}) {
754622.69ms push @$order, $c;
764622.58ms $list->{$c} = $Triggers{$c}{$when};
77 }
78 }
79 }
80231024.9ms if ($return) {
814622.04ms my @triggers;
824624.33ms foreach my $class (@$order) {
834624.84ms push @triggers, @{ $list->{$class} };
84 }
854624.34ms if (ref $obj && defined $when) {
864623.57ms my $obj_triggers = $obj->{__triggers}{$when};
874622.11ms push @triggers, @$obj_triggers if $obj_triggers;
88 }
894628.33ms 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 {
9415209µ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 {
1011575µs my ($obj, $proto) = @_;
102 # check object based triggers first
10315276µs return ref $obj ? $obj->{__triggers} ||= {} : $Triggers{$obj} ||= {};
104}
105
106113µs1;
107__END__
108
109=head1 NAME
110
111Class::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
146Class::Trigger is a mixin class to add / call triggers (or hooks)
147that get called at some points you specify.
148
149=head1 METHODS
150
151By 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
160Adds triggers for trigger point. You can have any number of triggers
161for each point. Each coderef will be passed a the object reference, and
162return values will be ignored.
163
164If C<add_trigger> is called as object method, whole current trigger
165table will be copied onto the object and the new trigger added to
166that. (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
182Calls triggers for trigger point, which were added via C<add_trigger>
183method. Each triggers will be passed a copy of the object as the first argument.
184Remaining arguments passed to C<call_trigger> will be passed on to each trigger.
185Triggers are invoked in the same order they were defined.
186
187=back
188
189=head1 TRIGGER POINTS
190
191By default you can make any number of trigger points, but if you want
192to declare names of trigger points explicitly, you can do it via
193C<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
204B<Acknowledgement:> Thanks to everyone at POOP mailing-list
205(http://poop.sourceforge.net/).
206
207=over 4
208
209=item Q.
210
211This module lets me add subs to be run before/after a specific
212subroutine is run. Yes?
213
214=item A.
215
216You put various call_trigger() method in your class. Then your class
217users can call add_trigger() method to add subs to be run in points
218just you specify (exactly where you put call_trigger()).
219
220=item Q.
221
222Are you aware of the perl-aspects project and the Aspect module? Very
223similar to Class::Trigger by the look of it, but its not nearly as
224explicit. Its not necessary for foo() to actually say "triggers go
225*here*", you just add them.
226
227=item A.
228
229Yep ;)
230
231But the difference with Aspect would be that Class::Trigger is so
232simple that it's easy to learn, and doesn't require 5.6 or over.
233
234=item Q.
235
236How does this compare to Sub::Versive, or Hook::LexWrap?
237
238=item A.
239
240Very similar. But the difference with Class::Trigger would be the
241explicitness of trigger points.
242
243In addition, you can put hooks in any point, rather than pre or post
244of a method.
245
246=item Q.
247
248It looks interesting, but I just can't think of a practical example of
249its use...
250
251=item A.
252
253(by Tony Bowden)
254
255I originally added code like this to Class::DBI to cope with one
256particular case: auto-upkeep of full-text search indices.
257
258So I added functionality in Class::DBI to be able to trigger an
259arbitary subroutine every time something happened - then it was a
260simple matter of setting up triggers on INSERT and UPDATE to reindex
261that row, and on DELETE to remove that index row.
262
263See L<Class::DBI::mysql::FullTextSearch> and its source code to see it
264in action.
265
266=back
267
268=head1 AUTHOR
269
270Original idea by Tony Bowden E<lt>tony@kasei.comE<gt> in Class::DBI.
271
272Code by Tatsuhiko Miyagawa E<lt>miyagawa@bulknews.netE<gt>.
273
274This library is free software; you can redistribute it and/or modify
275it under the same terms as Perl itself.
276
277=head1 SEE ALSO
278
279L<Class::DBI>
280
281=cut
282
Report produced by the NYTProf 3.11 Perl profiler, developed by Tim Bunce and Adam Kaplan.