File Coverage

blib/lib/Dios/Types.pm
Criterion Covered Total %
statement 525 610 86.0
branch 226 310 72.9
condition 113 196 57.6
subroutine 72 86 83.7
pod 2 2 100.0
total 938 1204 77.9


line stmt bran cond sub pod time code
1             package Dios::Types;
2             our $VERSION = '0.000001';
3              
4 59     59   233442 use 5.014; use warnings;
  59     59   193  
  59         298  
  59         111  
  59         1474  
5 59     59   294 use Carp;
  59         110  
  59         3549  
6 59     59   329 use Scalar::Util qw< reftype blessed looks_like_number openhandle >;
  59         93  
  59         5625  
7 59     59   50578 use overload;
  59         47640  
  59         309  
8 59     59   17984 use Sub::Uplevel;
  59         51440  
  59         352  
9              
10             $Carp::CarpInternal{'Dios::Types'}=1;
11              
12             ### IF KEYWORDS {
13 59     59   36648 use Keyword::Declare;
  59         5938230  
  59         807  
14              
15             ### IF KEYWORDS }
16              
17             my %exportable = ( validate => 1, validator_for => 1 );
18 0         0 sub import {
19              
20             # Throw away the package name...
21 62     62   487 shift @_;
22              
23             # Cycle through each SUB => AS pair...
24 62         403 while (my ($exported, $export_as) = splice(@_, 0, 2)) {
25             # If it's not a rename, don't change the name...
26 4 50 66     23 if ($export_as && $exportable{$export_as}) {
27 0         0 unshift @_, $export_as;
28 0         0 undef $export_as;
29             }
30              
31             # If it's not exported, don't export it...
32 4 50       16 croak "Can't export $exported" if !$exportable{$exported};
33              
34             # Unrenamed exports are exported under their own names...
35 4   66     17 $export_as //= $exported;
36              
37             # Do the export...
38 59     59   18406 no strict 'refs';
  59         109  
  59         11311  
39 4         4 *{caller.'::'.$export_as} = \&{$exported};
  4         12  
  4         11  
40             }
41              
42             ### IF KEYWORDS {
43 62         209  
44 59     59   1831618 keytype TypeSpec is /
45             (?&PerlIdentifier) (?: \[ (?>(?&PPR_balanced_squares)) \])?+
46             (?:
47             (?&PerlOWS) [&|] (?&PerlOWS)
48             (?&PerlIdentifier) (?: \[ (?>(?&PPR_balanced_squares)) \])?+
49             )*+
50             /x;
51 62         89  
52 59     59   1808409 keytype TypeParams is / \[ (?>(?&PPR_balanced_squares)) \] /x;
53              
54 62         93 # Create a new subtype of a known type, adding a constraint...
55 62 50 50     238 keyword subtype (
56 62         2342 Ident $new_type,
57             TypeParams $new_type_params = q{},
58             'of',
59             TypeSpec $known_type,
60 5     5   515405 'where',
  5         19  
  5         18  
  5         12  
  5         10  
  5         11  
  5         11  
  5         8  
61 5         30 Block $constraint
62             ) {
63 5         26 my $subtype_defn
64 62         515 = qq{Dios::Types::_define_subtype('$new_type', '$new_type_params', 'Is', '[$known_type]', sub $constraint) };
65             qq{if (((caller 0)[3]//q{}) =~ /\\b(?:un)?import\\Z/) { $subtype_defn }; BEGIN{ $subtype_defn }};
66 59     59   1974852 }
67              
68              
69 62         3484 # Alias a new subtype to a known type...
70 0 50 50     0 keyword subtype (
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  62         205  
71 0         0 Ident $new_type,
  62         1476  
72             TypeParams $new_type_params = q{},
73 0         0 'of',
74 59         481 TypeSpec $known_type,
75 4     4   392801 ) {
  4         37  
  4         10  
  4         10  
  4         8  
  4         8  
76 4         19 my $subtype_defn
77             = qq{Dios::Types::_define_subtype('$new_type', '$new_type_params', 'Is', '[$known_type]') };
78 4         43 qq{if (((caller 0)[3]//q{}) =~ /\\b(?:un)?import\\Z/) { $subtype_defn }; BEGIN{ $subtype_defn }};
79 62         375 }
80              
81 59     59   1986553 ### IF KEYWORDS }
82              
83             }
84              
85 0         0 my @user_defined_type;
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
86 0         0  
87             ### IF KEYWORDS {
88 0         0  
89 59         423 sub _define_subtype {
90 11     11   2449 my ($new_typename, $new_type_params, $old_typename, $old_type_params, $constraint) = @_;
91 11   100 10   73 $constraint //= sub{1};
  10         21  
92              
93 11   50     51 local $Dios::Types::lexical_hints = (caller 0)[10] // {};
94              
95             # Reassemble the complete base type...
96 11         314 $old_typename .= $old_type_params;
97              
98             # We are building a sub that builds type handlers...
99 11         19 my $new_type_handler_generator;
100              
101             # The simple case (where the new type is not parameterized)...
102 11 100       33 if (!length($new_type_params)) {
103 9         30 my $old_type_handler = _build_handler_for($old_typename);
104              
105             $new_type_handler_generator = sub {
106             return sub {
107 21         48 my $okay = $old_type_handler->($_[0]);
108 21 100       39 return _error_near($_[0], $new_typename, $okay) if !$okay;
109 17 100       40 return _error_near($_[0], $new_typename ) if !$constraint->(local $_ = $_[0]);
110 13         114 return 1;
111             }
112 9     21   42 };
  21         82  
113             }
114              
115             # The more complex case, where the new type has parameters...
116             else {
117             # Extract the new parameter names...
118 2         19 my @new_type_param_names = split /\s*,\s*/, $new_type_params =~ s{\A\[\s*+|\s*+\]\Z}{}grx;
119              
120             $new_type_handler_generator = sub {
121 10     10   17 my ($typename) = @_;
122 10         70 my @params = split /\s*,\s*/, $typename =~ s{\A \w++ \[ \s*+ | \s*+ \] \Z}{}grx;
123 10         20 my $substituted_typename = $old_typename;
124 10         23 for my $n (0..$#params) {
125 12         95 $substituted_typename =~ s{$new_type_param_names[$n]}{$params[$n]}gxms;
126             }
127              
128 10         30 my $old_type_handler
129             = _build_handler_for($substituted_typename,
130             "generated by parameterized subtype: $typename\n");
131              
132             return sub {
133 9         20 my $okay = $old_type_handler->($_[0]);
134 9 100       17 return _error_near($_[0], $typename, $okay) if !$okay;
135 7 100       9 if (! eval{ local $SIG{__WARN__} = sub{}; $constraint->(local $_ = $_[0]) }) {
  7         33  
  7         22  
136 3         26 my $constraint_desc = _describe_constraint($_[0], undef, $constraint, $@);
137 3         14 return _error_near(
138             $_[0], qq{Value ($_[0]) did not satisfy the constraint: $constraint_desc\n }
139             );
140             }
141 4         79 return 1;
142             }
143 2         14 };
  9         42  
144             }
145              
146 11         69 $^H{"Dios::Types subtype=$new_typename"} = @user_defined_type;
147 11         786 push @user_defined_type, $new_type_handler_generator;
148             }
149              
150             ### IF KEYWORDS }
151              
152             sub _error_near ($$;$) {
153 98     98   311 my ($where, $what, $previous_errors) = @_;
154              
155 0         0 { package Dios::Types::Error;
156 59     59   41219 use overload 'bool' => sub{0}, fallback => 1;
  59     209   129  
  59         571  
  209         541  
157             sub msg {
158 0     0   0 my $self = shift;
159 0 0       0 return $self->[0] ne $self->[-1] ? "$self->[-1]\n(because $self->[0])" : $self->[0];
160             }
161             }
162              
163 98 100 100     136 $previous_errors = bless [], 'Dios::Types::Error' if (reftype($previous_errors)//q{}) ne 'ARRAY';
  98         436  
164 98         135 push @{$previous_errors}, _perl($where) . " isn't of type $what";
  98         418  
165              
166 98         16545 return $previous_errors;
167             }
168              
169             # Standard type checking...
170             my %handler_for = (
171             # Any Perl value or ref...
172             Slurpy => sub { 1 },
173             Any => sub { 1 },
174              
175             # Anything that is true or false (and that's everything in Perl!)
176             Bool => sub { 1 },
177              
178             # Anything defined, or not...
179             Def => sub { defined $_[0] },
180             Undef => sub { !defined $_[0] },
181             Void => sub { !defined $_[0] || ref $_[0] eq 'ARRAY' && !@{$_[0]} },
182              
183             # Values, references, and filehandles...
184             Value => sub { defined($_[0]) && !ref($_[0]) },
185             Ref => sub { ref $_[0] },
186             IO => \&openhandle,
187             Glob => sub { ref($_[0]) eq 'GLOB' },
188              
189             # An integer...
190             Int => sub {
191             # If it's an object, must have a warning-less numeric overloading...
192             if (ref($_[0])) {
193             # Normal references aren't integers...
194             return 0 if !blessed($_[0]);
195              
196             # Is there an overloading???
197             my $converter = overload::Method($_[0],'0+')
198             or return 0;
199              
200             # Does this object convert to a number without complaint???
201             my $warned;
202             local $SIG{__WARN__} = sub { $warned = 1 };
203             my $value = eval{ $converter->($_[0]) }
204             // return 0;
205             return 0 if $warned;
206             return $value =~ m{\A \s*+ [+-]?+ (?: \d++ (\.0*+)?+ | inf(?:inity)?+ ) \s*+ \Z}ixms;
207             }
208              
209             # Value must be defined, non-reference, looks like an integer...
210             return defined($_[0])
211             && $_[0] =~ m{\A \s*+ [+-]?+ (?: \d++ (\.0*+)?+ | inf(?:inity)?+ ) \s*+ \Z}ixms;
212             },
213              
214             # A number
215             Num => sub {
216             return 0 if !defined $_[0] || lc($_[0]) eq 'nan';
217             &looks_like_number
218             },
219              
220             # A string, or stringifiable object, or array ref, or hash ref, that is empty...
221             Empty => sub {
222             my $value = shift;
223              
224             # Must be defined...
225             return 0 if !defined($value);
226              
227             # May be an empty array or hash...
228             my $reftype = ref($value);
229             return 1 if $reftype eq 'ARRAY' && !@{$value};
230             return 1 if $reftype eq 'HASH' && !keys %{$value};
231              
232             # May be an object that overloads stringification...
233             return 1 if $reftype && overload::Method($value, q{""}) && "$value" eq q{};
234              
235             # Otherwise, has to be an empty string...
236             return $value eq q{};
237             },
238              
239             # A string, or stringifiable object...
240             Str => sub { defined($_[0]) && (ref($_[0]) ? overload::Method(shift,q{""}) : 1) },
241              
242             # A blessed object...
243             Obj => \&blessed,
244              
245             # Any loaded class (must have @ISA or $VERSION or at least one method defined)...
246             Class => sub {
247             return 0 if ref $_[0] || not $_[0];
248             my $stash = \%main::;
249             for my $partial_name (split /::/, $_[0]) {
250             return 0 if !exists $stash->{$partial_name.'::'};
251             $stash = $stash->{$partial_name.'::'};
252             }
253             return 1 if exists $stash->{'ISA'};
254             return 1 if exists $stash->{'VERSION'};
255             for my $globref (values %$stash) {
256             return 1 if *{$globref}{CODE};
257             }
258             return 0;
259             },
260             );
261              
262             # Built-in type checking...
263             for my $type (qw< SCALAR ARRAY HASH CODE GLOB >) {
264             $handler_for{ ucfirst(lc($type)) } = sub { (reftype($_[0]) // q{}) eq $type };
265             }
266             $handler_for{ Regex } = sub { (reftype($_[0]) // q{}) eq 'REGEXP' };
267             $handler_for{ List } = $handler_for{ Array };
268              
269             # Standard type hierrachy...
270             my %BASIC_NARROWER = (
271             Slurpy => { },
272             Any => { map {$_=>1} qw< Slurpy >},
273             Bool => { map {$_=>1} qw< Slurpy Any >},
274             Undef => { map {$_=>1} qw< Slurpy Any Bool >},
275             Def => { map {$_=>1} qw< Slurpy Any Bool >},
276             Value => { map {$_=>1} qw< Slurpy Any Bool Def >},
277             Num => { map {$_=>1} qw< Slurpy Any Bool Def Value Str >},
278             Int => { map {$_=>1} qw< Slurpy Any Bool Def Value Str Num >},
279             Str => { map {$_=>1} qw< Slurpy Any Bool Def Value >},
280             Class => { map {$_=>1} qw< Slurpy Any Bool Def Value Str >},
281             Empty => { map {$_=>1} qw< Slurpy Any Bool Def Value Str Ref Array List Hash >},
282             Ref => { map {$_=>1} qw< Slurpy Any Bool Def >},
283             Scalar => { map {$_=>1} qw< Slurpy Any Bool Def Ref >},
284             Regex => { map {$_=>1} qw< Slurpy Any Bool Def Ref >},
285             Code => { map {$_=>1} qw< Slurpy Any Bool Def Ref >},
286             Glob => { map {$_=>1} qw< Slurpy Any Bool Def Ref >},
287             IO => { map {$_=>1} qw< Slurpy Any Bool Def Ref >},
288             Obj => { map {$_=>1} qw< Slurpy Any Bool Def Ref >},
289             Array => { map {$_=>1} qw< Slurpy Any Bool Def Ref >},
290             List => { map {$_=>1} qw< Slurpy Any Bool Def Ref Array >},
291             Empty => { map {$_=>1} qw< Slurpy Any Bool Def Value Str Ref Array Hash List >},
292             Hash => { map {$_=>1} qw< Slurpy Any Bool Def Ref >},
293             Empty => { map {$_=>1} qw< Slurpy Any Bool Def Value Str Ref Array Hash List >},
294             );
295              
296             # This is the full typename syntax...
297             my $BASIC_TYPES = join('|', keys %handler_for);
298              
299             my $TYPED_OR_PURE_ETC = qr{ \s*+ ,? \s*+ \.\.\.}xms;
300             my $TYPED_ETC = qr{ \s*+ \.\.\.}xms;
301             my $PURE_ETC = qr{ \s*+ , \s*+ \.\.\.}xms;
302              
303             my $KEYED_TYPENAME = q{
304             \\s*
305             (?: ' (? [^'\\\\]*+ (?: \\\\. [^'\\\\]*+ )*+ ) '
306             | (? (?&IDENT) )
307             )
308             (? \\s* [?] )?
309             (?: \\s* => \\s* (? (?&CONJ_TYPENAME) ) )?
310             };
311              
312             my $TYPENAME_GRAMMAR = qr{
313              
314             (?
315             (? (?&QUAL_IDENT) )
316             | Is \[ (? \s*+ (?&DISJ_TYPENAME_BAR) \s*+ ) \]
317             | Is \[ (? \s*+ (?&CONJ_TYPENAME) \s*+ ) \]
318             | Not \[ (? \s*+ (?&DISJ_TYPENAME) \s*+ ) \]
319             | List \[ (? \s*+ (?&DISJ_TYPENAME) \s*+ ) \]
320             | Array \[ (? \s*+ (?&DISJ_TYPENAME) \s*+ ) \]
321             | Tuple \[ (? \s*+ (?&TUPLE_FORMAT) \s*+ ) \]
322             | Hash \[ (? \s*+ (?&DISJ_TYPENAME) (?: \s*+ => \s*+ (?&DISJ_TYPENAME) )?+ \s*+ ) \]
323             | Dict \[ (? \s*+ (?&DICT_FORMAT) \s*+ ) \]
324             | Ref \[ (? \s*+ (?&DISJ_TYPENAME) \s*+ ) \]
325             | Eq \[ (? \s*+ (?&STR_SPEC) \s*+ ) \]
326             | Match \[ (? \s*+ (?®EX_SPEC) \s*+ ) \]
327             | Can \[ (? \s*+ (?&OPT_QUAL_IDENT) \s*+ (?: , \s*+ (?&OPT_QUAL_IDENT) \s*+ )*+ ) \]
328             | Overloads \[ (? [^]]++ ) \]
329             | (? (?&BASIC) )
330             | (? (?!(?&BASIC)) (?&IDENT) (?: \s*+ \[ \s*+ (?&TYPE_LIST) \s*+ \] )?+ )
331             )
332              
333             (?(DEFINE)
334              
335             (? (?&CONJ_TYPENAME) (?: \s* [|] \s* (?&CONJ_TYPENAME) )++ )
336             (? (?&CONJ_TYPENAME) (?: \s* [|] \s* (?&CONJ_TYPENAME) )*+ )
337             (? (?&ATOM_TYPENAME) (?: \s* [&] \s* (?&ATOM_TYPENAME) )*+ )
338              
339             (?
340             (?&CONJ_TYPENAME) (?: \s* [|] \s* (?&CONJ_TYPENAME) )++
341             | (?&ATOM_TYPENAME) (?: \s* [&] \s* (?&ATOM_TYPENAME) )++
342             )
343              
344             (?
345             (?&TYPE_LIST) (?: \s*+ ,? \s*+ \.\.\. )?
346             )
347              
348             (?
349             (?&CONJ_TYPENAME) (?: \s*,\s* (?&CONJ_TYPENAME) )*+
350             )
351              
352             (?
353             (?&KEYED_TYPENAME) (?: \s*,\s* (?&KEYED_TYPENAME) )*+ $PURE_ETC?
354             )
355              
356             (?
357             $KEYED_TYPENAME
358             )
359              
360             (? (?: [^][\\]++ | \\[][\\] )*+ )
361              
362             (? (?: [^][\\]++ | \\\S | \[ \^? \]? [^]]*+ \] )*+ )
363              
364             (? \b (?: $BASIC_TYPES ) \b )
365              
366             (? (?&IDENT) (?: :: (?&IDENT) )++ )
367              
368             (? (?&IDENT) (?: :: (?&IDENT) )*+ )
369              
370             (? [^\W\d] \w*+ )
371             )
372             }xms;
373              
374             my $FROM_TYPENAME_GRAMMAR = qr{ (?(DEFINE) $TYPENAME_GRAMMAR ) }xms;
375              
376             my $IS_REF_TYPE
377             = qr/\A (?: List | Array | Hash | Code | Scalar | Regex | Tuple | Dict | Glob | IO | Obj ) \b/x;
378              
379             # Complex types are built on the fly...
380             sub _build_handler_for {
381 250     250   496 my ($type, $context, $level) = @_;
382              
383             # Reformat conjunctions and disjunctions to avoid left recursion...
384 250 100       18967 if ($type =~ m{\A \s*+ ((?&NON_ATOM_TYPENAME)) \s*+ \Z $FROM_TYPENAME_GRAMMAR }xms) {
385 18         89 $type = "Is[$1]";
386             }
387              
388             # Parse the type specification...
389 250 50       9694 $type =~ m{\A \s*+ $TYPENAME_GRAMMAR \s*+ \Z }xms
    100          
390             or croak "Incomprehensible type name: $type\n",
391             (defined $context ? $context : q{});
392              
393 249         3229 my %type_is = %+;
394              
395             # Conjunction handlers test each component type and fail if any fails...
396 249 100       871 if ( exists $type_is{conj} ) { my @types = grep {defined} $type_is{conj} =~ m{ ((?&ATOM_TYPENAME))
  22         2293  
  972         1172  
397             $FROM_TYPENAME_GRAMMAR
398             }gxms;
399 22         93 my @handlers = map {_build_handler_for($_)} @types;
  27         93  
400             return sub {
401 34     34   56 for (@handlers) {
402 39         71 my $okay = $_->($_[0]);
403 39 100       99 return _error_near($_[0], join(' or ', @types), $okay)
404             if !$okay;
405             }
406 27         39 return 1;
407             }
408 22         129 }
409              
410             # Disjunction handlers test each component type and fail if all of them fail...
411 227 100       459 if ( exists $type_is{disj} ) { my @types = grep {defined} $type_is{disj} =~ m{ ((?&CONJ_TYPENAME))
  14         4348  
  1044         1266  
412             $FROM_TYPENAME_GRAMMAR
413             }gxms;
414 14         113 my @handlers = map {_build_handler_for($_)} @types;
  29         95  
415             return sub {
416 25     25   55 for (@handlers) {
417 43 100       108 return 1 if $_->($_[0]);
418             }
419 3         15 return _error_near($_[0], join(' or ', @types));
420             }
421 14         122 }
422              
423             # Basic types, just use the built-in handler...
424 213 100       382 if ( exists $type_is{basic} ) { return $handler_for{$type_is{basic}}; }
  102         442  
425              
426             # User defined types match an object of that type...
427 111 100       216 if ( exists $type_is{user} ) { my $typename = $type_is{user};
  13         24  
428 13         41 my $root_name = $typename =~ s{\[.*}{}rxms;
429 13         38 my $idx = $Dios::Types::lexical_hints->{"Dios::Types subtype=$root_name"};
430             return sub {
431             # Is it user-defined???
432 33 100   33   63 if (defined $idx) {
433 31         53 for ($_[0]) {
434 31   66     73 return $user_defined_type[$idx]($typename)($_)
435             || _error_near($_[0], $typename);
436             }
437             }
438              
439 2   33     18 return blessed($_[0]) && $_[0]->isa($typename)
440             || _error_near($_[0], $typename);
441             }
442 13         134 }
443              
444             # Array[T] types require an array ref, whose every element is of type T...
445 98 100       198 if ( exists $type_is{array} ) { my $value_handler = _build_handler_for($type_is{array});
  31         213  
446             return sub {
447 80 100 100 80   369 return _error_near($_[0], "Array[$type_is{array}]")
448             if (reftype($_[0]) // q{}) ne 'ARRAY';
449              
450 78         105 for (@{$_[0]}) {
  78         178  
451 167 100       303 next if my $okay = $value_handler->($_);
452 21         81 return _error_near($_, $type_is{array}, $okay);
453             }
454              
455 57         231 return 1;
456             }
457 31         242 }
458              
459             # List[T] types require an array ref, whose every element is of type T...
460 67 100       152 if ( exists $type_is{list} ) { my $value_handler = _build_handler_for($type_is{list});
  3         14  
461             return sub {
462 4 100 100 4   53 return _error_near($_[0], "List[$type_is{list}]")
463             if (reftype($_[0]) // q{}) ne 'ARRAY';
464              
465 3         7 for (@{$_[0]}) {
  3         9  
466 7 50       18 next if my $okay = $value_handler->($_);
467 0         0 return _error_near($_, $type_is{list}, $okay);
468             }
469              
470 3         10 return 1;
471             }
472 3         24 }
473              
474 64 100       132 if ( exists $type_is{tuple} ) { my @types
475 72         85 = grep {defined}
476 1         327 $type_is{tuple} =~ m{ ((?&CONJ_TYPENAME) | $TYPED_OR_PURE_ETC )
477             $FROM_TYPENAME_GRAMMAR
478             }gxms;
479             # Build type handlers for sequence...
480 1         11 my ($final_any, $final_handler);
481 1 50 33     40 if (@types > 1 && $types[-1] =~ /^$TYPED_ETC$/) {
    50 33        
482 0         0 pop @types;
483 0         0 $final_handler = _build_handler_for(pop @types);
484             }
485             elsif (@types > 0 && $types[-1] =~ /^$PURE_ETC$/) {
486 0         0 pop @types;
487 0         0 $final_any = 1;
488 0         0 $final_handler = _build_handler_for('Any');
489             }
490 1         5 my @value_handlers = map {_build_handler_for($_)} @types;
  2         5  
491              
492             return sub {
493 2     2   3 my $array_ref = shift;
494             # Tuples must be array refs the same length as their specifications...
495             return _error_near($array_ref, "Dict[$type_is{tuple}]")
496             if (reftype($array_ref) // q{}) ne 'ARRAY'
497 2 100 50     19 || !$final_handler && @{$array_ref} != @types;
  1   33     5  
      66        
498              
499             # The first N values must match the N types specified...
500 1         4 for my $n (0..$#types) {
501 2         6 my $okay = $value_handlers[$n]($array_ref->[$n]);
502 2 50       10 return _error_near($array_ref, "Dict[$type_is{tuple}]", $okay)
503             if !$okay;
504             }
505              
506             # Succeed at once if no etcetera to test, or it etcetera guaranteed...
507 1 50 33     7 return 1 if $final_any || @{$array_ref} == @types;
  1         5  
508              
509             # Any extra values must match the "et cetera" handler specified...
510 0         0 for my $n ($#types+1..$#{$array_ref}) {
  0         0  
511 0         0 my $okay = $final_handler->($array_ref->[$n]);
512 0 0       0 return _error_near($array_ref, "Dict[$type_is{tuple}]", $okay)
513             if !$okay;
514             }
515              
516 0         0 return 1;
517             }
518 1         9 }
519              
520             # Hash[T] and Hash[T=>T] types require a hash ref, whose every value is of type T...
521 63         212 my $HASH_KV_SPEC = qr{
522             \A
523             ((?&BalancedSquareBrackets))
524             (?: (=>) (.*) )?+
525             \Z
526              
527             (?(DEFINE)
528             (?
529             (?: [^][] | \[ (?&BalancedSquareBrackets) \] )*?
530             )
531             )
532             }xms;
533 63 100       139 if ( exists $type_is{hash} ) { my ($type_k, $arrow, $type_v) = $type_is{hash} =~ $HASH_KV_SPEC;
  21         258  
534             # Only value type specified...
535 21 100       73 if (!$arrow) {
536 12         53 $type_k =~ s/\A\s+|\s+\Z//g;
537 12         74 my $value_handler = _build_handler_for($type_k);
538             return sub {
539 39 100 100 39   201 return _error_near($_[0], "Hash[$type_is{hash}]")
540             if (reftype($_[0]) // q{}) ne 'HASH';
541              
542 35         54 for (values %{$_[0]}) {
  35         107  
543 41         97 my $okay = $value_handler->($_);
544 41 100       116 return _error_near($_, $type_is{hash}, $okay)
545             if !$okay;
546             }
547              
548 31         154 return 1;
549             }
550 12         115 }
551             # Both key and value type specified...
552             else {
553 9         38 $type_k =~ s/\A\s+|\s+\Z//g;
554 9         31 $type_v =~ s/\A\s+|\s+\Z//g;
555 9         22 my $key_handler = _build_handler_for($type_k);
556 9         20 my $value_handler = _build_handler_for($type_v);
557             return sub {
558 18 50 50 18   73 return _error_near($_[0], "Hash[$type_is{hash}]")
559             if (reftype($_[0]) // q{}) ne 'HASH';
560              
561 18         21 for (keys %{$_[0]}) {
  18         49  
562 39         57 my $okay = $key_handler->($_);
563 39 100       90 return _error_near($_, $type_is{hash}, $okay)
564             if !$okay;
565             }
566              
567 11         16 for (values %{$_[0]}) {
  11         22  
568 23         40 my $okay = $value_handler->($_);
569 23 100       50 return _error_near($_, $type_is{hash}, $okay)
570             if !$okay;
571             }
572              
573 9         19 return 1;
574             }
575 9         87 }
576             }
577              
578             # Dict[ k => T, k => T, ... ] requires a hash key, with the specified keys type-matched too...
579 42 100       81 if ( exists $type_is{dict} ) { my (%handler_for, @required_keys, $extra_keys_allowed);
  2         4  
580 2         341 while ($type_is{dict} =~ m{ (? $KEYED_TYPENAME)|(? $PURE_ETC)
581             $FROM_TYPENAME_GRAMMAR}gxms
582             ) {
583             # Create a type checker for each specified key (once!)...
584 6 100       41 if (exists $+{keyed}) {
585 4         27 my ($key, $valtype, $optional) = @+{qw< key valtype optional >};
586             croak qq{Two type specifications for key '$key' },
587             qq{in Dict[$type_is{dict}]}
588 4 50       14 if exists $handler_for{$key};
589 4   50     36 $handler_for{$key}
590             = _build_handler_for($valtype // 'Any');
591 4 50       54 push @required_keys, $key if !$optional;
592             }
593             # And remember whether other keys are allowed...
594             else {
595 2         13 $extra_keys_allowed = 1;
596             }
597             }
598              
599             # Build type handlers for sequence...
600             return sub {
601 4     4   6 my $hash_ref = shift;
602             # It has to be a hash reference...
603 4 100 50     18 return _error_near($hash_ref, "Dict[$type_is{dict}]")
604             if (reftype($hash_ref) // q{}) ne 'HASH';
605              
606             # With all the required keys...
607 3         5 for my $key (@required_keys) {
608             return _error_near($_, "Dict[$type_is{dict}]")
609 5 100       14 if !exists $hash_ref->{$key};
610             }
611              
612             # Each entry has to have a permitted key and the right type of value...
613 2         3 while (my ($key, $value) = each %{$hash_ref}) {
  10         23  
614 8 100       11 if (exists $handler_for{$key}) {
615 4         10 my $okay = $handler_for{$key}($value);
616 4 50       7 return _error_near($_, "Dict[$type_is{dict}]", $okay)
617             if !$okay;
618             }
619             else {
620 4 50       9 return _error_near($_, "Dict[$type_is{dict}]")
621             if !$extra_keys_allowed;
622             }
623             }
624              
625 2         3 return 1;
626             }
627 2         21 }
628              
629             # Ref[T] types require a reference, whose dereferenced value is of type T...
630             # but with special magic if T is already itself a reference type
631 40 100       68 if ( exists $type_is{ref} ) { my $value_handler = _build_handler_for($type_is{ref});
  14         44  
632 14 100       79 return $value_handler if $type_is{ref} =~ $IS_REF_TYPE;
633             return sub {
634 26     26   84 my $reftype = reftype($_[0]);
635 26 50 66     147 return _error_near($_[0], "Ref[$type_is{ref}]")
      33        
636             if !$reftype || $reftype ne 'REF' && $reftype ne 'SCALAR';
637 26         46 my $okay = $value_handler->(${$_[0]});
  26         65  
638 26 100       96 return $okay ? 1 : _error_near($_[0], "Ref[$type_is{ref}]", $okay)
639             }
640 10         86 }
641              
642             # Not[T] negates the usual test...
643 26 100       48 if ( exists $type_is{not} ) { my $negated_handler = _build_handler_for($type_is{not});
  2         6  
644             return sub {
645 11     11   24 my $not_okay = $negated_handler->($_[0]);
646 11 100       24 return _error_near($_[0], "Not[$type_is{not}]", $not_okay)
647             if $not_okay;
648 9         13 return 1;
649             }
650 2         34 }
651              
652             # Eq[S] types require a stringifiable, that matches 'S'...
653 24 50       61 if ( exists $type_is{eq} ) { my $str = eval "q[$type_is{eq}]";
  0         0  
654             return sub {
655             return 1 if defined $_[0]
656             && (!blessed($_[0]) || overload::Method($_[0],q{""}))
657 0 0 0 0   0 && eval{ "$_[0]" eq $str };
  0   0     0  
      0        
658 0         0 return _error_near($_[0], "Eq[$type_is{eq}]");
659             }
660 0         0 }
661              
662             # Match[R] types require a stringifiable, that matches /R/x...
663 24 100       47 if ( exists $type_is{match} ) {
664 6         11 my $regex = eval { qr{$type_is{match}}x };
  6         99  
665 6 50       19 croak "Invalid regex syntax in Match[$type_is{match}]:\n $@" if $@;
666             return sub {
667             return 1 if defined $_[0]
668             && (!blessed($_[0]) || overload::Method($_[0],q{""}))
669 26 100 33 26   109 && eval{ "$_[0]" =~ $regex };
  26   33     132  
      66        
670 4         23 return _error_near($_[0], "Match[$type_is{match}]");
671             }
672 6         43 }
673              
674             # Can[M] types require a class or object with the specified methods...
675 18 100       55 if ( exists $type_is{can} ) { my @method_names = split q{,}, $type_is{can};
  8         27  
676 8         75 s{\s*}{}g for @method_names;
677             return sub {
678 8 50 33 8   36 return 0 if !blessed($_[0]) && !$handler_for{Class}($_[0]);
679 8         14 for my $method_name (@method_names) {
680             return _error_near($_[0], "Can[$type_is{can}]")
681 12 100       14 if !eval{ $_[0]->can($method_name) };
  12         73  
682             }
683 6         13 return 1
684             }
685 8         65 }
686              
687             # Overloads[O] types require a class or object with the specified overloads...
688 10 50       19 if ( exists $type_is{overloads} ) { my @ops = split q{,}, $type_is{overloads};
  10         29  
689 10         87 s{\s*}{}g for @ops;
690             return sub {
691 59     59   210485 use overload;
  59         136  
  59         237  
692 10 50 33 10   44 return 0 if !blessed($_[0]) && !$handler_for{Class}($_[0]);
693 10         19 for my $op (@ops) {
694 24 100       380 return _error_near($_[0], "Can[$type_is{overloads}]")
695             if !overload::Method($_[0], $op);
696             }
697 6         200 return 1
698             }
699 10         80 }
700              
701 0         0 die "Internal error: could not generate a type from '$type'. Please report this as a bug."
702             }
703              
704             sub _complete_desc {
705 558     558   937 my ($desc, $value) = @_;
706 558   100     956 $desc //= q{Value (%s)};
707 558         922 my $value_perl = _perl($value);
708 558         57035 return $desc =~ s{(?
709             }
710              
711             sub validate {
712 757     757 1 169878 my ($typename, $value) = splice(@_,0,2);
713 757         1087 my ($value_desc, @constraints);
714 757         1208 for my $arg (@_) {
715             # Subs are undescribed constraints...
716 682 100       1554 if (ref($arg) eq 'CODE') {
    50          
717 60         101 push @constraints, $arg;
718             }
719              
720             # Anything else is part of the value description...
721             elsif (defined $arg) {
722 622         1068 $value_desc .= $arg;
723             }
724             }
725              
726             # What's happening in the caller's lexical scope???
727 757   50     1638 local $Dios::Types::lexical_hints = (caller 0)[10] // {};
728              
729             # All but the basic handlers are built late, as needed...
730 757 100       14187 if (!exists $handler_for{$typename}) {
731 44 50       145 $handler_for{$typename} = _build_handler_for($typename)
732             or die 'Internal error: unable to build type checker. Please report this as a bug.';
733             }
734              
735             # Either the type matches or we die...
736 757 100       1617 if (!$handler_for{$typename}($value)) {
737 314         631 $value_desc = _complete_desc($value_desc, $value);
738 314 50       3513 croak qq{\u$value_desc}
739             . ($value_desc =~ /\s$/ ? q{} : q{ })
740             . qq{is not of type $typename};
741             }
742 442 100       1675 return 1 if !@constraints;
743              
744             # Either every constraint matches or we die...
745 58         76 for my $test (@constraints) {
746 58         69 local $@;
747              
748             # If it fails to match...
749 58 100   0   82 if (! eval{ local $SIG{__WARN__} = sub{}; $test->(local $_ = $value) }) {
  58         256  
  58         159  
750 33         227 $value_desc = _complete_desc($value_desc, $value);
751 33         78 my $constraint_desc = _describe_constraint($value, $value_desc, $test, $@);
752 33 50       439 croak qq{\u$value_desc}
753             . ($value_desc =~ /\s$/ ? q{} : q{ })
754             . qq{did not satisfy the constraint: $constraint_desc\n }
755             }
756             }
757              
758 25         221 return 1;
759             }
760              
761             sub _up_validate {
762 118     118   3013 my ($uplevels, $typename, $value) = splice(@_,0,3);
763 118         163 my ($value_desc, @constraints);
764 118         191 for my $arg (@_) {
765             # Subs are undescribed constraints...
766 166 100       378 if (ref($arg) eq 'CODE') {
    50          
767 50         87 push @constraints, $arg;
768             }
769              
770             # Anything else is part of the value description...
771             elsif (defined $arg) {
772 116         214 $value_desc .= $arg;
773             }
774             }
775              
776             # What's happening in the caller's lexical scope???
777 118   100     243 local $Dios::Types::lexical_hints = (caller $uplevels)[10] // {};
778              
779             # All but the basic handlers are built late, as needed...
780 118 100       2105 if (!exists $handler_for{$typename}) {
781 2 50       6 $handler_for{$typename} = _build_handler_for($typename)
782             or die 'Internal error: unable to build type checker. Please report this as a bug.';
783             }
784              
785             # Either the type matches or we die...
786 118 100       265 if (!$handler_for{$typename}($value)) {
787 13         34 $value_desc = _complete_desc($value_desc, $value);
788 13 100       177 croak qq{\u$value_desc}
789             . ($value_desc =~ /\s$/ ? q{} : q{ })
790             . qq{is not of type $typename};
791             }
792 105 100       409 return 1 if !@constraints;
793              
794             # Either every constraint matches or we die...
795 42         60 for my $test (@constraints) {
796 42         54 local $@;
797              
798             # If it fails to match...
799 42 100   0   55 if (! eval{ local $SIG{__WARN__} = sub{}; $test->(local $_ = $value) }) {
  42         204  
  42         147  
800 4         33 $value_desc = _complete_desc($value_desc, $value);
801 4         49 my $constraint_desc = _describe_constraint($value, $value_desc, $test, $@);
802 4 50       90 croak qq{\u$value_desc}
803             . ($value_desc =~ /\s$/ ? q{} : q{ })
804             . qq{did not satisfy the constraint: $constraint_desc\n }
805             }
806             }
807              
808 38         183 return 1;
809             }
810              
811             sub validator_for {
812 281     281 1 108408 my $typename = shift;
813 281         430 my ($value_desc, @constraints);
814 281         473 for my $arg (@_) {
815             # Subs are undescribed constraints...
816 168 100       496 if (ref($arg) eq 'CODE') {
    50          
817 1         3 push @constraints, $arg;
818             }
819              
820             # Anything else is part of the value description...
821             elsif (defined $arg) {
822 167         385 $value_desc .= $arg;
823             }
824             }
825              
826             # What's happening in the caller's lexical scope???
827 281   50     727 local $Dios::Types::lexical_hints = (caller 0)[10] // {};
828              
829             # All but the basic handlers are built late, as needed...
830 281 100       5508 if (!exists $handler_for{$typename}) {
831 43 50       110 $handler_for{$typename} = _build_handler_for($typename)
832             or die 'Internal error: unable to build type checker. Please report this as a bug.';
833             }
834              
835             # Return the smallest sub that validates the type...
836 281         481 my $handler = $handler_for{$typename};
837              
838 281 50 66     938 return $handler if !$value_desc && !@constraints;
839              
840             return sub {
841 198 100   198   65958 return 1 if $handler->($_[0]);
842              
843 152         379 my $desc = _complete_desc($value_desc, $_[0]);
844 152 50       1772 croak qq{\u$desc}
845             . ($desc =~ /\s$/ ? q{} : q{ })
846             . qq{is not of type $typename};
847 167 100       1008 } if !@constraints;
848              
849             return sub {
850             # Either the type matches or we die...
851 10 100   10   31564 if (!$handler_for{$typename}($_[0])) {
852 2         6 my $desc = _complete_desc($value_desc, $_[0]);
853 2 50       34 croak qq{\u$desc}
854             . ($desc =~ /\s$/ ? q{} : q{ })
855             . qq{is not of type $typename};
856             }
857 8 50       30 return 1 if !@constraints;
858              
859             # Either every constraint matches or we die...
860 8         17 for my $test (@constraints) {
861 8         12 local $@;
862              
863             # If it fails to match...
864 8 50       13 if (! eval{ local $SIG{__WARN__} = sub{}; $test->(local $_ = $_[0]) }) {
  8         48  
  8         27  
865 0         0 my $desc = _complete_desc($value_desc, $_[0]);
866 0         0 my $constraint_desc = _describe_constraint($_[0], $desc, $test, $@);
867 0 0       0 croak qq{\u$desc}
868             . ($desc =~ /\s$/ ? q{} : q{ })
869             . qq{did not satisfy the constraint: $constraint_desc\n }
870             }
871             }
872              
873 8         84 return 1;
874             }
875 1         8 }
876              
877             package Dios::Types::TypedArray {
878             our @CARP_NOT = ('Dios::Types');
879 8     8   40 sub TIEARRAY { bless [$_[1]], $_[0] }
880 64     64   17008 sub FETCHSIZE { @{$_[0]} - 1 }
  64         128  
881 0     0   0 sub STORESIZE { $#{$_[0]} = $_[1] + 1 }
  0         0  
882 38     38   1639 sub STORE { my ($type, $desc, @constraint) = @{$_[0][0]};
  38         85  
883 38         101 Dios::Types::_up_validate(1, $type, $_[2], $desc, @constraint);
884 34         129 $_[0]->[$_[1]+1] = $_[2];
885             }
886 53     53   484 sub FETCH { $_[0]->[$_[1]+1] }
887 12     12   4097 sub CLEAR { @{$_[0]} = $_[0][0] }
  12         68  
888 0 0   0   0 sub POP { @{$_[0]} > 1 ? pop(@{$_[0]}) : undef }
  0         0  
  0         0  
889 0     0   0 sub PUSH { my $o = shift; push(@{$o}, @_) }
  0         0  
  0         0  
890 0     0   0 sub SHIFT { splice(@{$_[0]},1,1) }
  0         0  
891 0     0   0 sub UNSHIFT { my $o = shift; splice(@$o,1,0,@_) }
  0         0  
892 0     0   0 sub EXISTS { exists $_[0]->[$_[1]+1] }
893 0     0   0 sub DELETE { delete $_[0]->[$_[1]+1] }
894       12     sub EXTEND { }
895              
896             sub SPLICE
897             {
898 0     0   0 my $ob = shift;
899 0         0 my $sz = @{$ob} - 1;
  0         0  
900 0 0       0 my $off = @_ ? shift : 0;
901 0 0       0 $off += $sz if $off < 0;
902 0 0       0 my $len = @_ ? shift : $sz-$off;
903 0         0 return splice(@$ob,$off+1,$len,@_);
904             }
905             }
906              
907             package Dios::Types::TypedHash {
908             our @CARP_NOT = ('Dios::Types');
909 8     8   38 sub TIEHASH { bless [$_[1], {}], $_[0] }
910 24     24   523 sub STORE { my ($type, $desc, @constraint) = @{$_[0][0]};
  24         60  
911 24         71 Dios::Types::_up_validate(1, $type, $_[2], $desc, @constraint);
912 22         88 $_[0][1]{$_[1]} = $_[2]
913             }
914 35     35   406 sub FETCH { $_[0][1]{$_[1]} }
915 16     16   6741 sub FIRSTKEY { my $a = scalar keys %{$_[0][1]}; each %{$_[0][1]} }
  16         50  
  16         32  
  16         67  
916 32     32   46 sub NEXTKEY { each %{$_[0][1]} }
  32         85  
917 34     34   396 sub EXISTS { exists $_[0][1]{$_[1]} }
918 0     0   0 sub DELETE { delete $_[0][1]{$_[1]} }
919 12     12   7006 sub CLEAR { %{$_[0][1]} = () }
  12         80  
920 0     0   0 sub SCALAR { scalar %{$_[0][1]} }
  0         0  
921             }
922              
923             sub _set_var_type {
924 51     51   38274 my ($type, $varref, $value_desc, @constraint) = @_;
925 51         133 my $vartype = ref $varref;
926              
927 51 100 100     301 if ($vartype ne 'ARRAY' && $vartype ne 'HASH') {
    100          
    50          
928             croak 'Typed attributes require the Variable::Magic module, which could not be loaded'
929 21 50       39 if !eval{ require Variable::Magic };
  21         163  
930              
931 21         180 Variable::Magic::cast( ${$varref}, Variable::Magic::wizard( set => sub {
932             # Code around awkward Object::Insideout behaviour...
933 42 100 100 42   32208 return if ((caller 3)[3]//"") eq 'Object::InsideOut::DESTROY';
934              
935             # Code around more awkward Object::Insideout behaviour...
936 59     59   122794 no warnings 'redefine';
  59         130  
  59         98599  
937 23         408 local *croak = *confess{CODE};
938 23 100       43 return if eval { _up_validate(+2, $type, ${$_[0]}, $value_desc, @constraint) };
  23         39  
  23         83  
939 4         2189 die $@ =~ s{\s+at .*}{}r
940             =~ s{[\h\S]*Dios.*}{}gr
941             =~ s{.*\(eval .*}{}gr
942             =~ s{\s*[\h\S]*called at}{ at}r
943             =~ s{.*called at.*}{}gr;
944 21         60 }));
945             }
946             elsif ($vartype eq 'ARRAY') {
947 15 100       25 return if tied @{$varref};
  15         84  
948 8         16 tie @{$varref}, 'Dios::Types::TypedArray', [$type, $value_desc, @constraint];
  8         78  
949             }
950             elsif ($vartype eq 'HASH') {
951 15 100       25 return if tied %{$varref};
  15         65  
952 8         18 tie %{$varref}, 'Dios::Types::TypedHash', [$type, $value_desc, @constraint];
  8         63  
953             }
954             else {
955 0         0 die 'Internal error: argument to _set_var_type() must be scalar, array ref, or hash ref';
956             }
957             }
958              
959             # Implement return-type checking...
960             sub _validate_return_type {
961              
962             # Type info is first arg (an arrayref), subroutine body is final arg (a sub ref)...
963 33     33   14932 my ($name, $type, $where) = @{shift()};
  33         70  
964 33   50 26   171 $where //= sub{1};
  26         103  
965 33         41 my $function = pop;
966              
967             # List return context...
968 33 100       69 if (wantarray) {
    100          
969             # Tidy up type...
970 1         7 $type =~ s{\A Void \| | \| Void \Z}{}xmsg;
971 1         5 my $void_warning = vec((caller 1)[9], $warnings::Offsets{'void'}, 1);
972 1 50 33     24 warn sprintf "Call to $name() not in void context at %s line %d\n", (caller 1)[1,2]
973             if $void_warning && $type eq 'Void';
974              
975             # Execute the subroutine body in (apparently) the right context...
976 1         4 my @retvals = uplevel 2, $function, @_;
977              
978             # Adapt the constraint to produce a more appropriate error message...
979             my $listwhere = sub {
980 1     1   2 for (@{shift()}) {
  1         4  
981 3 50       4 die _describe_constraint($_,undef,$where) if !$where->($_)
982             }
983 1         6 return 1;
984 1         300 };
985              
986             # Validate the return values...
987             eval {
988 1 50       4 if (@retvals == 1) {
989 0         0 _up_validate(+1,
990             $type, $retvals[0], $where,
991             "Return value (" . (_perl(@retvals)=~s/^\(|\)$//gr) . ") of call to $name()\n"
992             );
993             }
994             else {
995 1         4 undef;
996             }
997             }
998             //
999 1   33     3 eval {
      50        
1000 1         5 _up_validate(+1,
1001             $type, \@retvals, $listwhere,
1002             "List of return values (" . (_perl(@retvals)=~s/^\(|\)$//gr) . ") of call to $name()\n"
1003             )
1004             }
1005              
1006             # ..or convert the error message to report from the correct line number...
1007 0         0 // die $@ =~ s{\s*+at \S+ line \d++.*+}{sprintf "\nat %s line %d\n", (caller 1)[1,2]}ser;
1008              
1009             # If the return values are valid, return them...
1010 1         9 return @retvals;
1011             }
1012              
1013             # Scalar context...
1014             elsif (defined wantarray) {
1015             # Tidy up type...
1016 30         62 $type =~ s{\A Void \| | \| Void \Z}{}xmsg;
1017 30         67 my $void_warning = vec((caller 1)[9], $warnings::Offsets{'void'}, 1);
1018 30 50 33     644 warn sprintf "Call to $name() not in void context at %s line %d\n", (caller 1)[1,2]
1019             if $void_warning && $type eq 'Void';
1020              
1021             # Execute the subroutine body in (apparently) the right context...
1022 30         65 my $retval = uplevel 2, $function, @_;
1023              
1024             # Validate the return value...
1025 30   100     757 eval {
1026 30         56 _up_validate(+1,
1027             $type, $retval, $where,
1028             "Scalar return value (" . _perl($retval) . ") of call to $name()\n"
1029             )
1030             }
1031             # ...or convert the error message to report from the correct line number...
1032 7         1729 // die $@ =~ s{\s*at \S+ line \d+.*}{sprintf "\nat %s line %d\n", (caller 1)[1,2]}er;
1033              
1034             # If the return value is valid, return it...
1035 23         79 return $retval;
1036             }
1037              
1038             # Void context...
1039             else {
1040             # Execute the subroutine body in (apparently) the right context...
1041 2         8 uplevel 2, $function, @_;
1042              
1043             # Warn about explicit return types in void context, unless return type implies void is okay...
1044 2         337 my $void_warning = vec((caller 1)[9], $warnings::Offsets{'void'}, 1);
1045             warn sprintf
1046             "Useless call to $name() with explicit return type $type\nin void context at %s line %d\n",
1047             (caller 1)[1,2]
1048 2 50 33     46 if $void_warning && !eval{ _up_validate(+1, $type, undef) };
  2         5  
1049              
1050             }
1051             }
1052              
1053              
1054              
1055              
1056             # Compare two types...
1057             sub _is_narrower {
1058 136     136   221 my ($type_a, $type_b, $unnormalized) = @_;
1059              
1060             # Short-circuit on identity...
1061 136 100       277 return 0 if $type_a eq $type_b;
1062              
1063             # Otherwise, normalize and decompose...
1064 110 100 100     3530 if (!$unnormalized && $type_a =~ m{\A (?: Ref ) \Z }xms) {
    50 66        
    100 100        
    50          
1065 24         36 $type_a = "Ref[Any]";
1066             }
1067             elsif (!$unnormalized && $type_a =~ m{\A (?: Array | List ) \Z }xms) {
1068 0         0 $type_a = "Ref[Array[Any]]";
1069             }
1070             elsif (!$unnormalized && $type_a eq 'Hash') {
1071 4         7 $type_a = "Ref[Hash[Any]]";
1072             }
1073             elsif ($type_a =~ m{\A \s*+ ((?&NON_ATOM_TYPENAME)) \s*+ \Z $FROM_TYPENAME_GRAMMAR }xms) {
1074 0         0 $type_a = "Is[$1]";
1075             }
1076 110         2018 $type_a =~ m{\A \s*+ $TYPENAME_GRAMMAR \s*+ \Z }xms; my %type_a_is = %+;
  110         1149  
1077              
1078 110 50 66     3737 if (!$unnormalized && $type_b =~ m{\A (?: Ref ) \Z }xms) {
    50 66        
    100 100        
    50          
1079 0         0 $type_b = "Ref[Any]";
1080             }
1081             elsif (!$unnormalized && $type_b =~ m{\A (?: Array | List ) \Z }xms) {
1082 0         0 $type_b = "Ref[Array[Any]]";
1083             }
1084             elsif (!$unnormalized && $type_b eq 'Hash') {
1085 20         34 $type_b = "Ref[Hash[Any]]";
1086             }
1087             elsif ($type_b =~ m{\A \s*+ ((?&NON_ATOM_TYPENAME)) \s*+ \Z $FROM_TYPENAME_GRAMMAR }xms) {
1088 0         0 $type_b = "Is[$1]";
1089             }
1090 110         1983 $type_b =~ m{\A \s*+ $TYPENAME_GRAMMAR \s*+ \Z }xms; my %type_b_is = %+;
  110         945  
1091              
1092             # If both are basic types, use the standard comparisons...
1093 110 100 100     412 if (exists $type_a_is{basic} && exists $type_b_is{basic}) {
1094 62 100       254 return +1 if $BASIC_NARROWER{$type_b}->{$type_a};
1095 30 50       186 return -1 if $BASIC_NARROWER{$type_a}->{$type_b};
1096             }
1097              
1098             # If both are array or hash or reference types, use the standard comparisons on their element-types...
1099 48         116 for my $elem_type (qw< array hash ref >) {
1100 144 100 100     301 if (exists $type_a_is{$elem_type} && exists $type_b_is{$elem_type}) {
1101 16         42 return _is_narrower($type_a_is{$elem_type}, $type_b_is{$elem_type}, 'unnormalized');
1102             }
1103             }
1104              
1105             # If either type is parameterized, try the generic unparameterized version...
1106 32 50 66     193 if ($type_a =~ s{\A(?:List|Array|Hash|Ref|Match|Eq)\K\[.*}{}xms
1107             || $type_b =~ s{\A(?:List|Array|Hash|Ref|Match|Eq)\K\[.*}{}xms) {
1108 32 0 33     88 return -1 if $type_a =~ m{\A(?:Match|Eq)\Z} && $BASIC_NARROWER{Class}->{$type_b};
1109 32 0 33     71 return +1 if $type_b =~ m{\A(?:Match|Eq)\Z} && $BASIC_NARROWER{Class}->{$type_a};
1110 32         74 return _is_narrower($type_a, $type_b, 'unnormalized');
1111             }
1112              
1113             # If both are user-defined types, try the standard inheritance hierarchy rules...
1114 0 0 0     0 if (exists $type_a_is{user} && exists $type_b_is{user}) {
1115 0 0       0 return +1 if $type_b->isa($type_a);
1116 0 0       0 return -1 if $type_a->isa($type_b);
1117             }
1118              
1119             # Otherwise, unable to compare...
1120 0         0 return 0;
1121             }
1122              
1123             # Compare two type signatures (of equal length)...
1124             sub _cmp_signatures {
1125 46     46   80 my ($sig_a, $sig_b) = @_;
1126              
1127             # Extract named parameters of B...
1128 46         50 state %named_B_for;
1129             my $named_B =
1130 46 100 100     109 $named_B_for{$sig_b} //= { map { $_->{named} ? ($_->{named} => $_) : () } @{$sig_b} };
  34         113  
  18         33  
1131              
1132             # Track relative ordering parameter-by-parameter...
1133 46         59 my $partial_ordering = 0;
1134 46         176 for my $n (0 .. max($#$sig_a, $#$sig_b)) {
1135             # Unpack the next parameter types...
1136 88   50     181 my $sig_a_n = $sig_a->[$n] // {};
1137 88         122 my $sig_a_name = $sig_a_n->{named};
1138 88 100 50     175 my $sig_b_n = ($sig_a_name ? $named_B->{$sig_a_name} : $sig_b->[$n]) // {};
1139 88   50     233 my ($type_a, $type_b) = ($sig_a_n->{type} // 'Any', $sig_b_n->{type} // 'Any');
      50        
1140              
1141             # Find the ordering of the next parameter pair from the two signatures...
1142 88         155 my $is_narrower = _is_narrower($type_a, $type_b);
1143              
1144             # Tie-break in favour of the type with more constraints...
1145 88 100 66     202 if (!$is_narrower && $type_a eq $type_b) {
1146 26   50     67 my $where_a = $sig_a_n->{where} // 0;
1147 26   50     59 my $where_b = $sig_b_n->{where} // 0;
1148 26 50       55 $is_narrower = $where_a > $where_b ? -1
    50          
1149             : $where_a < $where_b ? +1
1150             : 0;
1151             }
1152              
1153             # If this pair's ordering contradicts the ordering so far, there is no ordering...
1154 88 100 100     262 return 0 if $is_narrower && $is_narrower == -$partial_ordering;
1155              
1156             # Otherwise if there's an ordering, it becomes the "ordering so far"...
1157 72   100     194 $partial_ordering ||= $is_narrower;
1158             }
1159              
1160             # If we make it through the entire list, return the resulting ordering...
1161 30         72 return $partial_ordering;
1162             }
1163              
1164             # Resolve ambiguous argument lists using Perl6-ish multiple dispatch rules...
1165 59     59   497 use List::Util qw< max first >;
  59         118  
  59         37913  
1166             sub _resolve_signatures {
1167 27     27   33 state %narrowness_for;
1168 27         53 my ($kind, @sigs) = @_;
1169              
1170             # Track narrownesses...
1171 27         55 my %narrower = map { $_ => [] } 0..$#sigs;
  78         173  
1172              
1173             # Compare all signatures, recording definitive differences in narrowness...
1174 27         81 for my $index_1 (0 .. $#sigs) {
1175 78         163 for my $index_2 ($index_1+1 .. $#sigs) {
1176 91         146 my $sig1 = $sigs[$index_1]{sig};
1177 91         115 my $sig2 = $sigs[$index_2]{sig};
1178             my $narrowness =
1179 91   100     326 $narrowness_for{$sig1,$sig2} //= _cmp_signatures($sig1, $sig2);
1180              
1181 91 100       195 if ($narrowness < 0) { push @{$narrower{$index_1}}, $index_2; }
  35 100       39  
  35         98  
1182 24         32 elsif ($narrowness > 0) { push @{$narrower{$index_2}}, $index_1; }
  24         64  
1183             }
1184             }
1185              
1186             # Find the narrowest signature(s)...
1187 27         57 my $max_narrower = max map { scalar @{$_} } values %narrower;
  78         78  
  78         145  
1188              
1189             # If they're not sufficiently narrow, weed out the non-contenders...
1190 27 100       55 if ($max_narrower < @sigs-1) {
1191 6         15 @sigs = @sigs[ sort grep { @{$narrower{$_}} } keys %narrower ];
  22         20  
  22         52  
1192             }
1193             # Otherwise, locate the narrowest...
1194             else {
1195 21     43   111 @sigs = @sigs[ first { @{$narrower{$_}} >= $max_narrower } keys %narrower ];
  43         49  
  43         92  
1196             }
1197              
1198             # Tie-break methods on the class of the variants...
1199 27 100 100     132 if ($kind eq 'method' && @sigs > 1) {
1200 4         24 @sigs = sort { $a->{class} eq $b->{class} ? 0
1201             : $a->{class}->isa($b->{class}) ? -1
1202 4 50       22 : $b->{class}->isa($a->{class}) ? +1
    50          
    100          
1203             : 0
1204             } @sigs;
1205 4         58 @sigs = grep { $_->{class} eq $sigs[0]{class} } @sigs;
  8         20  
1206             }
1207              
1208 27         97 return @sigs;
1209             }
1210              
1211              
1212             sub _describe_constraint {
1213 40     40   89 my ($value, $value_desc, $constraint, $constraint_desc) = @_;
1214              
1215             # Did the exception provide a constraint description???
1216 40 50       84 if ($constraint_desc) {
1217 0         0 $constraint_desc =~ s{\b at .* line .*+ \s*+}{}gx;
1218             }
1219              
1220             # Describe the value that failed...
1221 40         68 $value_desc = _complete_desc($value_desc, $value);
1222              
1223             # Try to describe the constraint by name, if it was a named sub...
1224 40 50 50     146 if (!length($constraint_desc//q{}) && eval{ require B }) {
  40   33     264  
1225 40         275 my $sub_name = B::svref_2object($constraint)->GV->NAME;
1226 40 50 33     184 if ($sub_name && $sub_name ne '__ANON__') {
1227 0         0 $sub_name =~ s/[:_]++/ /g;
1228 0         0 $constraint_desc = $sub_name;
1229             }
1230             }
1231              
1232             # Deparse the constraint sub (if necessary and possible)...
1233 40 50 50     112 if (!length($constraint_desc//q{}) && eval{ require B::Deparse }) {
  40   33     173  
1234 40         271 state $deparser = B::Deparse->new;
1235 40         96 my ($hint_bits, $warning_bits) = (caller 0)[8,9];
1236 40         1153 $deparser->ambient_pragmas(
1237             hint_bits => $hint_bits, warning_bits => $warning_bits, '$[' => 0 + $[
1238 59     59   24071 );
  59         15585  
  59         12718  
1239 40         31795 $constraint_desc = $deparser->coderef2text($constraint);
1240 40         1220 $constraint_desc =~ s{\s*+ BEGIN \s*+ \{ (?&CODE) \}
1241             (?(DEFINE) (? [^{}]*+ (\{ (?&CODE) \} [^{}]*+ )*+ ))}{}gxms;
1242 40         413 $constraint_desc =~ s{(?: (?:use|no) \s*+ (?: feature | warnings | strict ) | die \s*+ sprintf ) [^;]* ;}{}gxms;
1243 40         152 $constraint_desc =~ s{package \s*+ \S+ \s*+ ;}{}gxms;
1244 40         185 $constraint_desc =~ s{\s++}{ }g;
1245             }
1246 40   33     154 return $constraint_desc // "$constraint";
1247             }
1248              
1249             sub _perl {
1250 59     59   16947 use Data::Dump 'dump';
  59         238382  
  59         11856  
1251             dump( map {
1252 1471 50   1471   275950 if (my $tiedclass = tied $_) { $tiedclass =~ s/=.*//; "<$tiedclass tie>" }
  1473 100       4689  
  0         0  
  0         0  
1253 2         14 elsif (my $classname = blessed $_) { "<$classname object>" }
1254 1471         4928 else { $_ }
1255             } @_ )
1256             =~ s{" (< \S++ \s (?:object|tie) >) "}{$1}xgmsr;
1257              
1258             }
1259              
1260              
1261              
1262             1; # Magic true value required at end of module
1263             __END__