File Coverage

blib/lib/Error/TypeTiny/Assertion.pm
Criterion Covered Total %
statement 48 48 100.0
branch 16 22 72.7
condition 7 12 58.3
subroutine 17 17 100.0
pod 11 11 100.0
total 99 110 90.0


line stmt bran cond sub pod time code
1             package Error::TypeTiny::Assertion;
2              
3 264     264   6121 use 5.008001;
  264         949  
4 264     264   1538 use strict;
  264         595  
  264         6122  
5 264     264   1448 use warnings;
  264         580  
  264         13172  
6              
7             BEGIN {
8 264     264   1132 $Error::TypeTiny::Assertion::AUTHORITY = 'cpan:TOBYINK';
9 264         200993 $Error::TypeTiny::Assertion::VERSION = '2.004000';
10             }
11              
12             $Error::TypeTiny::Assertion::VERSION =~ tr/_//d;
13              
14             require Error::TypeTiny;
15             our @ISA = 'Error::TypeTiny';
16              
17 373     373 1 1413 sub type { $_[0]{type} }
18 369     369 1 1301 sub value { $_[0]{value} }
19 1038   100 1038 1 5684 sub varname { $_[0]{varname} ||= '$_' }
20 2     2 1 10 sub attribute_step { $_[0]{attribute_step} }
21 2     2 1 12 sub attribute_name { $_[0]{attribute_name} }
22              
23 367     367 1 1123 sub has_type { defined $_[0]{type} }; # sic
24 2     2 1 10 sub has_attribute_step { exists $_[0]{attribute_step} }
25 2     2 1 1677 sub has_attribute_name { exists $_[0]{attribute_name} }
26              
27             sub new {
28 418     418 1 910 my $class = shift;
29 418         1581 my $self = $class->SUPER::new( @_ );
30            
31             # Supported but undocumented parameter is `mgaca`.
32             # This indicates whether Error::TypeTiny::Assertion
33             # should attempt to figure out which attribute caused
34             # the error from Method::Generate::Accessor's info.
35             # Can be set to true/false or not set. If not set,
36             # the current behaviour is true, but this may change
37             # in the future. If set to false, will ignore the
38             # $Method::Generate::Accessor::CurrentAttribute hashref.
39             #
40            
41 418 50 33     1634 if ( ref $Method::Generate::Accessor::CurrentAttribute
      66        
42             and $self->{mgaca} || !exists $self->{mgaca} )
43             {
44 26         138 require B;
45 26         42 my %d = %{$Method::Generate::Accessor::CurrentAttribute};
  26         114  
46 26 50       104 $self->{attribute_name} = $d{name} if defined $d{name};
47 26 50       79 $self->{attribute_step} = $d{step} if defined $d{step};
48            
49 26 100       68 if ( defined $d{init_arg} ) {
    50          
50 21         173 $self->{varname} = sprintf( '$args->{%s}', B::perlstring( $d{init_arg} ) );
51             }
52             elsif ( defined $d{name} ) {
53 5         47 $self->{varname} = sprintf( '$self->{%s}', B::perlstring( $d{name} ) );
54             }
55             } #/ if ( ref $Method::Generate::Accessor::CurrentAttribute...)
56            
57 418         1947 return $self;
58             } #/ sub new
59              
60             sub message {
61 349     349 1 2096 my $e = shift;
62 349 100       870 $e->varname eq '$_'
63             ? $e->SUPER::message
64             : sprintf( '%s (in %s)', $e->SUPER::message, $e->varname );
65             }
66              
67             sub _build_message {
68 1     1   5 my $e = shift;
69 1 50       4 $e->has_type
70             ? sprintf(
71             '%s did not pass type constraint "%s"',
72             Type::Tiny::_dd( $e->value ), $e->type
73             )
74             : sprintf(
75             '%s did not pass type constraint',
76             Type::Tiny::_dd( $e->value )
77             );
78             } #/ sub _build_message
79              
80             *to_string = sub {
81 343     343   794 my $e = shift;
82 343         920 my $msg = $e->message;
83            
84 343         1174 my $c = $e->context;
85 343 50 50     2509 $msg .= sprintf( " at %s line %s", $c->{file} || 'file?', $c->{line} || 'NaN' )
      50        
86             if $c;
87            
88 343         965 my $explain = $e->explain;
89 343 100       725 return "$msg\n" unless @{ $explain || [] };
  343 100       1291  
90            
91 342         898 $msg .= "\n";
92 342         922 for my $line ( @$explain ) {
93 2105         4201 $msg .= " $line\n";
94             }
95            
96 342         2166 return $msg;
97             }
98             if $] >= 5.008;
99            
100             sub explain {
101 366     366 1 699 my $e = shift;
102 366 100       905 return undef unless $e->has_type;
103 365         1030 $e->type->validate_explain( $e->value, $e->varname );
104             }
105              
106             1;
107              
108             __END__