File Coverage

blib/lib/Attribute/Params/Validate.pm

Criterion	Covered	Total	%
statement	64	65	98.4
branch	9	12	75.0
condition			n/a
subroutine	14	14	100.0
pod	0	2	0.0
total	87	93	93.5

package Attribute::Params::Validate;

use strict;
use warnings;

our $VERSION = '1.21';

use attributes;

use Attribute::Handlers 0.79;
use Exporter 5.60 qw( import );

# this will all be re-exported
use Params::Validate 1.21 qw(:all);

my %tags = (
    types => [
        qw( SCALAR ARRAYREF HASHREF CODEREF GLOB GLOBREF SCALARREF HANDLE UNDEF OBJECT )
    ],
);

our %EXPORT_TAGS = (
    'all' => [ qw( validation_options ), map { @{ $tags{$_} } } keys %tags ],
    %tags,
);
our @EXPORT_OK = ( @{ $EXPORT_TAGS{all} }, 'validation_options' );

sub UNIVERSAL::Validate : ATTR(CODE, INIT) {
    _wrap_sub( 'named', @_ );
}

sub UNIVERSAL::ValidatePos : ATTR(CODE, INIT) {
    _wrap_sub( 'positional', @_ );
}

## no critic (Subroutines::ProhibitManyArgs))
sub _wrap_sub {
    my ( $type, $package, $symbol, $referent, $attr, $params ) = @_;

    my @p = ref $params ? @{$params} : $params;

    my $subname = $package . '::' . *{$symbol}{NAME};

    my %attributes = map { $_ => 1 } attributes::get($referent);
    my $is_method = $attributes{method};

    {
        ## no critic (TestingAndDebugging::ProhibitNoStrict, TestingAndDebugging::ProhibitProlongedStrictureOverride)
        no warnings 'redefine';
        no strict 'refs';

        # An unholy mixture of closure and eval.  This is done so that
        # the code to automatically create the relevant scalars from
        # the hash of params can create the scalars in the proper
        # place lexically.

        my $code = <<"EOF";
sub
{
    package $package;
EOF

        $code .= "    my \$object = shift;\n" if $is_method;

        if ( $type eq 'named' ) {
            $params = {@p};
            $code .= "    Params::Validate::validate(\@_, \$params);\n";
        }
        else {
            $code .= "    Params::Validate::validate_pos(\@_, \@p);\n";
        }

        $code .= "    unshift \@_, \$object if \$object;\n" if $is_method;

        $code .= <<"EOF";
    \$referent->(\@_);
}
EOF

        ## no critic (BuiltinFunctions::ProhibitStringyEval)
        my $sub = eval $code;
        die $@ if $@;

        *{$subname} = $sub;
    }
}
## use critic

1;

# ABSTRACT: Define validation through subroutine attributes

__END__