File Coverage

blib/lib/Sub/Attributes.pm

Criterion	Covered	Total	%
statement	51	83	61.4
branch	8	10	80.0
condition	6	11	54.5
subroutine	10	12	83.3
pod	1	1	100.0
total	76	117	64.9

package Sub::Attributes;
use strict;
use warnings;

# voodoo
no strict 'refs';
no warnings qw(reserved redefine);

use B 'svref_2object';
use Carp 'croak';

BEGIN { our $VERSION = 0.02 }

# these data structures are key to this module. They're created in a BEGIN block
# as package variables so they're available when MODIFY_CODE_ATTRIBUTES is
# called:
#
#   %attributes is a hash of subroutine names and their attributes
#   %allowed is a hash of recognized subroutine attributes with a coderef for
#   the behavior
#
# You can relace/extend %allowed in an inherited class to provide your own behavior!
BEGIN {
  our %attributes = ();
  our %allowed = (
    # runtime check that caller is the class
    Private => sub {
      my ($class) = @_;
      return sub {
        my ($coderef, @args) = @_;
        my ($package, $filename, $line, $sub) = caller(2);
        croak 'Only the object may call this sub' unless $sub && $sub =~ /^$class\:\:/;
        $coderef->(@args);
      };
    },
    # runtime check that the first arg is the class
    ClassMethod => sub {
      return sub {
        my ($coderef, @args) = @_;
        croak 'Class method called as function / object method'
          unless $args[0] && exists $Sub::Attributes::attributes{ $args[0] };
        $coderef->(@args);
      };
    },
    # runtime check that the first arg is the object
    Method => sub {
      return sub {
        my ($coderef, @args) = @_;
        croak 'Method called as function'
          unless $args[0] && exists $Sub::Attributes::attributes{ ref $args[0] };
        $coderef->(@args);
      };
    },
    # compile time override, run a coderef before running the subroutine
    Before => sub {
      my ($class, $value, $coderef) = @_;

      # full name of the sub to override
      my $fq_sub = "$class:\:$value";

      my $target_coderef = \&{$fq_sub};
      *{$fq_sub} = sub {
        $coderef->(@_);
        $target_coderef->(@_);
      };

      # we didn't change the method with the attribute
      # so we return undef as we have no runtime changes
      return undef;
    },
    # compile time override, run a coderef after running the subroutine
    After => sub {
      my ($class, $value, $coderef) = @_;

      # full name of the sub to override
      my $fq_sub = "$class:\:$value";

      my $target_coderef = \&{$fq_sub};
      *{$fq_sub} = sub {
        my @rv = $target_coderef->(@_);
        return $coderef->(@_);
      };

      # we didn't change the method with the attribute
      # so we return undef as we have no runtime changes
      return undef;
    },
    # compile time override, run a coderef around running the subroutine
    Around => sub {
      my ($class, $value, $coderef) = @_;

      # full name of the sub to override
      my $fq_sub = "$class:\:\$value";

      my $target_coderef = \&{$fq_sub};
      *{$fq_sub} = sub {
        $coderef->($target_coderef, @_);
      };

      # we didn't change the method with the attribute
      # so we return undef as we have no runtime changes
      return undef;
    },
  );
}

# this is the registrar for subroutine attributes called at compile time
sub MODIFY_CODE_ATTRIBUTES {
  my ($class, $coderef, @attributes, @disallowed) = @_;

  my $obj = svref_2object($coderef);
  my $subroutine = $obj->GV->NAME;

  for my $attribute (@attributes) {
    # parse the attribute into name and value
    my ($name, $value) = $attribute =~ qr/^ (\w+) (?:\((\S+?)\))? $/x;
    my $overrider = $Sub::Attributes::allowed{$name};

    # attribute not known, compile error
    push(@disallowed, $name) && next unless $overrider;

    # make compile time changes, skip ahead if no runtime changes
    my $override_coderef = $overrider->($class, $value, $coderef);
    next unless $override_coderef;

    # override subroutine with attribute coderef
    my $old_coderef = $coderef;
    $coderef = sub { $override_coderef->($old_coderef, @_) };
    *{"$class:\:$subroutine"} = $coderef;
  }

  $Sub::Attributes::attributes{$class}{ $subroutine } = \@attributes;
  return @disallowed;
};

# this is to support attributes::get from attributes.pm
sub FETCH_CODE_ATTRIBUTES {
  my ($class, $coderef) = @_;
  my $cv = svref_2object($coderef);
  return @{$Sub::Attributes::attributes{$class}{ $cv->GV->NAME }};
}

sub sub_attributes {
  my ($class) = @_;
  return $Sub::Attributes::attributes{ ref $class };
}
1;
__END__