File Coverage

blib/lib/kura.pm

Criterion	Covered	Total	%
statement	85	86	98.8
branch	31	34	91.1
condition	4	7	57.1
subroutine	28	29	96.5
pod	0	2	0.0
total	148	158	93.6

package kura;
use strict;
use warnings;

our $VERSION = "0.10";

use Carp ();
use Sub::Util ();
use Scalar::Util ();

my %FORBIDDEN_NAME = map { $_ => 1 } qw{
    BEGIN CHECK DESTROY END INIT UNITCHECK
    AUTOLOAD STDIN STDOUT STDERR ARGV ARGVOUT ENV INC SIG
};

my @ALLOWED_CONSTRAINT_CLASSES = qw(
    Data::Validator
    Poz::Types
);

sub import {
    my $pkg = shift;
    my $caller = caller;

    $pkg->import_into($caller, @_);
}

# Import into the caller package.
sub import_into {
    my $pkg = shift;
    my ($caller, $name, $constraint) = @_;

    my ($kura_item, $err) = _new_kura_item($caller, $name, $constraint);
    Carp::croak $err if $err;

    _save_kura_item($kura_item, $caller);
    _save_inc($caller);
}

# Create a constraint object.
#
# @param $constraint Defined. Following `create_constraint` function allows these types: Object, CodeRef, HashRef.
# @param $opts Dict[name => Str, caller => Str]
# @return ($constraint, undef) | (undef, $error_message)
#
# NOTE: This function is a hook point. If you want to customize the constraint object, you can override this function.
sub create_constraint {
    my ($constraint, $opts) = @_;

    if (my $blessed = Scalar::Util::blessed($constraint)) {
        return _create_constraint_from_typetiny($constraint, $opts) if $constraint->isa('Type::Tiny');
        return ($constraint, undef) if $constraint->can('check');
        return ($constraint, undef) if grep { $constraint->isa($_) } @ALLOWED_CONSTRAINT_CLASSES;
        return (undef, "Invalid constraint. Object must have a `check` method or allowed constraint class: $blessed");
    }
    elsif (my $reftype = Scalar::Util::reftype($constraint)) {
        if ($reftype eq 'CODE') {
            return _create_constraint_from_coderef($constraint, $opts);
        }
        elsif ($reftype eq 'HASH') {
            return _create_constraint_from_hashref($constraint, $opts);
        }
    }

    return (undef, 'Invalid constraint');
}

# Create a constraint object from a Type::Tiny object.
sub _create_constraint_from_typetiny {
    my ($type, $opts) = @_;

    $type->{name} = $opts->{name} if $type->is_anon;

    return ($type, undef);
}

# Create a constraint object from a code reference.
sub _create_constraint_from_coderef {
    my ($coderef, $opts) = @_;

    require Type::Tiny;

    my $args = {};
    $args->{name} = $opts->{name};
    $args->{constraint} = sub { !!eval { $coderef->($_[0]) } };
    $args->{message} = sub { sprintf('%s did not pass the constraint "%s"', Type::Tiny::_dd($_[0]), $args->{name}) };

    return (Type::Tiny->new(%$args), undef);
}

# Create a constraint object from a hash reference.
sub _create_constraint_from_hashref {
    my ($args, $opts) = @_;

    my $blessed = delete $args->{blessed} || 'Type::Tiny';
    eval "require $blessed" or die $@;

    $args->{name} //= $opts->{name};

    return ($blessed->new(%$args), undef);
}

# Create a new kura item which is Dict[name => Str, code => CodeRef].
# If the name or constraint is invalid, it returns (undef, $error_message).
# Otherwise, it returns ($kura_item, undef).
sub _new_kura_item {
    my ($caller, $name, $constraint) = @_;

    {
        return (undef, 'name is required') if !defined $name;
        return (undef, "'$name' is forbidden.") if $FORBIDDEN_NAME{$name};
        return (undef, "'$name' is already defined") if $caller->can($name);
    }

    return (undef, 'constraint is required') if !defined $constraint;
    ($constraint, my $err) = create_constraint($constraint, { name => $name, caller => $caller });
    return (undef, $err) if $err;

    # Prefix '_' means private, so it is not exported.
    my $is_private = $name =~ /^_/ ? 1 : 0;

    my $kura_item = { name => $name, code => sub { $constraint }, is_private => $is_private };
    return ($kura_item, undef);
}

# Save the kura item to the caller package
sub _save_kura_item {
    my ($kura_item, $caller) = @_;

    my $name = $kura_item->{name};
    my $code = Sub::Util::set_subname("$caller\::$name", $kura_item->{code});

    no strict "refs";
    no warnings "once";
    *{"$caller\::$name"} = $code;

    if (!$kura_item->{is_private}) {
        push @{"$caller\::EXPORT_OK"}, $name;
        push @{"$caller\::KURA"}, $name;
    }

    return;
}

# Hack to make the caller package already loaded. Useful for multi-packages in a single file.
sub _save_inc {
    my ($caller) = @_;

    ( my $file = $caller ) =~ s{::}{/}g;
    $INC{"$file.pm"} ||= __FILE__;

    return;
}

1;
__END__