File Coverage

blib/lib/Class/C3/Componentised/ApplyHooks.pm

Criterion	Covered	Total	%
statement	62	62	100.0
branch	13	14	92.8
condition			n/a
subroutine	7	7	100.0
pod	2	2	100.0
total	84	85	98.8

package Class::C3::Componentised::ApplyHooks;

use strict;
use warnings;

our %Before;
our %After;

sub BEFORE_APPLY (&) {
  push @{$Before{scalar caller}}, $_[0];
  $Class::C3::Componentised::APPLICATOR_FOR{scalar caller} = __PACKAGE__;
}
sub AFTER_APPLY  (&) {
  push @{$After {scalar caller}}, $_[0];
  $Class::C3::Componentised::APPLICATOR_FOR{scalar caller} = __PACKAGE__;
}

sub _apply_component_to_class {
  my ($me, $comp, $target, $apply) = @_;
  my @heritage = @{mro::get_linear_isa($comp)};

  my @before = map {
     my $to_run = $Before{$_};
     ($to_run?[$_,$to_run]:())
  } @heritage;

  for my $todo (@before) {
     my ($parent, $fn)  = @$todo;
     for my $f (reverse @$fn) {
        $target->$f($parent)
     }
  }

  $apply->();

  my @after = map {
     my $to_run = $After{$_};
     ($to_run?[$_,$to_run]:())
  } @heritage;

  for my $todo (reverse @after) {
     my ($parent, $fn)  = @$todo;
     for my $f (@$fn) {
        $target->$f($parent)
     }
  }
}

{
   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];
            $Class::C3::Componentised::APPLICATOR_FOR{$to} = $from;
         } elsif ($arg eq '-after_apply') {
            $default = 0;
            $skip = 1;
            push @{$After{$to}}, $args[$i + 1];
            $Class::C3::Componentised::APPLICATOR_FOR{$to} = $from;
         } 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 that all C 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