Add Class::C3::Componetised::ApplyHooks features

diff --git a/Changes b/Changes
index f081bcd..0bf2ddb 100644 (file)
--- a/Changes
+++ b/Changes
@@ -1,5 +1,7 @@
 Revision history for Class-C3-Componentised
 
+      - Add Class::C3::Componentised::ApplyHooks features
+
 1.0009   20 Mar 2011
       - Stop importing Carp functions (and thus polluting the inheritor
         namespaces)

diff --git a/lib/Class/C3/Componentised.pm b/lib/Class/C3/Componentised.pm
index 58f9f2b..a5c3b99 100644 (file)
--- a/lib/Class/C3/Componentised.pm
+++ b/lib/Class/C3/Componentised.pm
@@ -188,13 +188,40 @@ sub inject_base {
   my $class = shift;
   my $target = shift;
 
-  for (reverse @_) {
+  mro::set_mro($target, 'c3');
+
+  for my $comp (reverse @_) {
     no strict 'refs';
-    unshift ( @{"${target}::ISA"}, $_ )
-      unless ($target eq $_ || $target->isa($_));
-  }
+    unless ($target eq $comp || $target->isa($comp)) {
+      my @heritage = @{mro::get_linear_isa($comp)};
+
+      my @before = map {
+         my $to_run = $Class::C3::Componentised::ApplyHooks::Before{$_};
+         ($to_run?[$_,$to_run]:())
+      } @heritage;
+
+      for my $todo (@before) {
+         my ($parent, $fn)  = @$todo;
+         for my $f (reverse @$fn) {
+            $target->$f($parent)
+         }
+      }
 
-  mro::set_mro($target, 'c3');
+      unshift ( @{"${target}::ISA"}, $comp );
+
+      my @after = map {
+         my $to_run = $Class::C3::Componentised::ApplyHooks::After{$_};
+         ($to_run?[$_,$to_run]:())
+      } @heritage;
+
+      for my $todo (reverse @after) {
+         my ($parent, $fn)  = @$todo;
+         for my $f (@$fn) {
+            $target->$f($parent)
+         }
+      }
+    }
+  }
 }
 
 =head2 load_optional_class

diff --git a/lib/Class/C3/Componentised/ApplyHooks.pm b/lib/Class/C3/Componentised/ApplyHooks.pm
new file mode 100644 (file)
index 0000000..6eb8bec
--- /dev/null
+++ b/lib/Class/C3/Componentised/ApplyHooks.pm
@@ -0,0 +1,117 @@
+package Class::C3::Componentised::ApplyHooks;
+
+use strict;
+use warnings;
+
+our %Before;
+our %After;
+
+sub BEFORE_APPLY (&) { push @{$Before{scalar caller}}, $_[0] };
+sub AFTER_APPLY  (&) { push @{$After {scalar caller}}, $_[0] };
+
+{
+   no strict 'refs';
+   sub import {
+      my ($from, @args) = @_;
+      my $to = caller;
+
+      my $default = 1;
+      my $i = 0;
+      my $skip = 0;
+      my @import;
+      for my $arg (@args) {
+         if ($skip) {
+            $skip--;
+            $i++;
+            next
+         }
+
+         if ($arg eq '-before_apply') {
+            $default = 0;
+            $skip = 1;
+            push @{$Before{$to}}, $args[$i + 1]
+         } elsif ($arg eq '-after_apply') {
+            $default = 0;
+            $skip = 1;
+            push @{$After{$to}}, $args[$i + 1];
+         } elsif ($arg =~ /^BEFORE_APPLY|AFTER_APPLY$/) {
+            $default = 0;
+            push @import, $arg
+         }
+         $i++;
+      }
+      @import = qw(BEFORE_APPLY AFTER_APPLY)
+         if $default;
+
+      *{"$to\::$_"} = \&{"$from\::$_"} for @import
+   }
+}
+
+1;
+
+=head1 NAME
+
+Class::C3::Componentised::ApplyHooks
+
+=head1 SYNOPSIS
+
+ package MyComponent;
+
+ our %statistics;
+
+ use Class::C3::Componentised::ApplyHooks
+   -before_apply => sub {
+     my ($class, $component) = @_;
+
+     push @{$statistics{$class}}, '-before_apply';
+   },
+   -after_apply  => sub {
+     my ($class, $component) = @_;
+
+     push @{$statistics{$class}}, '-after_apply';
+   }, qw(BEFORE_APPLY AFTER_APPLY);
+
+ BEFORE_APPLY { push @{$statistics{$class}}, 'BEFORE_APPLY' };
+ AFTER_APPLY { push @{$statistics{$class}}, 'AFTER_APPLY' };
+ AFTER_APPLY { use Devel::Dwarn; Dwarn %statistics };
+
+ 1;
+
+=head1 DESCRIPTION
+
+This package allows a given component to run methods on the class that is being
+injected into before or after the component is injected.  Note from the 
+L</SYNOPSIS> that all C<Load Actions> may be run more than once.
+
+=head1 IMPORT ACTION
+
+Both import actions simply run a list of coderefs that will be passed the class
+that is being acted upon and the component that is being added to the class.
+
+=head1 IMPORT OPTIONS
+
+=head2 -before_apply
+
+Adds a before apply action for the current component without importing
+any subroutines into your namespace.
+
+=head2 -after_apply
+
+Adds an after apply action for the current component without importing
+any subroutines into your namespace.
+
+=head1 EXPORTED SUBROUTINES
+
+=head2 BEFORE_APPLY
+
+ BEFORE_APPLY { warn "about to apply $_[1] to class $_[0]"  };
+
+Adds a before apply action for the current component.
+
+=head2 AFTER_APPLY
+
+ AFTER_APPLY { warn "just applied $_[1] to class $_[0]"  };
+
+Adds an after apply action for the current component.
+
+=cut

diff --git a/t/03-on-apply.t b/t/03-on-apply.t
new file mode 100644 (file)
index 0000000..79b3c69
--- /dev/null
+++ b/t/03-on-apply.t
@@ -0,0 +1,65 @@
+use strict;
+use warnings;
+
+use FindBin;
+use Test::More;
+use Test::Exception;
+
+use lib "$FindBin::Bin/lib";
+
+my $awesome_robot = 0;
+my $first = 0;
+my $last = 0;
+
+BEGIN {
+  package MyModule::Plugin::TestActions;
+
+  use Class::C3::Componentised::ApplyHooks;
+
+  BEFORE_APPLY { $awesome_robot++; $first = $awesome_robot };
+  BEFORE_APPLY { $awesome_robot++; $first = $awesome_robot };
+  AFTER_APPLY  { $awesome_robot++;  $last  = $awesome_robot };
+
+  1;
+}
+
+BEGIN {
+  package MyModule::Plugin::TestActionDie;
+
+  use Class::C3::Componentised::ApplyHooks
+    -before_apply => sub { die 'this component is not applicable (yuk yuk yuk)' };
+
+  1;
+}
+
+BEGIN {
+  package MyModule::Plugin::TestActionLoadFrew;
+
+  use Class::C3::Componentised::ApplyHooks;
+
+  BEFORE_APPLY { $_[0]->load_components('TestActionFrew') };
+
+  1;
+}
+
+BEGIN {
+  package MyModule::Plugin::TestActionFrew;
+  sub frew { 1 }
+  1;
+}
+
+use_ok('MyModule');
+is( $first, 0, 'first starts at zero' );
+is( $last, 0, 'last starts at zero' );
+
+MyModule->load_components('TestActions');
+is( $first, 2, 'first gets value of 1 (it runs first)' );
+is( $last, 3, 'last gets value of 2 (it runs last)' );
+
+dies_ok { MyModule->load_components('TestActionDie') } 'die from BEFORE_APPLY works';
+
+dies_ok { MyModule->frew } 'fREW is not loaded';
+MyModule->load_components('TestActionLoadFrew');
+is( MyModule->frew, 1, 'fREW is loaded' );
+
+done_testing;

diff --git a/t/04-on-apply-use-base.t b/t/04-on-apply-use-base.t
new file mode 100644 (file)
index 0000000..3d6a510
--- /dev/null
+++ b/t/04-on-apply-use-base.t
@@ -0,0 +1,105 @@
+use strict;
+use warnings;
+
+use FindBin;
+use Test::More;
+use Test::Exception;
+
+use lib "$FindBin::Bin/lib";
+
+BEGIN {
+  package A::First;
+
+  use Class::C3::Componentised::ApplyHooks;
+
+  AFTER_APPLY { $_[0]->after("a $_[1]") };
+  AFTER_APPLY { $_[0]->after("b $_[1]") };
+  BEFORE_APPLY { $_[0]->before("a $_[1]") };
+  BEFORE_APPLY { $_[0]->before("b $_[1]") };
+
+  1;
+}
+
+BEGIN {
+  package A::Second;
+
+  use base 'A::First';
+
+  use Class::C3::Componentised::ApplyHooks
+    -after_apply => sub { $_[0]->after("a $_[1]") },
+    -before_apply => sub { $_[0]->before("a $_[1]") },
+    qw(BEFORE_APPLY AFTER_APPLY);
+
+  AFTER_APPLY { $_[0]->after("b $_[1]") };
+  BEFORE_APPLY { $_[0]->before("b $_[1]") };
+  1;
+}
+
+
+BEGIN {
+  package A::Third;
+
+  use base 'A::Second';
+
+  1;
+}
+
+BEGIN {
+  package A::Class::Second;
+
+  use base 'Class::C3::Componentised';
+  use Test::More;
+
+  our @before;
+  our @after;
+
+  sub component_base_class { 'A' }
+  __PACKAGE__->load_components('Second');
+
+  sub before { push @before, $_[1] }
+  sub after { push @after, $_[1] }
+
+  is_deeply(\@before, [
+    'b A::Second',
+    'a A::Second',
+    'b A::First',
+    'a A::First',
+  ], 'before runs in the correct order');
+  is_deeply(\@after, [
+    'a A::First',
+    'b A::First',
+    'a A::Second',
+    'b A::Second',
+  ], 'after runs in the correct order');
+}
+
+BEGIN {
+  package A::Class::Third;
+
+  use base 'Class::C3::Componentised';
+  use Test::More;
+
+  our @before;
+  our @after;
+
+  sub component_base_class { 'A' }
+  __PACKAGE__->load_components('Third');
+
+  sub before { push @before, $_[1] }
+  sub after { push @after, $_[1] }
+
+  is_deeply(\@before, [
+    'b A::Second',
+    'a A::Second',
+    'b A::First',
+    'a A::First',
+  ], 'before runs in the correct order');
+  is_deeply(\@after, [
+    'a A::First',
+    'b A::First',
+    'a A::Second',
+    'b A::Second',
+  ], 'after runs in the correct order');
+}
+
+done_testing;