File Coverage

blib/lib/Boundary.pm

Criterion	Covered	Total	%
statement	56	56	100.0
branch	16	16	100.0
condition	2	2	100.0
subroutine	12	12	100.0
pod	0	5	0.0
total	86	91	94.5

package Boundary;
use strict;
use warnings;

use namespace::allclean ();
use Class::Load qw(try_load_class);

our $VERSION = "0.01";

our %INFO;

sub import {
    my $class = shift;
    my $target = scalar caller;

    my $requires = $class->gen_requires($target);
    {
        no strict 'refs';
        *{"${target}::requires"} = $requires;
    }

    namespace::allclean->import(
        -cleanee => $target,
    );

    return;
}


our $CROAK_MESSAGE_SUFFIX;
sub croak {
  require Carp;
  push @_ => $CROAK_MESSAGE_SUFFIX if $CROAK_MESSAGE_SUFFIX;
  goto &Carp::croak;
}

sub gen_requires {
    my ($class, $target) = @_;
    sub {
        my @methods = @_;
        push @{$INFO{$target}{requires}||=[]} => @methods;
        return;
    }
}

sub assert_requires {
    my ($class, $impl, $interface) = @_;
    croak "Not found interface info. $interface" if !$INFO{$interface};

    my @requires = @{$INFO{$interface}{requires}};
    return if !@requires;

    if (my @requires_fail = grep { !$impl->can($_) } @requires) {
        croak "Can't apply ${interface} to ${impl} - missing ". join(', ', @requires_fail);
    }
    return;
}

sub apply_interfaces_to_package {
    my ($class, $impl, @interfaces) = @_;
    croak "No interfaces supplied!" unless @interfaces;

    for my $interface (@interfaces) {
        my ($ok, $e) = try_load_class($interface);
        croak("cannot load interface package: $e") if !$ok;

        $class->assert_requires($impl, $interface);
    }
    $INFO{$impl}{interface_map}{$_} = 1 for @interfaces;
    return;
}

sub check_implementations {
    my ($class, $impl, @interfaces) = @_;
    return if !$INFO{$impl};
    my %interface_map = %{$INFO{$impl}{interface_map}};
    for (@interfaces) {
        return if !$interface_map{$_}
    }
    return !!1;
}

1;
__END__