File Coverage

blib/lib/Data/Sah/Util/Type.pm
Criterion Covered Total %
statement 59 64 92.1
branch 27 40 67.5
condition 24 37 64.8
subroutine 13 15 86.6
pod 6 6 100.0
total 129 162 79.6


line stmt bran cond sub pod time code
1             package Data::Sah::Util::Type;
2              
3             our $DATE = '2016-12-09'; # DATE
4             our $VERSION = '0.46'; # VERSION
5              
6 1     1   557 use 5.010001;
  1         3  
7 1     1   4 use strict;
  1         1  
  1         16  
8 1     1   4 use warnings;
  1         1  
  1         783  
9              
10             require Exporter;
11             our @ISA = qw(Exporter);
12             our @EXPORT_OK = qw(get_type is_type is_simple is_numeric is_collection is_ref);
13              
14             # XXX absorb and use metadata from Data::Sah::Type::*
15             our $type_metas = {
16             all => {scalar=>0, numeric=>0, ref=>0},
17             any => {scalar=>0, numeric=>0, ref=>0},
18             array => {scalar=>0, numeric=>0, ref=>1},
19             bool => {scalar=>1, numeric=>0, ref=>0},
20             buf => {scalar=>1, numeric=>0, ref=>0},
21             cistr => {scalar=>1, numeric=>0, ref=>0},
22             code => {scalar=>1, numeric=>0, ref=>1},
23             float => {scalar=>1, numeric=>1, ref=>0},
24             hash => {scalar=>0, numeric=>0, ref=>1},
25             int => {scalar=>1, numeric=>1, ref=>0},
26             num => {scalar=>1, numeric=>1, ref=>0},
27             obj => {scalar=>1, numeric=>0, ref=>1},
28             re => {scalar=>1, numeric=>0, ref=>1, simple=>1},
29             str => {scalar=>1, numeric=>0, ref=>0},
30             undef => {scalar=>1, numeric=>0, ref=>0},
31             date => {scalar=>1, numeric=>0, ref=>0},
32             duration => {scalar=>1, numeric=>0, ref=>0},
33             };
34              
35             sub get_type {
36 82     82 1 83 my $sch = shift;
37              
38 82 100       192 if (ref($sch) eq 'ARRAY') {
39 24         30 $sch = $sch->[0];
40             }
41              
42 82 50 33     287 if (defined($sch) && !ref($sch)) {
43 82         143 $sch =~ s/\*\z//;
44 82         219 return $sch;
45             } else {
46 0         0 return undef;
47             }
48             }
49              
50             sub _normalize {
51 24     24   786 require Data::Sah::Normalize;
52              
53 24         1448 my ($sch, $opts) = @_;
54 24 50       42 return $sch if $opts->{schema_is_normalized};
55 24         56 return Data::Sah::Normalize::normalize_schema($sch);
56             }
57              
58             # for any|all to pass a criteria, we assume that all of the schemas in the 'of'
59             # clause must also pass (and there must not be '!of', 'of&', or that kind of
60             # thing.
61             sub _handle_any_all {
62 24     24   29 my ($sch, $opts, $crit) = @_;
63 24         31 $sch = _normalize($sch, $opts);
64 24 100       1233 return 0 if $sch->[1]{'of.op'};
65 16         20 my $of = $sch->[1]{of};
66 16 100 66     138 return 0 unless $of && ref($of) eq 'ARRAY' && @$of;
      100        
67 8         14 for (@$of) {
68 14 100       24 return 0 unless $crit->($_);
69             }
70 4         18 1;
71             }
72              
73             sub is_type {
74 3     3 1 978 my ($sch, $opts) = @_;
75 3   50     18 $opts //= {};
76              
77 3 50       8 my $type = get_type($sch) or return undef;
78 3 100       14 my $tmeta = $type_metas->{$type} or return undef;
79 2         9 $type;
80             }
81              
82             sub is_simple {
83 33     33 1 1526 my ($sch, $opts) = @_;
84 33   50     137 $opts //= {};
85              
86 33 50       48 my $type = get_type($sch) or return undef;
87 33 50       84 my $tmeta = $type_metas->{$type} or return undef;
88 33 100 100     113 if ($type eq 'any' || $type eq 'all') {
89 12     8   48 return _handle_any_all($sch, $opts, sub { is_simple(shift) });
  8         13  
90             }
91 21   100     174 return $tmeta->{simple} // ($tmeta->{scalar} && !$tmeta->{ref});
      66        
92             }
93              
94             sub is_collection {
95 31     31 1 1546 my ($sch, $opts) = @_;
96 31   50     135 $opts //= {};
97              
98 31 50       45 my $type = get_type($sch) or return undef;
99 31 50       73 my $tmeta = $type_metas->{$type} or return undef;
100 31 100 100     117 if ($type eq 'any' || $type eq 'all') {
101 12     6   42 return _handle_any_all($sch, $opts, sub { is_collection(shift) });
  6         12  
102             }
103 19         94 return !$tmeta->{scalar};
104             }
105              
106             sub is_numeric {
107 9     9 1 1560 my ($sch, $opts) = @_;
108 9   50     40 $opts //= {};
109              
110 9 50       17 my $type = get_type($sch) or return undef;
111 9 50       25 my $tmeta = $type_metas->{$type} or return undef;
112 9 50 33     36 if ($type eq 'any' || $type eq 'all') {
113 0     0   0 return _handle_any_all($sch, $opts, sub { is_numeric(shift) });
  0         0  
114             }
115 9         54 return $tmeta->{numeric};
116             }
117              
118             sub is_ref {
119 6     6 1 1401 my ($sch, $opts) = @_;
120 6   50     33 $opts //= {};
121              
122 6 50       11 my $type = get_type($sch) or return undef;
123 6 50       18 my $tmeta = $type_metas->{$type} or return undef;
124 6 50 33     33 if ($type eq 'any' || $type eq 'all') {
125 0     0   0 return _handle_any_all($sch, $opts, sub { is_ref(shift) });
  0         0  
126             }
127 6         28 return $tmeta->{ref};
128             }
129              
130             1;
131             # ABSTRACT: Utility functions related to types
132              
133             __END__