lib/Class/C3/Componentised/ApplyHooks.pm

   1 package Class::C3::Componentised::ApplyHooks;
   2
   3 use strict;
   4 use warnings;
   5
   6 our %Before;
   7 our %After;
   8
   9 sub BEFORE_APPLY (&) {
  10   push @{$Before{scalar caller}}, $_[0];
  11   $Class::C3::Componentised::APPLICATOR_FOR{scalar caller} = __PACKAGE__;
  12 }
  13 sub AFTER_APPLY  (&) {
  14   push @{$After {scalar caller}}, $_[0];
  15   $Class::C3::Componentised::APPLICATOR_FOR{scalar caller} = __PACKAGE__;
  16 }
  17
  18 sub _apply_component_to_class {
  19   my ($me, $comp, $target, $apply) = @_;
  20   my @heritage = @{mro::get_linear_isa($comp)};
  21
  22   my @before = map {
  23      my $to_run = $Before{$_};
  24      ($to_run?[$_,$to_run]:())
  25   } @heritage;
  26
  27   for my $todo (@before) {
  28      my ($parent, $fn)  = @$todo;
  29      for my $f (reverse @$fn) {
  30         $target->$f($parent)
  31      }
  32   }
  33
  34   $apply->();
  35
  36   my @after = map {
  37      my $to_run = $After{$_};
  38      ($to_run?[$_,$to_run]:())
  39   } @heritage;
  40
  41   for my $todo (reverse @after) {
  42      my ($parent, $fn)  = @$todo;
  43      for my $f (@$fn) {
  44         $target->$f($parent)
  45      }
  46   }
  47 }
  48
  49 {
  50    no strict 'refs';
  51    sub import {
  52       my ($from, @args) = @_;
  53       my $to = caller;
  54
  55       my $default = 1;
  56       my $i = 0;
  57       my $skip = 0;
  58       my @import;
  59       for my $arg (@args) {
  60          if ($skip) {
  61             $skip--;
  62             $i++;
  63             next
  64          }
  65
  66          if ($arg eq '-before_apply') {
  67             $default = 0;
  68             $skip = 1;
  69             push @{$Before{$to}}, $args[$i + 1];
  70             $Class::C3::Componentised::APPLICATOR_FOR{$to} = $from;
  71          } elsif ($arg eq '-after_apply') {
  72             $default = 0;
  73             $skip = 1;
  74             push @{$After{$to}}, $args[$i + 1];
  75             $Class::C3::Componentised::APPLICATOR_FOR{$to} = $from;
  76          } elsif ($arg =~ /^BEFORE_APPLY|AFTER_APPLY$/) {
  77             $default = 0;
  78             push @import, $arg
  79          }
  80          $i++;
  81       }
  82       @import = qw(BEFORE_APPLY AFTER_APPLY)
  83          if $default;
  84
  85       *{"$to\::$_"} = \&{"$from\::$_"} for @import
  86    }
  87 }
  88
  89 1;
  90
  91 =head1 NAME
  92
  93 Class::C3::Componentised::ApplyHooks - Run methods before or after components are injected
  94
  95 =head1 SYNOPSIS
  96
  97  package MyComponent;
  98
  99  our %statistics;
 100
 101  use Class::C3::Componentised::ApplyHooks
 102    -before_apply => sub {
 103      my ($class, $component) = @_;
 104
 105      push @{$statistics{$class}}, '-before_apply';
 106    },
 107    -after_apply  => sub {
 108      my ($class, $component) = @_;
 109
 110      push @{$statistics{$class}}, '-after_apply';
 111    }, qw(BEFORE_APPLY AFTER_APPLY);
 112
 113  BEFORE_APPLY { push @{$statistics{$class}}, 'BEFORE_APPLY' };
 114  AFTER_APPLY { push @{$statistics{$class}}, 'AFTER_APPLY' };
 115  AFTER_APPLY { use Devel::Dwarn; Dwarn %statistics };
 116
 117  1;
 118
 119 =head1 DESCRIPTION
 120
 121 This package allows a given component to run methods on the class that is being
 122 injected into before or after the component is injected.  Note from the
 123 L</SYNOPSIS> that all C<Load Actions> may be run more than once.
 124
 125 =head1 IMPORT ACTION
 126
 127 Both import actions simply run a list of coderefs that will be passed the class
 128 that is being acted upon and the component that is being added to the class.
 129
 130 =head1 IMPORT OPTIONS
 131
 132 =head2 -before_apply
 133
 134 Adds a before apply action for the current component without importing
 135 any subroutines into your namespace.
 136
 137 =head2 -after_apply
 138
 139 Adds an after apply action for the current component without importing
 140 any subroutines into your namespace.
 141
 142 =head1 EXPORTED SUBROUTINES
 143
 144 =head2 BEFORE_APPLY
 145
 146  BEFORE_APPLY { warn "about to apply $_[1] to class $_[0]"  };
 147
 148 Adds a before apply action for the current component.
 149
 150 =head2 AFTER_APPLY
 151
 152  AFTER_APPLY { warn "just applied $_[1] to class $_[0]"  };
 153
 154 Adds an after apply action for the current component.
 155
 156 =cut