File Coverage

blib/lib/MooX/Types/MooseLike/Base.pm
Criterion Covered Total %
statement 129 186 69.3
branch 71 112 63.3
condition 15 18 83.3
subroutine 61 76 80.2
pod 0 7 0.0
total 276 399 69.1


line stmt bran cond sub pod time code
1             package MooX::Types::MooseLike::Base;
2 10     10   153248 use strict;
  10         18  
  10         442  
3 10     10   45 use warnings FATAL => 'all';
  10         16  
  10         450  
4 10     10   45 use Scalar::Util qw(blessed);
  10         16  
  10         966  
5 10     10   58 use List::Util;
  10         10  
  10         601  
6 10     10   3284 use MooX::Types::MooseLike qw( exception_message inflate_type );
  10         15  
  10         600  
7 10     10   48 use Exporter 5.57 'import';
  10         145  
  10         28617  
8             our @EXPORT_OK = ();
9              
10             our $VERSION = 0.29;
11              
12             # These types act like those found in Moose::Util::TypeConstraints.
13             # Generally speaking, the same test is used.
14             sub some_basic_type_definitions {
15             return
16             (
17             {
18             name => 'Any',
19 0     0   0 test => sub { 1 },
20             message =>
21 0     0   0 sub { "If you get here you've achieved the impossible, congrats." }
22             },
23             {
24             name => 'Item',
25 0     0   0 test => sub { 1 },
26             message =>
27 0     0   0 sub { "If you get here you've achieved the impossible, congrats" }
28             },
29             {
30             name => 'Bool',
31              
32             # test => sub { $_[0] == 0 || $_[0] == 1 },
33             test => sub {
34 8 100 100 8   122 !defined($_[0]) || $_[0] eq "" || "$_[0]" eq '1' || "$_[0]" eq '0';
      100        
35             },
36 1     1   4 message => sub { return exception_message($_[0], 'a Boolean') },
37             },
38              
39             # Maybe has no test for itself, rather only the parameter type does
40             {
41             name => 'Maybe',
42 12     12   29 test => sub { 1 },
43 0     0   0 message => sub { 'Maybe only uses its parameterized type message' },
44 12 100   12   64 parameterizable => sub { return if (not defined $_[0]); $_[0] },
  9         17  
45             },
46             {
47             name => 'Undef',
48 6     6   36 test => sub { !defined($_[0]) },
49 4     4   13 message => sub { return exception_message($_[0], 'undef') },
50             },
51 10     10 0 262 );
52             }
53              
54             sub defined_type_definitions {
55             return
56             ({
57             name => 'Defined',
58 2     2   21 test => sub { defined($_[0]) },
59 1     1   4 message => sub { return exception_message($_[0], 'defined') },
60             },
61             {
62             name => 'Value',
63 5 100   5   80 test => sub { defined $_[0] and not ref($_[0]) },
64 2     2   6 message => sub { return exception_message($_[0], 'a value') },
65             },
66             {
67             name => 'Str',
68 12 100   12   137 test => sub { defined $_[0] and (ref(\$_[0]) eq 'SCALAR') },
69 5     5   16 message => sub { return exception_message($_[0], 'a string') },
70             },
71             {
72             name => 'Num',
73             test => sub {
74 22     22   41 my $val = $_[0];
75 22 100 100     444 defined $val and
76             ($val =~ /\A[+-]?[0-9]+\z/) ||
77             ( $val =~ /\A(?:[+-]?) # matches optional +- in the beginning
78             (?=[0-9]|\.[0-9]) # matches previous +- only if there is something like 3 or .3
79             [0-9]* # matches 0-9 zero or more times
80             (?:\.[0-9]+)? # matches optional .89 or nothing
81             (?:[Ee](?:[+-]?[0-9]+))? # matches E1 or e1 or e-1 or e+1 etc
82             \z/x );
83             },
84             message => sub {
85 5     5   7 my $nbr = shift;
86 5 100       16 if (not defined $nbr) {
    100          
87 1         2 $nbr = 'undef';
88             }
89             elsif (not (length $nbr)) {
90 1         2 $nbr = 'The empty string';
91             }
92 5         12 return exception_message($nbr, 'a number');
93             },
94             },
95             {
96             name => 'Int',
97 43 100   43   526 test => sub { defined $_[0] and ("$_[0]" =~ /^-?[0-9]+$/x) },
98             message => sub {
99 20     20   27 my $nbr = shift;
100 20 100       65 if (not defined $nbr) {
    100          
101 4         15 $nbr = 'undef';
102             }
103             elsif (not (length $nbr)) {
104 1         1 $nbr = 'The empty string';
105             }
106 20         49 return exception_message($nbr, 'an integer');
107             },
108             },
109 10     10 0 202 );
110             }
111              
112             sub ref_type_definitions {
113             return
114             (
115             {
116             name => 'Ref',
117 4 100   4   42 test => sub { defined $_[0] and ref($_[0]) },
118 3     3   8 message => sub { return exception_message($_[0], 'a reference') },
119             },
120              
121             {
122             name => 'ScalarRef',
123 2 50   2   15 test => sub { defined $_[0] and ref($_[0]) eq 'SCALAR' },
124 0     0   0 message => sub { return exception_message($_[0], 'a ScalarRef') },
125 2     2   2 parameterizable => sub { ${ $_[0] } },
  2         6  
126             inflate => sub {
127 0     0   0 require Moose::Util::TypeConstraints;
128 0 0       0 if (my $params = shift) {
129 0         0 return Moose::Util::TypeConstraints::_create_parameterized_type_constraint(
130             Moose::Util::TypeConstraints::find_type_constraint('ScalarRef'),
131             inflate_type(@$params),
132             );
133             }
134 0         0 return Moose::Util::TypeConstraints::find_type_constraint('ScalarRef');
135             },
136             },
137             {
138             name => 'ArrayRef',
139 25 100   25   182 test => sub { defined $_[0] and ref($_[0]) eq 'ARRAY' },
140 6     6   16 message => sub { return exception_message($_[0], 'an ArrayRef') },
141 16     16   14 parameterizable => sub { @{ $_[0] } },
  16         40  
142             inflate => sub {
143 0     0   0 require Moose::Util::TypeConstraints;
144 0 0       0 if (my $params = shift) {
145 0         0 return Moose::Util::TypeConstraints::_create_parameterized_type_constraint(
146             Moose::Util::TypeConstraints::find_type_constraint('ArrayRef'),
147             inflate_type(@$params),
148             );
149             }
150 0         0 return Moose::Util::TypeConstraints::find_type_constraint('ArrayRef');
151             },
152             },
153             {
154             name => 'HashRef',
155 39 100   39   317 test => sub { defined $_[0] and ref($_[0]) eq 'HASH' },
156 13     13   33 message => sub { return exception_message($_[0], 'a HashRef') },
157 14     14   13 parameterizable => sub { values %{ $_[0] } },
  14         66  
158             inflate => sub {
159 0     0   0 require Moose::Util::TypeConstraints;
160 0 0       0 if (my $params = shift) {
161 0         0 return Moose::Util::TypeConstraints::_create_parameterized_type_constraint(
162             Moose::Util::TypeConstraints::find_type_constraint('HashRef'),
163             inflate_type(@$params),
164             );
165             }
166 0         0 return Moose::Util::TypeConstraints::find_type_constraint('HashRef');
167             },
168             },
169             {
170             name => 'CodeRef',
171 5 50   5   73 test => sub { defined $_[0] and ref($_[0]) eq 'CODE' },
172 1     1   3 message => sub { return exception_message($_[0], 'a CodeRef') },
173             },
174             {
175             name => 'RegexpRef',
176 2 50   2   31 test => sub { defined $_[0] and ref($_[0]) eq 'Regexp' },
177 1     1   5 message => sub { return exception_message($_[0], 'a RegexpRef') },
178             },
179             {
180             name => 'GlobRef',
181 2 50   2   29 test => sub { defined $_[0] and ref($_[0]) eq 'GLOB' },
182 1     1   3 message => sub { return exception_message($_[0], 'a GlobRef') },
183             },
184 10     10 0 439 );
185             }
186              
187             sub filehandle_type_definitions {
188             return
189             (
190             {
191             name => 'FileHandle',
192             test => sub {
193 2 50 66 2   62 defined $_[0]
      33        
194             and Scalar::Util::openhandle($_[0])
195             or (blessed($_[0]) && $_[0]->isa("IO::Handle"));
196             },
197 1     1   4 message => sub { return exception_message($_[0], 'a FileHandle') },
198             },
199 10     10 0 50 );
200             }
201              
202             sub blessed_type_definitions {## no critic qw(Subroutines::ProhibitExcessComplexity)
203             return
204             (
205             {
206             name => 'Object',
207 9 100 100 9   181 test => sub { defined $_[0] and blessed($_[0]) and blessed($_[0]) ne 'Regexp' },
208 5     5   15 message => sub { return exception_message($_[0], 'an Object') },
209             },
210             {
211             name => 'InstanceOf',
212             test => sub {
213 11     11   35 my ($instance, @classes) = (shift, @_);
214 11 100       40 return if not defined $instance;
215 9 100       53 return if not blessed($instance);
216 7         18 my @missing_classes = grep { !$instance->isa($_) } @classes;
  8         100  
217 7 100       118 return (scalar @missing_classes ? 0 : 1);
218             },
219             message => sub {
220 6     6   13 my $instance = shift;
221 6 100       863 return "No instance given" if not defined $instance;
222 4 100       408 return "$instance is not blessed" if not blessed($instance);
223 2         6 my @missing_classes = grep { !$instance->isa($_) } @_;
  2         12  
224 2 50       11 my $s = (scalar @missing_classes) > 1 ? 'es' : '';
225 2         7 my $missing_classes = join ' ', @missing_classes;
226 2         401 return "$instance is not an instance of the class${s}: $missing_classes";
227             },
228             inflate => sub {
229 0     0   0 require Moose::Meta::TypeConstraint::Class;
230 0 0       0 if (my $classes = shift) {
231 0 0       0 if (@$classes == 1) {
    0          
232 0         0 return Moose::Meta::TypeConstraint::Class->new(class => @$classes);
233             }
234             elsif (@$classes > 1) {
235             return Moose::Meta::TypeConstraint->new(
236             parent => Moose::Util::TypeConstraints::find_type_constraint('Object'),
237             constraint => sub {
238 0         0 my $instance = shift;
239 0         0 my @missing_classes = grep { !$instance->isa($_) } @$classes;
  0         0  
240 0 0       0 return (scalar @missing_classes ? 0 : 1);
241             },
242 0         0 );
243             }
244             }
245 0         0 return Moose::Util::TypeConstraints::find_type_constraint('Object');
246             },
247             },
248             {
249             name => 'ConsumerOf',
250             test => sub {
251 5     5   13 my ($instance, @roles) = (shift, @_);
252 5 100       17 return if not defined $instance;
253 4 100       19 return if not blessed($instance);
254 3 100       26 return if (!$instance->can('does'));
255 2         4 my @missing_roles = grep { !$instance->does($_) } @roles;
  3         56  
256 2 50       73 return (scalar @missing_roles ? 0 : 1);
257             },
258             message => sub {
259 3     3   5 my $instance = shift;
260 3 100       316 return "No instance given" if not defined $instance;
261 2 100       230 return "$instance is not blessed" if not blessed($instance);
262 1 50       90 return "$instance is not a consumer of roles" if (!$instance->can('does'));
263 0         0 my @missing_roles = grep { !$instance->does($_) } @_;
  0         0  
264 0 0       0 my $s = (scalar @missing_roles) > 1 ? 's' : '';
265 0         0 my $missing_roles = join ' ', @missing_roles;
266 0         0 return "$instance does not consume the required role${s}: $missing_roles";
267             },
268             inflate => sub {
269 0     0   0 require Moose::Meta::TypeConstraint::Role;
270 0 0       0 if (my $roles = shift) {
271 0 0       0 if (@$roles == 1) {
    0          
272 0         0 return Moose::Meta::TypeConstraint::Role->new(role => @$roles);
273             }
274             elsif (@$roles > 1) {
275             return Moose::Meta::TypeConstraint->new(
276             parent => Moose::Util::TypeConstraints::find_type_constraint('Object'),
277             constraint => sub {
278 0         0 my $instance = shift;
279 0 0       0 return if (!$instance->can('does'));
280 0         0 my @missing_roles = grep { !$instance->does($_) } @$roles;
  0         0  
281 0 0       0 return (scalar @missing_roles ? 0 : 1);
282             },
283 0         0 );
284             }
285             }
286 0         0 return Moose::Util::TypeConstraints::find_type_constraint('Object');
287             },
288             },
289             {
290             name => 'HasMethods',
291             test => sub {
292 6     6   16 my ($instance, @methods) = (shift, @_);
293 6 100       50 return if not defined $instance;
294 5 100       30 return if not blessed($instance);
295 4         10 my @missing_methods = grep { !$instance->can($_) } @methods;
  7         47  
296 4 100       72 return (scalar @missing_methods ? 0 : 1);
297             },
298             message => sub {
299 3     3   4 my $instance = shift;
300 3 100       213 return "No instance given" if not defined $instance;
301 2 100       320 return "$instance is not blessed" if not blessed($instance);
302 1         2 my @missing_methods = grep { !$instance->can($_) } @_;
  2         7  
303 1 50       5 my $s = (scalar @missing_methods) > 1 ? 's' : '';
304 1         3 my $missing_methods = join ' ', @missing_methods;
305 1         83 return "$instance does not have the required method${s}: $missing_methods";
306             },
307             inflate => sub {
308 0     0   0 require Moose::Meta::TypeConstraint::DuckType;
309 0 0       0 if (my $methods = shift) {
310 0         0 return Moose::Meta::TypeConstraint::DuckType->new(methods => $methods);
311             }
312 0         0 return Moose::Util::TypeConstraints::find_type_constraint('Object');
313             },
314             },
315             {
316             name => 'Enum',
317             test => sub {
318 9     9   24 my ($value, @possible_values) = @_;
319 9 100       28 return if not defined $value;
320 8         50 return List::Util::first { $value eq $_ } @possible_values;
  21         92  
321             },
322             message => sub {
323 6     6   12 my ($value, @possible_values) = @_;
324 6         16 my $possible_values = join(', ', @possible_values);
325 6         22 return exception_message($value, "any of the possible values: ${possible_values}");
326             },
327             inflate => sub {
328 0     0   0 require Moose::Meta::TypeConstraint::Enum;
329 0 0       0 if (my $possible_values = shift) {
330 0         0 return Moose::Meta::TypeConstraint::Enum->new(values => $possible_values);
331             }
332 0         0 die "Enum cannot be inflated to a Moose type without any possible values";
333             },
334             },
335 10     10 0 347 );
336             }
337              
338             sub logic_type_definitions {
339             return
340             (
341             {
342             name => 'AnyOf',
343             test => sub {
344 15     15   28 my ($value, @types) = @_;
345 15         29 foreach my $type (@types) {
346 36 100       8725 return 1 if (eval {$type->($value); 1;});
  36         91  
  8         192  
347             }
348 7         3183 return;
349             },
350 7     7   22 message => sub { return exception_message($_[0], 'any of the types') },
351             inflate => sub {
352 0     0   0 require Moose::Meta::TypeConstraint::Union;
353 0 0       0 if (my $types = shift) {
354 0         0 return Moose::Meta::TypeConstraint::Union->new(
355             type_constraints => [ map inflate_type($_), @$types ],
356             );
357             }
358 0         0 die "AnyOf cannot be inflated to a Moose type without any possible types";
359             },
360             },
361             {
362             name => 'AllOf',
363 5     5   16 test => sub { return 1; },
364 0     0   0 message => sub { 'AllOf only uses its parameterized type messages' },
365 8     8   15 parameterizable => sub { $_[0] },
366 10     10 0 240 inflate => 0,
367             },
368             );
369             }
370              
371             sub type_definitions {
372             return
373             [
374 10     10 0 23 some_basic_type_definitions()
375             ,defined_type_definitions()
376             ,ref_type_definitions()
377             ,filehandle_type_definitions()
378             ,blessed_type_definitions()
379             ,logic_type_definitions()
380             ];
381             }
382              
383             MooX::Types::MooseLike::register_types(type_definitions(), __PACKAGE__);
384              
385             # Export an 'all' tag so one can easily import all types like so:
386             # use MooX::Types::MooseLike::Base qw(:all)
387             our %EXPORT_TAGS = ('all' => \@EXPORT_OK);
388              
389             1;
390              
391             __END__