File Coverage

blib/lib/Text/Xslate/Bridge/TypeDeclaration.pm

Criterion	Covered	Total	%
statement	86	86	100.0
branch	28	30	93.3
condition	11	14	78.5
subroutine	22	22	100.0
pod	0	1	0.0
total	147	153	96.0

package Text::Xslate::Bridge::TypeDeclaration;
use strict;
use warnings;
use parent qw(Text::Xslate::Bridge);

use Carp qw(croak);
use Data::Dumper;
use List::MoreUtils qw(all);
use Scalar::Util qw(blessed);
use Text::Xslate qw(mark_raw);
use Text::Xslate::Bridge::TypeDeclaration::Registry;
use Type::Registry ();
use Type::Tiny qw();
use Types::Standard qw(Any Dict slurpy);

our $VERSION = '0.13';

# Set truthy value to skip validation for local scope.
our $DISABLE_VALIDATION = 0;

our $IMPORT_DEFAULT_ARGS = {
    method         => 'declare',
    validate       => 1,
    print          => 1,
    on_mismatch    => 'die', # Cannot give a subroutine reference >_<
    registry_class => undef, # Class name for Type::Registry to lookup types
};

sub export_into_xslate {
    my $class     = shift;
    my $funcs_ref = shift;

    my $args = @_ == 1 ? shift : { @_ };
    croak sprintf '%s can receive either a hash or a hashref.', $class
        unless ref $args && ref($args) eq 'HASH';

    for my $key (keys %$IMPORT_DEFAULT_ARGS) {
        $args->{$key} = $IMPORT_DEFAULT_ARGS->{$key} unless defined $args->{$key};
    }

    my $registry = defined $args->{registry_class}
        ? Type::Registry->for_class($args->{registry_class})
        : Text::Xslate::Bridge::TypeDeclaration::Registry->new;

    $class->bridge(function => { $args->{method} => _declare_func($args, $registry) });
    $class->SUPER::export_into_xslate($funcs_ref, @_);
}

sub _declare_func {
    my ($args, $registry) = @_;

    return sub {
        return if $DISABLE_VALIDATION || !$args->{validate};

        while (my ($key, $declaration) = splice(@_, 0, 2)) {
            my $type = _type($declaration, $registry);
            my $value = Text::Xslate->current_vars->{$key};

            unless ($type->check($value)) {
                my $msg = sprintf(
                    "Declaration mismatch for `%s`\n  %s\n", $key, $type->get_message($value)
                );
                _print($msg) if $args->{print};
                last if _on_mismatch($msg, $args->{on_mismatch});
            }
        };

        return;
    };
}

# This treats unknown types as a declaration error.
sub _get_invalid_type {
    my ($name_or_struct) = @_;

    local $Data::Dumper::Indent   = 0;
    local $Data::Dumper::Maxdepth = 2;
    local $Data::Dumper::Sortkeys = 1;
    local $Data::Dumper::Terse    = 1;
    local $Data::Dumper::Useqq    = 1;

    my $name = Dumper($name_or_struct);
    return Type::Tiny->new(
        display_name => $name,
        constraint   => sub { },
        message      => sub { "$name is not a known type" },
    );
}

# returns: Type::Tiny
sub _type {
    my ($name_or_struct, $registry) = @_;

    return _get_invalid_type($name_or_struct)
        if !defined $name_or_struct || $name_or_struct eq '';

    if (my $ref = ref $name_or_struct) {
        return _hash_structure($name_or_struct, $registry) if $ref eq 'HASH';
        return _get_invalid_type($name_or_struct);
    } else {
        my $type = eval { $registry->lookup($name_or_struct) };
        return ($type && blessed($type) && $type->can('check'))
            ? $type : _get_invalid_type($name_or_struct);
    }
}

sub _hash_structure {
    my ($hash, $registry) = @_;

    return Dict[
        (map { $_ => _type($hash->{$_}, $registry) } keys %$hash),
        slurpy Any
    ];
}

sub _print {
    my ($msg) = @_;

    my $is_html = (Text::Xslate->current_engine->{type} || '') ne 'text';

    my @outputs = $is_html
        ? (mark_raw("\n"), $msg, mark_raw("\n"))
        : (mark_raw($msg));

    Text::Xslate->print(@outputs);
}

sub _on_mismatch {
    my ($msg, $func) = @_;

    my $h = +{
        die  => [ 'die_handler',  1 ],
        warn => [ 'warn_handler', 0 ],
        none => [ undef,          0 ]
    }->{$func};

    if ($h->[0]) {
        my $handler = Text::Xslate->current_engine->{$h->[0]};
        $handler->($msg) if $handler;
    }
    return $h->[1];
}

1;

__END__