File Coverage

blib/lib/Test/Deep/Type.pm
Criterion Covered Total %
statement 51 51 100.0
branch 15 16 93.7
condition 5 5 100.0
subroutine 17 17 100.0
pod 1 1 100.0
total 89 90 98.8


line stmt bran cond sub pod time code
1 2     2   35640 use strict;
  2         3  
  2         45  
2 2     2   5 use warnings;
  2         3  
  2         79  
3             package Test::Deep::Type; # git description: v0.007-3-g1a9faf7
4             # vim: set ts=8 sts=4 sw=4 tw=115 et :
5             # ABSTRACT: A Test::Deep plugin for validating type constraints
6             # KEYWORDS: testing tests plugin types
7              
8             our $VERSION = '0.008';
9              
10 2     2   6 use Exporter 5.57 'import';
  2         35  
  2         156  
11             our @EXPORT = qw(is_type);
12              
13             sub is_type($)
14             {
15 9     9 1 10116 return Test::Deep::Type::Object->new($_[0]);
16             }
17              
18             package # hide from PAUSE
19             Test::Deep::Type::Object;
20              
21             our $VERSION = '0.008';
22              
23 2     2   751 use parent 'Test::Deep::Cmp';
  2         424  
  2         8  
24 2     2   1677 use Scalar::Util ();
  2         2  
  2         20  
25 2     2   399 use Try::Tiny ();
  2         939  
  2         696  
26              
27             sub init
28             {
29 9     9   41 my ($self, $type) = @_;
30 9         66 $self->{type} = $type;
31             }
32              
33             sub descend
34             {
35 9     9   16834 my ($self, $got) = @_;
36 9         18 return $self->_is_type($self->{type}, $got);
37             }
38              
39             sub diag_message
40             {
41 5     5   739 my ($self, $where) = @_;
42 5         11 my $name = $self->_type_name($self->{type});
43 5 100       1121 return 'Validating ' . $where . ' as a'
44             . (defined $name ? ' ' . $name : 'n unknown')
45             . ' type';
46             }
47              
48             # we do not define a diagnostics sub, so we get the one produced by deep_diag
49             # showing exactly what part of the data structure failed. This calls renderGot
50             # and renderVal:
51              
52             sub renderGot
53             {
54 5     5   20 my $self = shift; # my $got = shift;
55 5 100       12 return defined $self->{error_message} ? $self->{error_message} : 'failed';
56             }
57              
58             sub renderExp
59             {
60 5     5   12 my $self = shift;
61 5         7 return 'no error';
62             }
63              
64             sub _is_type
65             {
66 9     9   11 my ($self, $type, $got) = @_;
67              
68 9 100       8 if (eval { $type->can('validate') })
  9         49  
69             {
70 4         6 $self->{error_message} = $type->validate($got);
71 4         25 return !defined($self->{error_message});
72             }
73              
74             # last ditch effort - use the type as a coderef
75 5 100       7 if (__isa_coderef($type))
76             {
77             return Try::Tiny::try {
78 4     4   84 $type->($got)
79             } Try::Tiny::catch {
80 1     1   16 chomp($self->{error_message} = $_);
81 1         3 undef;
82 4         18 };
83             }
84              
85             # for now, stringy types are not supported. If a known Moose type, use
86             # Moose::Util::TypeConstraints::find_type_constraint('typename').
87              
88 1         20 $self->{error_message} = "Can't figure out how to use '$type' as a type";
89 1         2 return;
90             }
91              
92             sub _type_name
93             {
94 5     5   4 my ($self, $type) = @_;
95              
96             # use $type->name if we can
97 5         6 my $name = eval { $type->name };
  5         35  
98 5 50       13 return $name if $name;
99              
100             # ...or stringify, if possible
101 5 100       12 return "$type" if overload::Method($type, '""');
102              
103             # ...or its package name, if it has one
104 4         1079 my $class = Scalar::Util::blessed($type);
105 4 100       9 return $class if defined $class;
106              
107             # plain old subref perhaps?
108 2         3 return;
109             }
110              
111             sub __isa_coderef
112             {
113 5 100 100 5   39 ref $_[0] eq 'CODE'
      100        
114             or (Scalar::Util::reftype($_[0]) || '') eq 'CODE'
115             or overload::Method($_[0], '&{}')
116             }
117              
118             1;
119              
120             __END__