File Coverage

blib/lib/Sub/Attributes.pm

Criterion	Covered	Total	%
statement	63	80	78.7
branch	10	12	83.3
condition	7	14	50.0
subroutine	12	12	100.0
pod	1	1	100.0
total	93	119	78.1

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.04 }

# 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 %allowed = (
    # runtime check that caller is the package
    Private => sub {
      my ($package) = @_;
      return sub {
        my ($coderef, @args) = @_;
        my ($package_caller, $filename, $line, $sub) = caller(2);
        croak 'Only the object may call this sub' unless $sub && $sub =~ /^$package\:\:/;
        $coderef->(@args);
      };
    },
    # runtime check that the first arg is the package
    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 ($package, $value, $coderef) = @_;

      # full name of the sub to override
      my $fq_sub = "$package:\:$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 ($package, $value, $coderef) = @_;

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

      my $target_coderef = \&{$fq_sub};
      *{$fq_sub} = sub {
        my @rv = $target_coderef->(@_);
        $coderef->(@_);
        return wantarray ? @rv : $rv[0];
      };

      # 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 ($package, $value, $coderef) = @_;

      # full name of the sub to override
      my $fq_sub = "$package:\:\$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 ($package, $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->($package, $value, $coderef);
    next unless $override_coderef;

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

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

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