File Coverage

blib/lib/Attribute/Contract.pm

Criterion	Covered	Total	%
statement	103	107	96.2
branch	24	32	75.0
condition	3	3	100.0
subroutine	22	23	95.6
pod	0	4	0.0
total	152	169	89.9

package Attribute::Contract;

use strict;
use warnings;

use 5.012;
use attributes;

our $VERSION = '0.05';

use constant NO_ATTRIBUTE_CONTRACT => $ENV{NO_ATTRIBUTE_CONTRACT};

use Scalar::Util qw(refaddr);

use Attribute::Contract::Modifier::Requires;
use Attribute::Contract::Modifier::Ensures;

BEGIN {
    use Exporter ();
    our (@ISA, @EXPORT);

    @ISA    = qw(Exporter);
    @EXPORT = qw(&MODIFY_CODE_ATTRIBUTES &FETCH_CODE_ATTRIBUTES);
}

our $CONTRACT_REQUIRES_ATTR_ALIAS = 'ContractRequires';
our $CONTRACT_ENSURES_ATTR_ALIAS  = 'ContractEnsures';

my %attrs;
my %modifiers;
my %symcache;
my %todo;
my %import;

sub contract_requires_name {
    $import{-names}->{requires} || $CONTRACT_REQUIRES_ATTR_ALIAS;
}

sub contract_ensures_name {
    $import{-names}->{ensures} || $CONTRACT_ENSURES_ATTR_ALIAS;
}

sub contract_attr_re {
    my $requires_name = contract_requires_name();
    my $ensures_name = contract_ensures_name();

    return qr/
        ^
        ($requires_name|$ensures_name)
        (?:\((.*?)\))?
        $
    /x;
}

sub import {
    return if NO_ATTRIBUTE_CONTRACT;

    my ($package) = caller;
    $todo{$package}++;

    shift;
    %import = @_;

    __PACKAGE__->export_to_level(1);
}

sub CHECK {
    return if NO_ATTRIBUTE_CONTRACT;

    foreach my $package (keys %todo) {
        foreach my $key (keys %modifiers) {
            my ($class, $method) = split /::/, $key;
            next unless $package->isa($class);

            next unless my $code_ref = $package->can($method);

            my $attrs = $modifiers{$key};

            foreach my $attr (@$attrs) {
                next unless $attr =~ contract_attr_re();

                attributes::->import($package, $code_ref, $attr);
            }
        }
    }
}

sub FETCH_CODE_ATTRIBUTES {
    my ($package, $subref) = @_;

    my $attrs = $attrs{refaddr $subref };

    return @$attrs;
}

sub MODIFY_CODE_ATTRIBUTES {
    my ($package, $code_ref, @attr) = @_;

    my $sym = findsym($package, $code_ref);
    my $name = *{$sym}{NAME};

    return if exists $attrs{refaddr $code_ref };
    return if exists $modifiers{"$package\::$name"};

    $attrs{refaddr $code_ref } = \@attr;
    $modifiers{"$package\::$name"} = \@attr;

    if (@attr) {
        no strict;
        my @isa = @{"$package\::ISA"};
        use strict;
        foreach my $isa (@isa) {
            my $key = "$isa\::$name";
            if (exists $modifiers{$key}) {

                my $base_contract = $modifiers{$key};
                my $contract = $modifiers{"$package\::$name"};

                if (@$base_contract == @$contract) {
                    next
                      if join(',', sort @$base_contract) eq
                          join(',', sort @$contract);
                }

                Carp::croak(qq{Changing contract of method '$name'}
                      . qq{ in $package is not allowed});
            }
        }
    }

    no warnings 'redefine';
    foreach my $attr (@attr) {
        next unless $attr =~ contract_attr_re();

        my $type      = $1;
        my $arguments = $2;

        my $modifier = $type eq contract_requires_name() ? 'Requires' : 'Ensures';

        my $class = __PACKAGE__ . '::Modifier::' . $modifier;

        *{$sym} = $class->modify($package, $name, $code_ref, \%import, $arguments);
    }

    return ();
}

# From Attribute::Handlers
sub findsym {
    my ($package, $ref) = @_;

    return $symcache{$package, $ref} if $symcache{$package, $ref};

    my $type = ref($ref);

    no strict 'refs';
    foreach my $sym (values %{$package . "::"}) {
        use strict;
        next unless ref(\$sym) eq 'GLOB';

        return $symcache{$package, $ref} = \$sym
          if *{$sym}{$type} && *{$sym}{$type} == $ref;
    }

    return;
}

1;
__END__