| Subject: | Patch to allow caching of triggers |
Heya,
Walking the @ISA stack on every trigger call can be expensive.
Attached is a patch which provides ->finalize_triggers, which will cache
the triggers for either an object or a class.
- Alex
| Subject: | Class-Trigger.patch |
diff -ruN Class-Trigger-0.12/lib/Class/Trigger.pm Class-Trigger-0.12-modified/lib/Class/Trigger.pm
--- Class-Trigger-0.12/lib/Class/Trigger.pm 2007-08-20 19:08:20.000000000 -0400
+++ Class-Trigger-0.12-modified/lib/Class/Trigger.pm 2007-11-14 09:59:18.000000000 -0500
@@ -16,7 +16,7 @@
# export mixin methods
no strict 'refs';
- my @methods = qw(add_trigger call_trigger last_trigger_results);
+ my @methods = qw(add_trigger call_trigger last_trigger_results finalize_triggers);
*{"$pkg\::$_"} = \&{$_} for @methods;
}
@@ -63,7 +63,21 @@
$result_store->{'_class_trigger_results'} = [];
- if (my @triggers = __fetch_all_triggers($self, $when)) { # any triggers?
+ my @triggers;
+ # Check cache first
+ if (ref $self and $self->{_class_trigger_cache}) {
+ @triggers = @{$self->{_class_trigger_cache}{$when} || []};
+ } elsif (ref $self and ${Class::Trigger::_trigger_cache}->{ref $self}) {
+ @triggers = @{${Class::Trigger::_trigger_cache}->{ref $self}{$when} || []};
+ push @triggers, @{$self->{__triggers}{$when} || []};
+ } elsif (not ref $self and ${Class::Trigger::_trigger_cache}->{$self}) {
+ @triggers = @{${Class::Trigger::_trigger_cache}->{$self}{$when} || []};
+ } else {
+ @triggers = __fetch_all_triggers($self, $when);
+ }
+
+
+ if (@triggers) { # any triggers?
for my $trigger (@triggers) {
my @return = $trigger->[0]->($self, @_);
push @{$result_store->{'_class_trigger_results'}}, \@return;
@@ -80,6 +94,52 @@
return scalar @{$result_store->{'_class_trigger_results'}};
}
+sub __finalize_all_triggers {
+ my($class, $store) = @_;
+ return ${Class::Trigger::_trigger_cache}->{$class}
+ if ${Class::Trigger::_trigger_cache}->{$class};
+
+ $store ||= {};
+ $store->{$class} = {};
+
+ no strict 'refs';
+ my @classes = @{$class . '::ISA'};
+
+ foreach my $c (@classes) {
+ next unless UNIVERSAL::can($c, 'call_trigger');
+
+ # Finalize that class
+ my $t = $store->{$c} || __finalize_all_triggers($c, $store);
+
+ # Push its final'd ones onto ours
+ for my $when (keys %{$t}) {
+ push @{$store->{$class}{$when}}, @{$t->{$when}};
+ }
+ }
+
+ # Add self triggers to cache
+ for my $when (keys %{$Triggers{$class}}) {
+ push @{$store->{$class}{$when}}, @{$Triggers{$class}{$when}};
+ }
+
+ return $store->{$class};
+}
+
+sub finalize_triggers {
+ my $obj = shift;
+
+ if (ref $obj) {
+ $obj->{_class_trigger_cache} = __finalize_all_triggers(ref $obj);
+ for my $when (keys %{$obj->{__triggers} || {}}) {
+ push @{$obj->{_class_trigger_cache}{$when}}, @{$obj->{__triggers}{$when}};
+ }
+ return $obj->{_class_trigger_cache};
+ } else {
+ ${Class::Trigger::_trigger_cache}->{$obj} = __finalize_all_triggers($obj);
+ return ${Class::Trigger::_trigger_cache}->{$obj};
+ }
+}
+
sub __fetch_all_triggers {
my ($obj, $when, $list, $order) = @_;
my $class = ref $obj || $obj;
@@ -248,6 +308,17 @@
for the last trigger point. Results are ordered in the same order the triggers
were run.
+=item finalize_triggers
+
+ Foo->finalize_triggers;
+
+Inspecting the inheritance tree to determine all of the possible
+triggers on a class (as call_trigger does) can add up. Calling this
+method will inspect and cache the set of triggers, saving this time
+later. This method can be called on a class, or on an instance. If
+called on a class, triggers can still be added to instances of the
+class, and will still be respected. If called on an instance, it only
+finalizes that instance, not the entire class.
=back
diff -ruN Class-Trigger-0.12/t/04_object.t Class-Trigger-0.12-modified/t/04_object.t
--- Class-Trigger-0.12/t/04_object.t 2006-03-18 06:48:00.000000000 -0500
+++ Class-Trigger-0.12-modified/t/04_object.t 2007-11-13 19:22:27.000000000 -0500
@@ -1,5 +1,5 @@
use strict;
-use Test::More tests => 5;
+use Test::More tests => 6;
use IO::Scalar;
@@ -37,6 +37,14 @@
{
my $foo = Foo->new;
tie *STDOUT, 'IO::Scalar', \my $out;
+ $foo->add_trigger(before_foo => sub { print "before_foo1\n" });
+ $foo->foo;
+ is $out, "before_foo\nbefore_foo1\nfoo\n";
+}
+
+{
+ my $foo = Foo->new;
+ tie *STDOUT, 'IO::Scalar', \my $out;
$foo->foo;
is $out, "before_foo\nfoo\n";
}
diff -ruN Class-Trigger-0.12/t/09_finalize.t Class-Trigger-0.12-modified/t/09_finalize.t
--- Class-Trigger-0.12/t/09_finalize.t 1969-12-31 19:00:00.000000000 -0500
+++ Class-Trigger-0.12-modified/t/09_finalize.t 2007-11-13 19:42:29.000000000 -0500
@@ -0,0 +1,72 @@
+use strict;
+use Test::More tests => 12;
+
+use IO::Scalar;
+
+use lib 't/lib';
+use Foo;
+use Foo::Bar;
+
+ok(Foo->add_trigger(before_foo => sub { print "before_foo\n" }),
+ 'add_trigger in Foo');
+ok(Foo::Bar->add_trigger(after_foo => sub { print "after_foo\n" }),
+ 'add_trigger in Foo::Bar');
+ok(Foo::Bar->add_trigger(before_foo => sub { print "before_foo2\n" }),
+ 'add_trigger in Foo::Bar');
+ok(Foo->add_trigger(before_foo => sub { print "before_foo3\n" }),
+ 'add_trigger in Foo');
+
+{
+ my $foo = Foo::Bar->new;
+ tie *STDOUT, 'IO::Scalar', \my $pre;
+ $foo->foo;
+ is $pre, "before_foo\nbefore_foo3\nbefore_foo2\nfoo\nafter_foo\n";
+
+ Foo::Bar->finalize_triggers;
+
+ tie *STDOUT, 'IO::Scalar', \my $post;
+ $foo->foo;
+ is $post, $pre;
+}
+
+{
+ my $foo = Foo::Bar->new;
+ $foo->add_trigger(before_foo => sub { print "before_foo4\n" });
+
+ tie *STDOUT, 'IO::Scalar', \my $pre;
+ $foo->foo;
+ is $pre, "before_foo\nbefore_foo3\nbefore_foo2\nbefore_foo4\nfoo\nafter_foo\n";
+
+ $foo->finalize_triggers;
+
+ tie *STDOUT, 'IO::Scalar', \my $post;
+ $foo->foo;
+ is $post, $pre;
+}
+
+{
+ my $foo_parent = Foo->new;
+ tie *STDOUT, 'IO::Scalar', \my $pre;
+ $foo_parent->foo;
+ is $pre, "before_foo\nbefore_foo3\nfoo\n", 'Foo not affected';
+
+ Foo->finalize_triggers;
+
+ tie *STDOUT, 'IO::Scalar', \my $post;
+ $foo_parent->foo;
+ is $post, $pre;
+}
+
+{
+ my $foo_parent = Foo->new;
+ $foo_parent->add_trigger(before_foo => sub { print "before_foo4\n" });
+ tie *STDOUT, 'IO::Scalar', \my $pre;
+ $foo_parent->foo;
+ is $pre, "before_foo\nbefore_foo3\nbefore_foo4\nfoo\n", 'Foo not affected';
+
+ $foo_parent->finalize_triggers;
+
+ tie *STDOUT, 'IO::Scalar', \my $post;
+ $foo_parent->foo;
+ is $post, $pre;
+}