File Coverage

blib/lib/MooseX/Attribute/ValidateWithException/AttributeRole.pm
Criterion Covered Total %
statement 17 18 94.4
branch 1 2 50.0
condition n/a
subroutine 6 6 100.0
pod n/a
total 24 26 92.3


line stmt bran cond sub pod time code
1 3     3   525 use 5.006; # warnings
  3         7  
2 3     3   9 use strict;
  3         6  
  3         64  
3 3     3   19 use warnings;
  3         3  
  3         190  
4              
5             package MooseX::Attribute::ValidateWithException::AttributeRole;
6              
7             our $VERSION = 'v0.4.0';
8              
9             # ABSTRACT: Role to apply attribute properties to an attribute.
10              
11             our $AUTHORITY = 'cpan:KENTNL'; # AUTHORITY
12              
13 3     3   1218 use Moose::Role qw( override );
  3         303360  
  3         20  
14              
15             sub __generate_check {
16 2     2   6 my ( $self, %params ) = @_;
17 2 50       54 if ( $self->type_constraint->can_be_inlined ) {
18             ## no critic (ProtectPrivateSubs)
19 2         223 return sprintf '( %s )', $self->type_constraint->_inline_check( $params{value} );
20             }
21             else {
22 0           return sprintf '( %s->( %s ) )', $params{tc}, $params{value};
23             }
24             }
25              
26             override '_inline_check_constraint' => sub {
27              
28             my $self = shift;
29             my ( $value, $tc, $message, ) = @_;
30              
31             my $attribute_name = quotemeta( $self->name );
32              
33             return unless $self->has_type_constraint;
34              
35             my $tc_obj = $self->type_constraint;
36             my $tc_name = quotemeta( $tc_obj->name );
37              
38             ## no critic ( ProhibitImplicitNewlines RequireInterpolationOfMetachars )
39              
40             my $check_code = $self->__generate_check( value => $value, tc => $tc, );
41             my $message_variable = '$message';
42             my $get_message_code = ( sprintf 'do { local $_ = %s; %s->( %s ) }', $value, $message, $value, );
43              
44             return <<"CHECKCODE";
45             if( ! $check_code ) {
46             my $message_variable = $get_message_code;
47             if ( ref $message_variable ) {
48             die $message_variable;
49             } else {
50             require MooseX::Attribute::ValidateWithException::Exception;
51             die MooseX::Attribute::ValidateWithException::Exception->new(
52             attribute_name => '$attribute_name',
53             data => $value,
54             constraint_message => $message_variable,
55             constraint_name => '$tc_name',
56             );
57             }
58             }
59             CHECKCODE
60             };
61              
62             override 'verify_against_type_constraint' => sub {
63             my $self = shift;
64             my $val = shift;
65              
66             return 1 if !$self->has_type_constraint;
67              
68             my $type_constraint = $self->type_constraint;
69              
70             if ( not $type_constraint->check($val) ) {
71             my $message = $type_constraint->get_message($val);
72             if ( ref $message ) {
73             die $message;
74             }
75             else {
76             require MooseX::Attribute::ValidateWithException::Exception;
77             die MooseX::Attribute::ValidateWithException::Exception->new(
78             attribute_name => $self->name,
79             data => $val,
80             constraint_message => $message,
81             constraint => $type_constraint,
82             constraint_name => $type_constraint->name,
83             );
84             }
85             }
86             };
87              
88 3     3   9350 no Moose::Role;
  3         6  
  3         11  
89              
90             1;
91              
92             __END__
93              
94             =pod
95              
96             =encoding UTF-8
97              
98             =head1 NAME
99              
100             MooseX::Attribute::ValidateWithException::AttributeRole - Role to apply attribute properties to an attribute.
101              
102             =head1 VERSION
103              
104             version v0.4.0
105              
106             =head1 AUTHOR
107              
108             Kent Fredric <kentnl@cpan.org>
109              
110             =head1 COPYRIGHT AND LICENSE
111              
112             This software is copyright (c) 2017 by Kent Fredric <kentnl@cpan.org>.
113              
114             This is free software; you can redistribute it and/or modify it under
115             the same terms as the Perl 5 programming language system itself.
116              
117             =cut