File Coverage

blib/lib/Contract/Declare.pm

Criterion	Covered	Total	%
statement	76	77	98.7
branch	20	24	83.3
condition	5	6	83.3
subroutine	15	15	100.0
pod	4	4	100.0
total	120	126	95.2

package Contract::Declare;

use v5.14;
use Exporter 'import';
use Role::Tiny ();
use Scalar::Util qw(blessed);
use Carp;


our @EXPORT = qw(contract interface method returns);

our $CURRENT_PKG;
my %REGISTRY;

our $VERSION = '1.0.0';


sub contract {
    local $CURRENT_PKG;
    my $block;
    ($CURRENT_PKG, $block) = @_;
    $block->();
    _build_contract($CURRENT_PKG, $REGISTRY{$CURRENT_PKG});
    delete $REGISTRY{$CURRENT_PKG} unless $ENV{CONTRACT_DECLARE_KEEP_CONTRACT};
}

sub interface (&) { shift }
sub returns       { [ @_ ] }

sub method {
    my ($name, @parts) = @_;
    my (@in, $out);

    for my $p (@parts) {
        if (ref($p) eq 'ARRAY') {
            $out = $p;
            last;
        }
        push @in, $p;
    }

    for my $arg (@in) {
        croak "Contract violation: input argument for method '$name' must be an object with 'compiled_check'"
            unless blessed($arg) && $arg->can('compiled_check');
    }

    if ($out) {
        croak "Contract violation: return type for method '$name' must be an arrayref"
            unless ref($out) eq 'ARRAY';

        for my $ret (@$out) {
            croak "Contract violation: each return type for method '$name' must be an object with 'compiled_check'"
                unless blessed($ret) && $ret->can('compiled_check');
        }
    }

    $REGISTRY{$CURRENT_PKG}{$name} = [ \@in, $out ];
}

sub _build_contract {
    my ($pkg, $contract) = @_;

    no strict 'refs';

    *{"${pkg}::new"} = sub {
        my ($class, $impl) = @_;
        my %cache;

        for my $method (keys %$contract) {
            my $code = $impl->can($method);
            croak "Contract violation: Implementation does not provide method '$method' for interface '$pkg'" unless $code;
            $cache{$method} = $code;
        }

        bless {
            _impl  => $impl,
            _cache => \%cache,
        }, $pkg;
    };

    for my $method (keys %$contract) {
        my ($in_rules, $out_rules) = @{$contract->{$method}};
        my @in_checks  = map { $_->compiled_check } @$in_rules;
        my @out_checks = map { $_->compiled_check } @$out_rules;

        *{"${pkg}::$method"} = sub {
            my ($self, @args) = @_;

            _validate(\@args, \@in_checks, "$pkg\::$method args");

            my @res = $self->{_cache}{$method}->($self->{_impl}, @args);

            _validate(\@res, \@out_checks, "$pkg\::$method return");

            return wantarray ? @res : $res[0];
        };
    }

    Role::Tiny->make_role($pkg);
    $Role::Tiny::INFO{$pkg}{requires} = [ sort keys %$contract ];

    use strict 'refs';
}

sub _validate {
    my ($values, $checkers, $label) = @_;

    return if @$checkers == 0;

    if (@$values != @$checkers) {
        croak "Contract violation in $label: expected " . scalar(@$checkers) . " argument(s), got " . scalar(@$values);
    }

    for (my $i = 0; $i < @$checkers; $i++) {
        next if $checkers->[$i]->($values->[$i]);
        my $val = defined($values->[$i]) ? "'$values->[$i]'" : 'undef';
        croak "Contract violation in $label: argument #$i ($val) failed type check";
    }
}

1;

__END__