File Coverage

blib/lib/Type/Nano.pm
Criterion Covered Total %
statement 66 134 49.2
branch 14 44 31.8
condition 7 62 11.2
subroutine 24 57 42.1
pod 3 23 13.0
total 114 320 35.6


line stmt bran cond sub pod time code
1 2     2   1407 use 5.008001;
  2         8  
2 2     2   10 use strict;
  2         13  
  2         60  
3 2     2   12 use warnings;
  2         3  
  2         60  
4              
5 2     2   489 use Exporter::Tiny ();
  2         3288  
  2         34  
6 2     2   12 use Scalar::Util ();
  2         4  
  2         3985  
7              
8             package Type::Nano;
9              
10             our $AUTHORITY = 'cpan:TOBYINK';
11             our $VERSION = '0.014';
12             our @ISA = qw( Exporter::Tiny );
13             our @EXPORT_OK = qw(
14             Any Defined Undef Ref ArrayRef HashRef CodeRef Object Str Bool Num Int Object
15             class_type role_type duck_type union intersection enum type
16             );
17              
18             # Built-in type constraints
19             #
20              
21             our %TYPES;
22              
23             sub Any () {
24             $TYPES{Any} ||= __PACKAGE__->new(
25             name => 'Any',
26 26     26   74 constraint => sub { !!1 },
27 2   33 2 0 25 );
28             }
29              
30             sub Defined () {
31             $TYPES{Defined} ||= __PACKAGE__->new(
32             name => 'Defined',
33             parent => Any,
34 26     26   61 constraint => sub { defined $_ },
35 2   33 2 0 13 );
36             }
37              
38             sub Undef () {
39             $TYPES{Undef} ||= __PACKAGE__->new(
40             name => 'Undef',
41             parent => Any,
42 0     0   0 constraint => sub { !defined $_ },
43 0   0 0 0 0 );
44             }
45              
46             sub Ref () {
47             $TYPES{Ref} ||= __PACKAGE__->new(
48             name => 'Ref',
49             parent => Defined,
50 0     0   0 constraint => sub { ref $_ },
51 0   0 0 0 0 );
52             }
53              
54             sub ArrayRef () {
55             $TYPES{ArrayRef} ||= __PACKAGE__->new(
56             name => 'ArrayRef',
57             parent => Ref,
58 0     0   0 constraint => sub { ref $_ eq 'ARRAY' },
59 0   0 0 0 0 );
60             }
61              
62             sub HashRef () {
63             $TYPES{HashRef} ||= __PACKAGE__->new(
64             name => 'HashRef',
65             parent => Ref,
66 0     0   0 constraint => sub { ref $_ eq 'HASH' },
67 0   0 0 0 0 );
68             }
69              
70             sub CodeRef () {
71             $TYPES{CodeRef} ||= __PACKAGE__->new(
72             name => 'CodeRef',
73             parent => Ref,
74 0     0   0 constraint => sub { ref $_ eq 'CODE' },
75 0   0 0 0 0 );
76             }
77              
78             sub Object () {
79             $TYPES{Object} ||= __PACKAGE__->new(
80             name => 'Object',
81             parent => Ref,
82 0     0   0 constraint => sub { Scalar::Util::blessed($_) },
83 0   0 0 0 0 );
84             }
85              
86             sub Bool () {
87             $TYPES{Bool} ||= __PACKAGE__->new(
88             name => 'Bool',
89             parent => Any,
90 0 0 0 0   0 constraint => sub { !defined($_) or (!ref($_) and { 1 => 1, 0 => 1, '' => 1 }->{$_}) },
91 0   0 0 0 0 );
92             }
93              
94             sub Str () {
95             $TYPES{Str} ||= __PACKAGE__->new(
96             name => 'Str',
97             parent => Defined,
98 24     24   56 constraint => sub { !ref $_ },
99 2   33 2 0 13 );
100             }
101              
102             sub Num () {
103             $TYPES{Num} ||= __PACKAGE__->new(
104             name => 'Num',
105             parent => Str,
106 24     24   87 constraint => sub { Scalar::Util::looks_like_number($_) },
107 2   33 2 0 13 );
108             }
109              
110             sub Int () {
111             $TYPES{Int} ||= __PACKAGE__->new(
112             name => 'Int',
113             parent => Num,
114 19     19   131 constraint => sub { /\A-?[0-9]+\z/ },
115 4   66 4 0 184 );
116             }
117              
118             sub class_type ($) {
119 0     0 0 0 my $class = shift;
120             $TYPES{CLASS}{$class} ||= __PACKAGE__->new(
121             name => $class,
122             parent => Object,
123 0     0   0 constraint => sub { $_->isa($class) },
124 0   0     0 class => $class,
125             );
126             }
127              
128             sub role_type ($) {
129 0     0 0 0 my $role = shift;
130             $TYPES{ROLE}{$role} ||= __PACKAGE__->new(
131             name => $role,
132             parent => Object,
133 0   0 0   0 constraint => sub { my $meth = $_->can('DOES') || $_->can('isa'); $_->$meth($role) },
  0         0  
134 0   0     0 role => $role,
135             );
136             }
137              
138             sub duck_type {
139 0 0   0 0 0 my $name = ref($_[0]) ? '__ANON__' : shift;
140 0 0       0 my @methods = sort( ref($_[0]) ? @{+shift} : @_ );
  0         0  
141 0         0 my $methods = join "|", @methods;
142             $TYPES{DUCK}{$methods} ||= __PACKAGE__->new(
143             name => $name,
144             parent => Object,
145 0   0 0   0 constraint => sub { my $obj = $_; $obj->can($_)||return !!0 for @methods; !!1 },
  0         0  
  0         0  
146 0   0     0 methods => \@methods,
147             );
148             }
149              
150             sub enum {
151 0 0   0 0 0 my $name = ref($_[0]) ? '__ANON__' : shift;
152 0 0       0 my @values = sort( ref($_[0]) ? @{+shift} : @_ );
  0         0  
153 0         0 my $values = join "|", map quotemeta, @values;
154 0         0 my $regexp = qr/\A(?:$values)\z/;
155             $TYPES{ENUM}{$values} ||= __PACKAGE__->new(
156             name => $name,
157             parent => Str,
158 0     0   0 constraint => sub { $_ =~ $regexp },
159 0   0     0 values => \@values,
160             );
161             }
162              
163             sub union {
164 0 0   0 0 0 my $name = ref($_[0]) ? '__ANON__' : shift;
165 0 0       0 my @types = ref($_[0]) ? @{+shift} : @_;
  0         0  
166             __PACKAGE__->new(
167             name => $name,
168 0   0 0   0 constraint => sub { my $val = $_; $_->check($val) && return !!1 for @types; !!0 },
  0         0  
  0         0  
169 0         0 types => \@types,
170             );
171             }
172              
173             sub intersection {
174 0 0   0 0 0 my $name = ref($_[0]) ? '__ANON__' : shift;
175 0 0       0 my @types = ref($_[0]) ? @{+shift} : @_;
  0         0  
176             __PACKAGE__->new(
177             name => $name,
178 0   0 0   0 constraint => sub { my $val = $_; $_->check($val) || return !!0 for @types; !!1 },
  0         0  
  0         0  
179 0         0 types => \@types,
180             );
181             }
182              
183             sub type {
184 0 0   0 0 0 my $name = ref($_[0]) ? '__ANON__' : shift;
185 0         0 my $coderef = shift;
186 0         0 __PACKAGE__->new(
187             name => $name,
188             constraint => $coderef,
189             );
190             }
191              
192             # OO interface
193             #
194              
195             sub DOES {
196 0     0 0 0 my $proto = shift;
197 0         0 my ($role) = @_;
198             return !!1 if {
199             'Type::API::Constraint' => 1,
200             'Type::API::Constraint::Constructor' => 1,
201 0 0       0 }->{$role};
202 0 0       0 "UNIVERSAL"->can("DOES") ? $proto->SUPER::DOES(@_) : $proto->isa(@_);
203             }
204              
205             sub new { # Type::API::Constraint::Constructor
206 10 50   10 1 27 my $class = ref($_[0]) ? ref(shift) : shift;
207 10 50       35 my $self = bless { @_ == 1 ? %{+shift} : @_ } => $class;
  0         0  
208            
209 10   50 0   100 $self->{constraint} ||= sub { !!1 };
  0         0  
210 10 50       22 unless ($self->{name}) {
211 0         0 require Carp;
212 0         0 Carp::croak("Requires both `name` and `constraint`");
213             }
214            
215 10         25 $self;
216             }
217              
218             sub check { # Type::API::Constraint
219 130     130 1 182 my $self = shift;
220 130         177 my ($value) = @_;
221            
222 130 100       242 if ($self->{parent}) {
223 104 100       166 return unless $self->{parent}->check($value);
224             }
225            
226 119         192 local $_ = $value;
227 119         195 $self->{constraint}->($value);
228             }
229              
230             sub get_message { # Type::API::Constraint
231 7     7 1 15 my $self = shift;
232 7         13 my ($value) = @_;
233            
234 7         35 require B;
235             !defined($value)
236             ? sprintf("Undef did not pass type constraint %s", $self->{name})
237             : ref($value)
238             ? sprintf("Reference %s did not pass type constraint %s", $value, $self->{name})
239 7 50       980 : sprintf("Value %s did not pass type constraint %s", B::perlstring($value), $self->{name});
    100          
240             }
241              
242             # Overloading
243             #
244              
245             {
246             my $nil = sub {};
247             sub _install_overloads
248             {
249 2     2   17 no strict 'refs';
  2         4  
  2         97  
250 2     2   13 no warnings 'redefine', 'once';
  2         4  
  2         696  
251 2 50   2   9 if ($] < 5.010) {
252 0         0 require overload;
253 0         0 push @_, fallback => 1;
254 0         0 goto \&overload::OVERLOAD;
255             };
256 2         4 my $class = shift;
257 2     0   7 *{$class . '::(('} = sub {};
  2         16  
258 2     0   6 *{$class . '::()'} = sub {};
  2         10  
259 2         4 *{$class . '::()'} = do { my $x = 1; \$x };
  2         5  
  2         3  
  2         5  
260 2         7 while (@_)
261             {
262 6         11 my $f = shift;
263             #*{$class . '::(' . $f} = $nil; # cargo culting overload.pm
264             #*{$class . '::(' . $f} = shift;
265 6 50   0   14 *{$class . '::(' . $f} = ref $_[0] ? shift : do { my $m = shift; sub { shift->$m(@_) } };
  6         27  
  0         0  
  0         0  
  0         0  
266             }
267             }
268             }
269              
270             __PACKAGE__ ->_install_overloads(
271 236     236   690 'bool' => sub { 1 },
272 0     0   0 '""' => sub { shift->{name} },
273             '&{}' => sub {
274 3     3   21046 my $self = shift;
275             sub {
276 4     4   2082 my ($value) = @_;
277 4 100       30 $self->check($value) or do {
278 2         23 require Carp;
279 2         11 Carp::croak($self->get_message($value));
280             };
281 3         27 };
282             },
283             );
284              
285             1;
286              
287             __END__