File Coverage

blib/lib/Dios.pm
Criterion Covered Total %
statement 512 635 80.6
branch 251 352 71.3
condition 95 146 65.0
subroutine 57 58 98.2
pod n/a
total 915 1191 76.8


line stmt bran cond sub pod time code
1             package Dios;
2             our $VERSION = '0.002011';
3              
4 55     55   2231249 use 5.014; use warnings;
  55     55   198  
  55         291  
  55         97  
  55         1554  
5 55     55   26067 use Dios::Types;
  55         407  
  55         371  
6 55     55   3793 use Keyword::Declare;
  55         102  
  55         351  
7              
8             my $PARAMETER_SYNTAX = qr{
9             (?&WS)?+
10             (?
11             (?
12             (? (?&PerlNumber) )
13             |
14             (? (?&PerlQuotelikeQ) )
15             |
16             (? (?&PerlMatch) )
17             )
18             |
19             # TYPE...
20             (? (?&TYPE_SPEC) )?+
21              
22             # NAME...
23             (?&WS)?+
24             (?
25             : (? (?&IDENT) ) \( (?&WS)?+
26             (? (? [\$\@%]) (?&IDENT) ) (?&WS)?+
27             \)
28             |
29             : (? (? [\$\@%]) (? (?&IDENT) ) )
30             |
31             \* (?)
32             (?:
33             (? (? [\@%]) (?&IDENT) )
34             |
35             : (? (?&IDENT) ) \( (?&WS)?
36             (? (? \@) (?&IDENT) ) (?&WS)?
37             \)
38             |
39             : (? (? \@) (? (?&IDENT) ) )
40             |
41             (? (? [\@%]) )
42             )
43             |
44             (? (? [\$\@%]) (?&IDENT) )
45             |
46             (? (? [\$\@%]?+) )
47             )
48              
49             # OPTIONAL OR REQUIRED...
50             (?: (? \? ) (? )
51             | (? \! )
52             )?+
53              
54             # CONSTRAINT...
55             (?&WS)?+
56             (?: where (?&WS)?+ (? (?&PerlBlock) ) )?+
57              
58             # READONLY OR ALIAS...
59             (?: (?&WS)?+ is (?&WS)?+ (? ro | alias ) )?+
60              
61             # DEFAULT VALUE...
62             (?: (?&WS)?+ (? (?> // | \|\| )?+ = )
63             (?&WS)?+ (? (?&PerlConditionalExpression) ))?+
64              
65             (?&WS)?+
66             )
67             (? , | : | (?= --> ) | \z )
68              
69             (?(DEFINE)
70             (? (?&TYPE_NAME) (?: [&|] (?&TYPE_NAME) )*+ )
71             (? (?&QUAL_IDENT) (?&TYPE_PARAM)?+ )
72             (? \[ (?: [^][]*+ | (?&TYPE_PARAM) )*+ \] )
73             (? (?&IDENT) (?: :: (?&IDENT) )*+ )
74             (? [^\W\d] \w*+ )
75             (? (\s++ | \# [^\n]*+ \n )++ )
76             $PPR::GRAMMAR
77             )
78             }xms;
79              
80             my $EMPTY_PARAM_LIST = qr{
81             \A
82             (?&OWS)
83             (?:
84             \( (?&OWS) (\*\@_)?+ (?&OWS) \)
85             )?+
86             (?&OWS)
87             \z
88              
89             (?(DEFINE)
90             (? \s*+ (?: \# .* \n \s*+ )*+ )
91             )
92             }xm;
93              
94             sub _translate_parameters {
95 226     226   683 my $params = shift;
96 226         483 my $kind = shift;
97 226         426 my $sub_name = shift;
98 226         438 my $sub_name_tidy = $sub_name;
99 226         1012 $sub_name_tidy =~ s{\A \s*+ (?: \# .*+ \n \s*+ )*+ }{}x;
100              
101 226 100       1005 my $sub_desc = $sub_name ? "$kind $sub_name_tidy" : "anonymous $kind";
102 226   50     1126 my $invocant_name = $^H{'Dios invocant_name'} // '$self';
103              
104             # Empty and "standard" parameter lists are easy...
105 226 100 66     3684 if (!defined $params || $params =~ $EMPTY_PARAM_LIST) {
106 50         162 my $std_slurpy = defined $1;
107 50 100       475 my $code
    100          
108             = ($kind eq 'method'
109             ? _generate_invocant("method $sub_name_tidy", {var=>$invocant_name, sigil=>'$'})
110             : q{}
111             )
112             . ($std_slurpy ? q{} : qq{Dios::_error(ucfirst(q{$sub_desc takes no arguments})) if \@_;});
113              
114 50 100       291 my $spec = ( $kind eq 'method' ? q{ {type=>'Any', where=[]}, } : q{} )
    100          
115             . ( $std_slurpy ? q{ {optional => 1, type=>'Slurpy', where=>[]} } : q{} );
116              
117 50         275 return { code => $code, spec => $spec };
118             }
119              
120 176         1002 $params =~ s{\A \s*+ \(}{}x;
121 176         860 $params =~ s{\) \s*+ \z}{}x;
122              
123 176         412 my $return_type = undef;
124 176         339 my $return_constraint = undef;
125 176 100       611 my $invocant = $kind eq 'method' ? $invocant_name : undef;
126 176         357 my $first_param = 1;
127 176         326 my @params;
128              
129 176   66     5147225 while (length($params) && $params =~ s{\A \s*+ $PARAMETER_SYNTAX }{}x) {
130 284         75454 my %param = %+;
131 284 100       3700 last if $param{raw_param} !~ /\S/;
132              
133             # Special case of literal numeric constant as parameter (e.g. multi func fib(0) { 0 } )...
134 251 100       2083 if (defined $param{is_num_constant}) {
    100          
    100          
135 3         10 $param{type} = 'Num';
136 3         14 $param{constraint} = "{ \$_ == $param{is_num_constant} }";
137             }
138              
139             # Special case of literal string constant as parameter (e.g. multi func handle_event('add') {...} )...
140             elsif (defined $param{is_str_constant}) {
141 7         20 $param{type} = 'Str';
142 7         28 $param{constraint} = "{ \$_ eq $param{is_str_constant} }";
143             }
144              
145             # Special case of literal regex match as parameter (e.g. multi func # handle_event(/a|b/) {...} )...
146             elsif (defined $param{is_regex_constant}) {
147 2         7 $param{type} = 'Str';
148 2         9 $param{constraint} = "{ \$_ =~ $param{is_regex_constant} }";
149             }
150              
151 251         3147293 push @params, \%param;
152              
153             }
154              
155             # Make an implicit invocant explicit...
156 176 100 100     1137 if (!@params && $kind eq 'method') {
157 1         28242 "$invocant:" =~ m{\A \s*+ $PARAMETER_SYNTAX }x;
158 1         176 push @params, {%+};
159             }
160              
161             # Extract trailing return type specification...
162 176 100       1211 if ($params =~ s{ (?&WS) --> (?&WS) (.*+) (?(DEFINE) (? \s*+ (\# [^\n]*+ \n \s*+ )*+)) }{}xms ) {
163 33         248 ($return_type, $return_constraint) = split /\bwhere\b/, $1, 2;
164             }
165              
166             # Anything else in the parameter list is a mistake...
167 176 50       683 _error( qq{Invalid parameter specification: $params\n in $kind declaration} )
168             if $params =~ /\S/;
169              
170             # Convert the parameters into checking code...
171 176         462 my $code = q{};
172 176         369 my $spec = q{};
173 176         326 my $nameless_pos = 0;
174 176         442 my (%param_named, @positional, @named, $slurpy);
175              
176 176         629 for my $param (@params) {
177 252         424 $nameless_pos++;
178              
179             # Constraints imply an Any type...
180 252 100 66     924 if (defined $param->{constraint} && (!defined $param->{type} || $param->{type} !~ /\S/)) {
      100        
181 1         2 $param->{type} = 'Any';
182             }
183              
184             # Rectify nameless params...
185 252 100       669 if (exists $param->{nameless}) {
186 19   100     76 $param->{sigil} ||= '$';
187 19 100       119 my $nth = $nameless_pos
    100          
    100          
188             . ( $nameless_pos =~ /(?
189             : $nameless_pos =~ /(?
190             : $nameless_pos =~ /(?
191             : 'th'
192             );
193 19         86 $param->{var} = $param->{sigil} . '__nameless_'.$nth.'_parameter__';
194 19         50 $param->{namedvar} = $param->{sigil} . ' (unnamed $nth parameter)';
195             }
196              
197             # "There ken be onla one!" (...parameter of any given name)...
198             _error( qq{Can't declare two parameters named $param->{var}\n in specification of $sub_desc})
199 252 50       741 if exists $param_named{ $param->{var} };
200 252         804 $param_named{ $param->{var} }++;
201              
202             # Parameters are lexical, so can't be named @_ or $_ or %_...
203             _error(
204             qq{Can't declare a },
205             (exists $param->{name} ? 'named' : exists $param->{slurpy} ? 'slurpy' : 'positional'),
206             qq{ parameter named $param->{var}\nin specification of $sub_desc},
207 252 0 66     1105 ) if substr($param->{var},1) eq '_' && $param->{namedvar} ne '*@_';
    0          
    50          
208              
209             # Handle implicit invocant specially...
210 252 100 100     1495 if ($first_param && $kind eq 'method' && $param->{terminator} ne ':') {
      100        
211 89         690 $code .= _generate_invocant( "$sub_desc", {var=>$invocant_name, sigil=>'$'} );
212 89         318 $first_param = 0;
213             }
214              
215             # Handle explicit invocant...
216 252 100 100     1321 if ($first_param && $param->{terminator} && $param->{terminator} eq ':') {
    100 100        
217 18 50       55 _error( qq{Can't specify invocant ($param->{raw_param}:) for $sub_desc} ) if $kind ne 'method';
218 18         96 $code .= _generate_invocant( "$sub_desc", $param );
219 18   50     123 my $type = $param->{type} // 'Any';
220 18 50       70 my $constraint = $param->{constraint} ? "where => sub $param->{constraint}" : q{};
221 18         65 $spec .= qq{{type => '$type', $constraint },};
222 18         47 $first_param = 0;
223             }
224              
225             # Save a scalar (named or positional) paramater...
226             elsif (!exists $param->{slurpy}) {
227 214 100       507 if (exists $param->{name}) { push @named, $param }
  58         138  
228 156         368 else { push @positional, $param }
229             }
230              
231             # Save the final slurpy array or hash...
232             else {
233 20 50       59 _error( qq{Can't specify more than one slurpy parameter },
234             qq{($slurpy->{namedvar}, $param->{namedvar})\n},
235             qq{ in specification of $sub_desc}
236             ) if defined $slurpy;
237              
238 20 100       54 if (exists $param->{name}) {
239             _error( qq{Can't specify non-array named slurpy parameter ($param->{namedvar})\n},
240             qq{ in specification of $sub_desc}
241 2 50 33     13 ) if exists $param->{name} && $param->{sigil} ne '@';
242              
243 2         6 push @named, $param;
244             }
245             else {
246 18         59 $slurpy = $param;
247             }
248             }
249             }
250              
251 176 100       499 if (@positional) {
252 104         478 $code .= _generate_positionals( "$sub_desc", @positional );
253 104         292 for my $param (@positional) {
254 156   100     549 my $type = $param->{type} // 'Any';
255              
256 156 100       621 if ($param->{sigil} eq '@') { $type = "Array[$type]"; }
  6 100       19  
257 2         5 elsif ($param->{sigil} eq '%') { $type = "Hash[$type]"; }
258              
259 156 100       395 my $constraint = $param->{constraint} ? "where => sub $param->{constraint}" : q{};
260              
261 156 100       359 my $is_optional = exists $param->{default_type} ? 1 : 0;
262              
263 156         627 $spec .= qq{{optional => $is_optional, type => '$type', $constraint},};
264             }
265             }
266 176 100       511 if (@named) {
267 40         193 $code .= _generate_nameds( "$sub_desc", @named );
268 40         113 for my $param (@named) {
269 60   100     196 my $type = $param->{type} // 'Any';
270              
271 60 100       225 if ($param->{sigil} eq '@') { $type = "Array[$type]"; }
  5 100       14  
272 1         3 elsif ($param->{sigil} eq '%') { $type = "Hash[$type]"; }
273              
274 60 100       159 my $constraint = $param->{constraint} ? "where => sub $param->{constraint}" : q{};
275              
276 60 100       142 my $is_optional = exists $param->{default_type} ? 1 : 0;
277              
278 60         266 $spec .= qq{{named => '$param->{name}', optional => $is_optional, type => '$type', $constraint},};
279             }
280             }
281              
282 176 100       502 if (defined $slurpy) {
283 18 100       63 if ($slurpy->{var} ne '@_') {
284 17 50       59 my $constraint = $slurpy->{constraint} ? "where => sub $slurpy->{constraint}" : q{};
285 17         76 $code .= _generate_slurpies( "$sub_desc", $slurpy );
286 17         56 $spec .= qq{ {optional => 1, type=>'Slurpy', $constraint} };
287             }
288             }
289             else {
290 158         727 $code .= qq[Dios::_error q{Unexpected extra argument}.(\@_==1?q{}:q{s}).' ('.join(', ', map { Dios::_perl \$_ } \@_).q{) in call to $sub_desc} if \@_;];
291             }
292              
293 176 100       553 $return_type = defined $return_type ? qq{q{$return_type}} : "";
294 176 50       479 if (defined $return_constraint) {
295 0         0 $return_type .= qq{, sub $return_constraint };
296             }
297 176         2185 return { code => $code, return_type => $return_type, spec => $spec };
298             }
299              
300             sub _verify_required_named {
301 40     40   111 my ($context, @params) = @_;
302 40         90 my $code = q{};
303 40         87 for my $param (@params) {
304 60 100       172 next if !$param->{required};
305 1         3 my $vardesc = quotemeta $param->{namedvar};
306 1   50     7 my $argdesc = qq{'$param->{name}' => <} . lc($param->{type}//'value'). q{>};
307 1         6 $code .= qq[Dios::_error(qq{No argument ($argdesc) found for required named parameter $vardesc\\n]
308             . qq[in call to $context}) if !\$seen{$param->{name}}; ];
309             }
310 40         98 return $code;
311             }
312              
313             sub _generate_invocant {
314 153     153   483 my ($context, $param) = @_;
315 153         264 my $code;
316 153         547 my $vardesc = qq{invocant $param->{var}};
317              
318             # Create and unpack corresponding argument...
319 153         555 $code .= qq{my $param->{var}; };
320 153         391 $code .= _unpack_code( @{$param}{'sigil','var','name','default','special'}, $vardesc, $context );
  153         1120  
321              
322             # Install a type check, if necessary...
323 153 50       1084 if (exists $param->{type}) {
324 0         0 $code .= _typecheck_code(@{$param}{'sigil','var','type','constraint'}, $vardesc, $context);
  0         0  
325             }
326              
327 153         557 return $code;
328             }
329              
330             sub _generate_positionals {
331 104     104   347 my ($context, @positionals) = @_;
332 104         203 my $code;
333              
334 104         249 for my $param (@positionals) {
335             # Create and unpack corresponding argument...
336 156         340 my $var = $param->{var};
337 156 100       589 my $vardesc = $var =~ /^(.)__nameless_(\d++[^\W_]++)_parameter__$/
338             ? "unnamed $2 positional parameter"
339             : "positional parameter $var";
340 156         481 $code .= qq{my $var; };
341             $code .= _unpack_code(
342 156         314 @{$param}{'sigil','var','name','default','special'},
  156         775  
343             $vardesc,
344             $context
345             );
346 156 100 66     785 if (exists $param->{name} && exists $param->{default_type}) {
347 36 100 100     195 if ($param->{default_type} eq '//=' && $param->{sigil} eq '$') {
    100          
348 9         16 my $assign_code = _assign_value_code( @{$param}{'sigil','var','special','default'}, q{});
  9         24  
349 9         40 $code .= qq{ do {$assign_code} if !defined $var; };
350             }
351             elsif ($param->{default_type} eq '||=') {
352 10         15 my $assign_code = _assign_value_code( @{$param}{'sigil','var','special','default'}, q{});
  10         25  
353 10         34 $code .= qq{ do {$assign_code} if !$var; };
354             }
355             }
356              
357             # Install a type check, if necessary...
358 156 100       505 next if !exists $param->{type};
359 55         106 $code .= _typecheck_code(@{$param}{'sigil','var','type','constraint'}, $vardesc, $context);
  55         201  
360             }
361              
362 104         422 return $code;
363             }
364              
365             sub _generate_nameds {
366 40     40   128 my ($context, @nameds) = @_;
367 40         72 my $code;
368              
369             # Declare all named args...
370 40         113 $code .= 'my (' . join(',', map { $_->{var} } @nameds) . '); ';
  60         293  
371              
372             # Walk the arg list, unpacking them...
373 40         113 $code .= qq[{ my %seen; while (\@_) { my \$next_key = shift;];
374              
375 40         85 my $defaults = q{};
376 40         113 for my $param (@nameds) {
377 60         171 $code .= qq[ if (\$next_key eq q{$param->{name}}) {];
378             my $unpack_code =
379             exists $param->{slurpy} ? _unpack_named_slurpy_code(
380 2         14 @{$param}{qw< var sigil name special >},
381             "slurpy named parameter $param->{namedvar}", $context
382             )
383             : _unpack_code(
384 58         334 @{$param}{'sigil','var','name'}, undef, $param->{special},
385 60 100       178 "named parameter $param->{namedvar}", $context
386             );
387 60         217 $code .= qq[$unpack_code next}];
388              
389 60 100 66     291 if (exists $param->{name} && exists $param->{default}) {
390 2         5 my $assign_code = _assign_value_code( @{$param}{'sigil','var','special','default'}, q{});
  2         7  
391             $defaults .= qq{ do {$assign_code} if }
392             . ( $param->{default_type} eq '//=' ? qq{!defined $param->{var}; }
393 2 50       19 : $param->{default_type} eq '||=' ? qq{!$param->{var}; }
    100          
394             : qq{!\$seen{$param->{'name'}}; }
395             );
396             }
397             }
398              
399 40         157 my $requireds = _verify_required_named($context, @nameds);
400              
401 40         140 $code .= qq[unshift \@_, \$next_key; last} $defaults $requireds}];
402              
403 40         86 for my $param (@nameds) {
404 60 100       153 next if !exists $param->{type};
405              
406 40 100       95 my $slurpy = exists $param->{slurpy} ? q{slurpy } : q{};
407             $code .= _typecheck_code(
408 40         84 @{$param}{'sigil','var','type','constraint'}, "${slurpy}named parameter $param->{namedvar}", $context
  40         214  
409             );
410             }
411              
412 40         147 return $code;
413             }
414              
415             my $REFALIASING = q{use experimental 'refaliasing'};
416              
417             sub _generate_slurpies {
418 17     17   48 my ($context, $param) = @_;
419              
420             # No slurpy by default...
421 17 50       56 return q{} if !defined $param;
422 17         53 my $special = $param->{special};
423 17         41 my $code = q{};
424              
425 17 100       101 my $vardesc = $param->{var} =~ /^(.)__nameless_.*_parameter__$/
426             ? "nameless slurpy parameter (*$1)"
427             : "slurpy parameter *$param->{var}";
428              
429             # Check named slurpies...
430 17 100       75 if ($param->{sigil} eq '%') {
431 2         9 $code .= qq{Dios::_error('Final key ('.Dios::dump(\$_[-1]).qq{) for $vardesc is missing its value\\nin call to $context}) if \@_ % 2;}
432             }
433              
434             # Create and unpack corresponding argument...
435 17 50 33     91 $code .= !$special ? qq{ my $param->{var} = }
    50          
    50          
    100          
436             : $special eq 'ro' ? qq{ Const::Fast::const my $param->{var} => }
437             : $special eq 'alias' && $] < 5.022 ? qq{ Data::Alias::alias my $param->{var} = }
438             : $special eq 'alias' ? qq{ $REFALIASING; \\my $param->{var} =\\ }
439             : die "Internal error: unknown special trait: is $special";
440              
441 17 100       65 $code .= exists $param->{default} ? qq{ (\@_ ? \@_ : $param->{default}); }
442             : qq{ \@_; };
443              
444             # Install a type check, if necessary...
445 17 100       57 if (exists $param->{type}) {
446 1         2 $code .= _typecheck_code(@{$param}{'sigil','var','type','constraint'}, $vardesc, $context, 'slurpy');
  1         4  
447             }
448              
449             # Install existence check, if necessary...
450 17 100       60 if (exists $param->{required}) {
451 1         3 my $vardesc = quotemeta $vardesc;
452 1         5 $code .= qq[Dios::_error qq{Missing argument for required $vardesc\\nin $context} if !\@_;];
453             }
454              
455 17         58 return $code;
456             }
457              
458             sub _assign_value_code {
459 388     388   917 my ($sigil, $var, $special, $value_source, $check_type) = @_;
460 388   100     1611 $special //= q{};
461              
462 388 100       910 if ($sigil eq '$') {
463 375 100 66     3021 return $special eq 'ro' ? qq[ Const::Fast::const($var => $value_source); ]
    50          
    100          
464             : $special eq 'alias' && $] < 5.022 ? qq[ Data::Alias::alias $var = $value_source ; ]
465             : $special eq 'alias' ? qq[ $REFALIASING; \\$var = \\($value_source); ]
466             : qq[ $var = $value_source ; ]
467             }
468              
469             # Arrays and hashes, need more type-checking...
470 13 100       38 if ($sigil eq '@') {
471 10 50 33     113 return qq[ { my \$next_value = $value_source; ]
    50          
    50          
472             . $check_type
473             . ( $special eq 'ro' ? qq[ Const::Fast::const($var => \@{\$next_value}); ]
474             : $special eq 'alias' && $] < 5.022 ? qq[ Data::Alias::alias $var = \@{\$next_value} ; ]
475             : $special eq 'alias' ? qq[ $REFALIASING; \\$var = \@{\$next_value} ; ]
476             : qq[ $var = \@{\$next_value} ; ]
477             )
478             . qq[} ];
479             }
480 3 50       21 if ($sigil eq '%') {
481 3 50 33     53 return qq[ { my \$next_value = $value_source; ]
    50          
    50          
482             . $check_type
483             . ( $special eq 'ro' ? qq[ Const::Fast::const($var => \%{\$next_value}); ]
484             : $special eq 'alias' && $] < 5.022 ? qq[ Data::Alias::alias $var = \%{\$next_value} ; ]
485             : $special eq 'alias' ? qq[ $REFALIASING; \\$var = \%{\$next_value} ; ]
486             : qq[ $var = \%{\$next_value} ; ]
487             )
488             . qq[} ];
489             }
490             }
491              
492             sub _unpack_code {
493 367     367   1171 my ($sigil, $var, $name, $default, $special, $vardesc, $context) = @_;
494 367         881 state $type_of = { '$' => q{}, '@' => 'ARRAY', '%' => 'HASH' };
495              
496             # Set up for readonly or aliasing, if specified...
497 367 100       907 if ($special) {
498 4 100 33     82 if ($special eq 'ro') {
    50          
499             _error(q{'is ro' requires the Const::Fast module (which could not be loaded)})
500 2 50       6 if !eval { require Const::Fast; 1 };
  2         575  
  2         1109  
501             }
502             elsif ($special eq 'alias' && $] < 5.022) {
503             _error(q{'is alias' requires the Data::Alias module (which could not be loaded)})
504 0 0       0 if !eval { require Data::Alias; 1 };
  0         0  
  0         0  
505             }
506             }
507              
508             # Set up for default handling, if specified...
509 367         980 my $value_source = qq{ ( !\@_ ? Dios::_error(q{No argument found for $vardesc in call to $context}) : shift) };
510 367         1829 my $type_check = qq[ Dios::_error q{Argument for $vardesc is not \L$type_of->{$sigil}\E ref in call to $context} ]
511             . qq[ if ref(\$next_value) ne '$type_of->{$sigil}';];
512              
513 367 100       1000 if (defined($default)) {
514 36 50 66     128 $default ||= $sigil eq '$' ? 'undef'
    100          
515             : $sigil eq '@' ? '[]'
516             : '{}';
517 36 100       96 my $and_type_test = $sigil eq '$' ? '' : "&& ref(\$_[0]) eq '$type_of->{$sigil}'";
518 36         105 $value_source = qq{ \@_ $and_type_test ? shift() : $default };
519 36         63 $type_check = q{};
520             }
521              
522             # Named params have to be tracked, if they have defaults...
523 367 100       1135 my $note_seen
524             = $name ? qq{ Dios::_error(q{Unexpected second value (}.Dios::_perl($var).q{) for named '$name' parameter in call to $context}) if \$seen{$name}; \$seen{$name} = 1; }
525             : q{};
526              
527             # Return the code...
528 367         968 return _assign_value_code($sigil, $var, $special, $value_source, $type_check)
529             . $note_seen;
530             }
531              
532             sub _unpack_named_slurpy_code {
533 2     2   5 my ($var, $sigil, $name, $special, $vardesc, $context) = @_;
534 2   50     11 $special //= q{};
535              
536             # Must be able to use the module, if it's required
537 2 50 33     9 if ($special eq 'alias' && $] < 5.022) {
538             _error(q{'is alias' requires the Data::Alias module (which could not be loaded)})
539 0 0       0 if !eval { require Data::Alias; 1 };
  0         0  
  0         0  
540             }
541              
542             # Work out how at unpack the arg
543 2 50 33     13 my $unpack_code
    50          
544             = $special eq 'alias' && $] >= 5.022 ? qq{use experimental 'refaliasing';\\\$${name}[\@$name]=\\shift;}
545             : $special eq 'alias' ? qq{ Data::Alias::alias( \$${name}[\@$name] = shift); }
546             : qq{ push $var, shift; };
547              
548 2         9 return qq{ Dios::_error q{No argument found for $vardesc in call to $context} if !\@_; }
549             . $unpack_code;
550             }
551              
552             sub _typecheck_code {
553 96     96   287 my ($sigil, $var, $type, $constraint, $vardesc, $context, $is_slurpy) = @_;
554 96 100       216 $constraint = $constraint ? "sub $constraint" : q{};
555              
556             # Provide a human-readble description for any error message...
557 96         221 $vardesc = qq{q{Value (%s) for $vardesc}};
558              
559 96 100       226 if ($sigil eq '$') {
560 94         471 return qq[{package Dios::Types; validate(q{$type}, $var,$vardesc,$constraint)}];
561             }
562 2 50       9 if ($sigil eq '@') {
563 2 100       8 return qq[{package Dios::Types; validate(q{List[$type]}, \\$var,$vardesc,$constraint)}] if $is_slurpy;
564 1         7 return qq[{package Dios::Types; validate(q{Array[$type]},\\$var,$vardesc,$constraint)}];
565             }
566 0 0       0 if ($sigil eq '%') {
567 0         0 return qq[{package Dios::Types; validate(q{Hash[$type]}, \\$var,$vardesc,$constraint)}];
568             }
569 0         0 die 'Internal error: unable to generate type checking code';
570             }
571              
572             sub _perl {
573 55     55   186356 use Data::Dump 'dump';
  55         111  
  55         4796  
574 7     7   5969 return dump(@_);
575             }
576              
577             our @CARP_NOT = 'Keyword::Declare';
578             sub _error {
579 55     55   342 use Carp;
  55         94  
  55         3904  
580 20     20   15855 croak @_;
581             }
582              
583 55     55   321 use re 'eval';
  55         99  
  55         107896  
584             my $FIELD_DEFN = qr{
585             (?
586             (?&TYPE_SPEC)
587             )? \s*+
588             (?
589             [\$\@%]
590             )
591             (?
592             [.!]?
593             )
594             (?
595             [^\W\d] \w* # Simple identifier
596             )
597             (?
598             \s+ is \s+ req(?:uired)?
599             )?
600             (?:
601             \s+ is \s+
602             (? r[wo] )
603             )?
604             (? # repeat to allow 'is' options in either order
605             \s+ is \s+ req(?:uired)?
606             )?
607             (?
608             \s*+ : \s*+ (?&ATTR)
609             (?:
610             (?: \s*+ : \s*+ | \s++) (?&ATTR)
611             )*+
612             )?
613             (?
614             .*+
615             )
616              
617             (?(DEFINE)
618             (? (?&TYPE_NAME) (?: [&|] (?&TYPE_NAME) )*+ )
619             (? (?&QUAL_IDENT) (?&TYPE_PARAM)?+ )
620             (? \[ (?: [^][]*+ | (?&TYPE_PARAM) )*+ \] )
621             (? (?&IDENT) (?: :: (?&IDENT) )*+ )
622             (? [^\W\d] \w*+ )
623             (? [^\W\d]\w*+ (?! [(] ) )
624             )
625              
626             }xms;
627              
628             my $SHARED_DEFN = qr{
629             (?
630             (?&TYPE_SPEC)
631             )?
632             \s*+
633             (?
634             \$ | \@ | \%
635             )
636             (?
637             [.!]?
638             )
639             (?
640             [^\W\d] \w* # Simple identifier
641             )
642             (?:
643             \s+ is \s+
644             (? r[wo] )
645             )?
646             (?
647             .*
648             )
649              
650             (?(DEFINE)
651             (? (?&TYPE_NAME) (?: [&|] (?&TYPE_NAME) )*+ )
652             (? (?&QUAL_IDENT) (?&TYPE_PARAM)?+ )
653             (? \[ (?: [^][]*+ | (?&TYPE_PARAM) )*+ \] )
654             (? (?&IDENT) (?: :: (?&IDENT) )*+ )
655             (? [^\W\d] \w*+ )
656             )
657              
658             }xms;
659              
660             my $LEXICAL_DEFN = qr{
661             (?
662             (?&TYPE_SPEC)
663             )?
664             \s*+
665             (?
666             \$ | \@ | \%
667             )
668             (?
669             [^\W\d] \w* # Simple identifier
670             )
671             (?
672             .*
673             )
674              
675             (?(DEFINE)
676             (? (?&TYPE_NAME) (?: (?: [&|] | => ) (?&TYPE_NAME) )*+ )
677             (? (?&QUAL_IDENT) (?&TYPE_PARAM)?+ )
678             (? \[ (?: [^][]*+ | (?&TYPE_PARAM) )*+ \] )
679             (? (?&IDENT) (?: :: (?&IDENT) )*+ )
680             (? [^\W\d] \w*+ )
681             )
682              
683             }xms;
684              
685              
686             # These options can be passed in when importing, to change how accessors are generated...
687             my %OIO_accessor_keyword = (
688             'standard' => { rw => 'Std', ro => 'StdRO' },
689             'unified' => { rw => 'Acc', ro => 'Get' },
690             'lvalue' => { rw => 'Lvalue', ro => 'Get' },
691             );
692             @OIO_accessor_keyword{qw< std uni lval >}
693             = @OIO_accessor_keyword{qw< standard unified lvalue >};
694              
695             my %OIO_accessor_generate = (
696             'standard' => {
697             rw => sub { my ($name, $sigil) = @_;
698             my $var = $sigil.$name;
699             my $unpack = $sigil eq '$' ? 'shift' : '@_';
700             return qq{ sub get_$name { shift; $var }
701             sub set_$name { local \$Carp::CarpLevel = 1;
702             shift;
703             $var = $unpack;
704             };
705             };
706             },
707             ro => sub { my ($name, $sigil) = @_; my $var = $sigil.$name;
708             return qq{ sub get_$name { shift; $var } };
709             },
710             },
711              
712             'unified' => {
713             rw => sub { my ($name, $sigil) = @_;
714             my $var = $sigil.$name;
715             my $unpack = $sigil eq '$' ? 'shift' : '@_';
716             return qq{ sub $name { local \$Carp::CarpLevel = 1;
717             shift;
718             if (\@_) {
719             $var = $unpack;
720             }
721             $var
722             }; };
723             },
724             ro => sub { my ($name, $sigil) = @_; my $var = $sigil.$name;
725             return qq{ sub $name { shift; $var } };
726             },
727             },
728              
729             'lvalue' => {
730             rw => sub { my ($name, $sigil) = @_;
731             my $var = $sigil.$name;
732             return qq{ sub $name :lvalue {
733             local \$Carp::CarpLevel = 1;
734             $var
735             }
736             };
737             },
738             ro => sub { my ($name, $sigil) = @_; my $var = $sigil.$name;
739             return qq{ sub $name { $var } };
740             },
741             },
742             );
743             @OIO_accessor_generate{qw< std uni lval >}
744             = @OIO_accessor_generate{qw< standard unified lvalue >};
745              
746             # Convert a 'has' to an OIO variable declaration with attributes...
747             sub _compose_field {
748 30     30   119 my ($type, $var, $traits, $handles, $initializer, $constraint) = @_;
749              
750             # Normalize constraint...
751 30 100       130 $constraint = $constraint ? 'sub ' . substr($constraint, 5) : q{};
752 30 50 66     175 if ($constraint && !defined $type) {
753 0         0 $type = 'Any';
754             }
755              
756             # Read-only or readwrite???
757 30 100       178 my $rw = $traits =~ /\brw\b/ ? 'rw' : 'ro';
758 30         132 my $required = $traits =~ /\breq(?:uired)?\b/;
759              
760             # Did the user specify a particular kind of accessor generation???
761 30         104 my $accessor_type = $^H{'Dios accessor_type'};
762              
763             # Unpack the parsed components of the field declaration...
764 30         182 my ($sigil, $twigil, $name) = $var =~ m{\A ([\$\@%]) ([.!]?+) (\S*+) }xms;
765              
766             # Adapt type to sigil...
767 30 100 50     220 my $container_type = ($sigil eq '@') ? "Array[".($type//'Any')."]"
    100 50        
768             : ($sigil eq '%') ? "Hash[".($type//'Any')."]"
769             : $type;
770              
771             # Is it type-checked???
772 30         74 my $TYPE_SETUP = q{};
773 30         61 my $TYPE_VALIDATOR = q{};
774 30 100       102 if ($type) {
775 28         73 state $validator_num = 0; $validator_num++;
  28         71  
776 28         154 $TYPE_VALIDATOR = qq[ { no warnings; \$Dios::_internal::attr_validator_$validator_num = Dios::Types::validator_for(q{$container_type}, 'Value (%s) for $sigil$name attribute', $constraint ); } ];
777 28         84 $TYPE_SETUP = qq[ :Type( sub{ \$Dios::_internal::attr_validator_$validator_num->(shift) }) ];
778             }
779              
780             # Define accessors...
781 30 100       215 my $access = $twigil ne '.' ? q{} : $OIO_accessor_keyword{$accessor_type}{$rw}."(Name=>q{$name}) $TYPE_SETUP";
782              
783             # Is it a delegated handler???
784 30         66 my $delegators = '';
785 30         144 for my $delegation (split /(?&WS) handles (?&WS) (?(DEFINE) (? \s*+ (?: \# [^\n]*+ \n \s*+ )*+ ))/x, $handles) {
786 0 0       0 next unless $delegation;
787 0 0       0 if ($delegation =~ m{^:(.*)<(.*)>$}xms) {
788 0         0 $delegators .= " :Handles($1-->$2)";
789             }
790             else {
791 0         0 $delegators .= " :Handles($delegation)";
792             }
793             }
794              
795             # Is it initialized???
796 30 100       139 my $init = qq{:Arg(Name=>q{$name} } . ($required ? q{, Mandatory=>1)} : q{)} );
797 30         63 my $INIT_FUNC = q{};
798              
799             # Ensure array and hash attrs are initialized...
800 30 50 33     196 if ($sigil =~ /[\@%]/ && (!$initializer || $initializer =~ m{\A \s*+ \z}xms)) {
      66        
801 15         59 $initializer = '//=()';
802             }
803              
804             # Install the initialization code...
805 30 100       138 if ($initializer =~ m{\A \s*+ (? // \s*+ )? = (? .*+ ) }xms) {
806 16         228 my %init_field = %+;
807 16         100 my $init_val = $init_field{INIT_VAL};
808              
809             # Adapt initializer value to sigil...
810 16 100       84 if ($sigil eq '@') { $init_val = "[$init_val]"; }
  7 100       28  
811 8         26 elsif ($sigil eq '%') { $init_val = "+{$init_val}"; }
812              
813 16 100       96 $init = qq{:DEFAULT(___i_n_i_t__${name}___(\$self)) } . ($init_field{DEFAULT_INIT} ? $init : q{});
814 16         76 $INIT_FUNC = qq{sub ___i_n_i_t__${name}___ { my (\$self) = \@_; $init_val }};
815             }
816             else {
817 14         42 $init .= $initializer;
818             }
819              
820             # Update the attribute setting code...
821 30 100       91 if ($sigil eq '$') {
822 15 50       177 $^H{'Dios attrs'} .= $] < 5.022 ? qq{alias my \$$name = \$_Dios__attr_${name}[\${\$_[0]}];}
823             : qq{ \\ my \$$name = \\ \$_Dios__attr_${name}[\${\$_[0]}];};
824             }
825             else {
826 15 50       184 $^H{'Dios attrs'}
827             .= $] < 5.022 ? qq{alias my $sigil$name = $sigil}.qq{{\$_Dios__attr_${name}[\${\$_[0]}]};}
828             : qq{ \\ my $sigil$name = \$_Dios__attr_${name}[\${\$_[0]}]; };
829             }
830             # Add type-checking code to alias...
831 30 100       99 if ($type) {
832 28         176 $^H{'Dios attrs'} .= qq{ Dios::Types::_set_var_type(q{$type}, \\$sigil$name, 'Value (%s) for $sigil$name attribute', $constraint ); };
833             }
834              
835             # Return the converted syntax...
836 30         279 return qq{ $TYPE_VALIDATOR my \@_Dios__attr_$name : Field $access $delegators $init $TYPE_SETUP; $INIT_FUNC; };
837             }
838              
839             # Convert a typed lexical variable...
840             sub _compose_lexical {
841 3     3   15 my ($type, $variable, $constraint) = @_;
842              
843             # Normalize constraint...
844 3 100       21 $constraint = $constraint ? 'sub ' . substr($constraint, 5) : q{};
845 3 50 66     28 if ($constraint && !defined $type) {
846 0         0 $type = 'Any';
847             }
848              
849             # Is it type-checked???
850 3         8 my $TYPE_SETUP = q{};
851 3 50       14 if (defined $type) {
852 3         19 $TYPE_SETUP = qq[ Dios::Types::_set_var_type(q{$type}, \\$variable, 'Value (%s) assigned to $variable', $constraint ); ];
853             }
854              
855             # Return the converted syntax...
856 3         16 return qq{my $variable; $TYPE_SETUP; $variable = $variable};
857             }
858              
859              
860             # Convert a 'shared' to a class attribute...
861             sub _compose_shared {
862 5     5   41 my ($type, $var, $traits, $initializer, $constraint) = @_;
863              
864             # Normalize constraint...
865 5 100       19 $constraint = $constraint ? 'sub ' . substr($constraint, 5) : q{};
866 5 50 66     26 if ($constraint && !defined $type) {
867 0         0 $type = 'Any';
868             }
869              
870             # Did the user specify a particular kind of accessor generation???
871 5         19 my $accessor_type = $^H{'Dios accessor_type'};
872              
873             # Unpack the parsed components of the shared declaration...
874 5         32 my ($sigil, $twigil, $name) = $var =~ m{\A ([\$\@%]) ([.!]?+) (\S*+) }xms;
875 5 100       21 my $rw = $traits =~ /\brw\b/ ? 'rw' : 'ro';
876              
877             # Generate accessor subs...
878             my $accessors = $twigil ne '.' ? q{}
879 5 50       39 : $OIO_accessor_generate{$accessor_type}{$rw}->($name, $sigil);
880              
881             # Build type checking sub...
882 5         10 my $type_func = q{};
883 5 100       14 if ($type) {
884 1         7 $type_func = qq[ sub ___t_y_p_e__${name}___ { state \$check = Dios::Types::validator_for(q{$type}, 'Value (%s) for \$$name attribute' ); \$check->($_[0]) } ___t_y_p_e__${name}___($sigil$name); ];
885             }
886             else {
887 4         8 $type_func = q{};
888             }
889             # Is it type-checked???
890 5         9 my $TYPE_SETUP = q{};
891 5 100       15 if ($type) {
892 1         5 $TYPE_SETUP = qq[ Dios::Types::_set_var_type(q{$type}, \\$sigil$name, 'Value (%s) for shared $sigil$name attribute', '$sigil', $constraint ); ];
893             }
894              
895             # Return the converted syntax...
896 5         25 return qq{my $sigil$name $initializer; $TYPE_SETUP; $accessors};
897             }
898              
899              
900              
901             sub _multi_dispatch {
902 55     55   435 use Data::Dump 'dump';
  55         108  
  55         28444  
903              
904 58     58   51299 my $subname = shift;
905 58         82 my $kind = shift;
906 58         112 my @arg_list = @_;
907              
908             # Find all possible variants for this call...
909 58         64 our %multis;
910 58   50     69 my @variants = @{ $Dios::multis{$subname} //= [] };
  58         205  
911              
912             # But only those in the right hierarchy, if it's a method call
913 58 100       122 if ($kind eq 'method') {
914 28         41 @variants = grep { $arg_list[0]->isa($_->{class}) } @variants;
  196         1638  
915             }
916              
917             # And only those in the right namespace, if it's a function call...
918             else {
919 30         71 my $caller = caller;
920 30         537 @variants = grep { $_->{class} eq $caller } @variants;
  122         265  
921             }
922              
923             # Eliminate variants that doen't match the argument list...
924 58         311 for my $variant (@variants) {
925 290         354 my $match = eval{ $variant->{validator}(@arg_list) };
  290         727  
926 290 100       50010 if (defined $match) {
927 103         116 @{$variant}{ keys %{$match} } = values %{$match};
  103         414  
  103         153  
  103         209  
928             }
929             else {
930 187         355 $variant = undef;
931             }
932             }
933 58         91 @variants = grep { defined } @variants;
  290         423  
934              
935             # If there's only one left, we're done...
936 58 100       158 return $variants[0] if @variants == 1;
937              
938             # If there isn't one left, we're also done (but not in a good way)...
939             return {
940 6     6   58 impl => sub { my $args = dump(@arg_list);
941 6 50       1342 croak "No suitable '$subname' variant found for call to multi $subname",
942             (($args =~ m{\A \( .* \) \Z}xms) ? $args : qq{($args)});
943             },
944 33 100       100 } if @variants == 0;
945              
946             # There were 2+ left, so pick the one with the most specific signature...
947 27         87 @variants = Dios::Types::_resolve_signatures($kind, @variants);
948              
949             # If there isn't one left, we're also done (but in an even worse way than before)...
950             return {
951 0     0   0 impl => sub { my $args = dump(@arg_list);
952 0 0       0 croak "Dios: Internal error in dispatch resolution of multi $subname",
953             (($args =~ m{\A \( .* \) \Z}xms) ? $args : qq{($args)});
954             },
955 27 50       58 } if @variants == 0;
956              
957             # Otherwise, return the most specific/earliest...
958 27         70 return $variants[0];
959              
960             #====[ NOTE: I still prefer an ambiguity warning, but Perl 6 no longer does that :-( ]=====
961             #
962             # # Otherwise, the call is ambiguous, so report that...
963             # return {
964             # impl => sub {
965             # croak "Ambiguous call to multi '$subname'. Could invoke any of:\n",
966             # map({ my $sig = $_->{sig}; "\t$subname(". join(',',map({$_->{type}} @$sig)) .")\n" } @variants),
967             # "to handle:\n\t$subname(", dump(@arg_list)=~s/^\(|\)$//gr, ")\ncalled";
968             # },
969             # };
970             }
971              
972 55     55   1803259 keytype ParamList is m{
973             \(
974             (?:
975             (?&Parameter)
976             (?:
977             (?: (?&PerlOWS) [:,]
978             (?: (?&Parameter) (?&PerlOWS) , )*+
979             (?&Parameter)?+
980             )?+
981             )?+
982             )?+
983             (?: (?&PerlOWS) --> [^)]*+ )?+
984             (?&PerlOWS)
985             \)
986              
987             (?(DEFINE)
988             (?
989             (?&PerlOWS)
990             (?:
991             # Nameless literal constraint
992             (?&PerlNumber) | (?&PerlQuotelikeQ) | (?&PerlMatch)
993             |
994             (?! , | --> | \) ) # Every component is optional, but there must be at least one
995              
996             # TYPE...
997             (?: (?&TYPE_SPEC) (?&PerlOWS) )?+
998              
999             # NAME...
1000             (?>
1001             : (?&IDENT) \( (?&PerlOWS) [\$\@%] (?&IDENT) (?&PerlOWS) \)
1002             |
1003             : [\$\@%] (?&IDENT)
1004             |
1005             \*
1006             (?:
1007             [\@%] (?&IDENT)?+
1008             |
1009             : (?&IDENT) \( (?&PerlOWS) \@ (?&IDENT) (?&PerlOWS) \)
1010             |
1011             : \@ (?&IDENT)
1012             )
1013             |
1014             [\$\@%] (?&IDENT)?+
1015             )?+
1016              
1017             # OPTIONAL OR REQUIRED...
1018             [?!]?+
1019              
1020             # CONSTRAINT...
1021             (?: (?&PerlOWS) where (?&PerlOWS) (?&PerlBlock) )?+
1022              
1023             # READONLY OR ALIAS...
1024             (?: (?&PerlOWS) is (?&PerlOWS) (?: ro | alias ) )?+
1025              
1026             # DEFAULT VALUE...
1027             (?: (?&PerlOWS) (?://|\|\|)? = (?&PerlOWS) (?&PerlConditionalExpression) )?+
1028             )
1029             )
1030              
1031             (? (?&TYPE_NAME) (?: [&|] (?&TYPE_NAME) )*+ )
1032             (? (?&QUAL_IDENT) (?&TYPE_PARAM)?+ )
1033             (? \[ (?: [^][]*+ | (?&TYPE_PARAM) )*+ \] )
1034             (? (?&IDENT) (?: :: (?&IDENT) )*+ )
1035             (? [^\W\d] \w*+ )
1036             )
1037             }xms;
1038              
1039 0           sub import {
1040 65     65   7182 my (undef, $opt) = @_;
1041              
1042             # What kind of accessors were requested in this scope???
1043             $^H{'Dios accessor_type'}
1044 65   66     1439 = $opt->{accessor} // $opt->{accessors} // $opt->{acc} // q{standard};
      100        
      100        
1045              
1046             # How should the invocants be named in this scope???
1047 65   100     553 my $invocant_name = $opt->{invocant} // $opt->{inv} // q{$self};
      100        
1048 65 50       982 if ($invocant_name =~ m{\A (\$?+) ([^\W\d]\w*+) \Z}xms) {
1049 65   100     898 $^H{'Dios invocant_name'} = ($1||'$').$2;
1050             }
1051             else {
1052 0         0 _error "Invalid invocant specification: '$invocant_name'\nin 'use Dios' statement";
1053             }
1054              
1055 65         139 # Class definitions are translated to encapsulated packages using OIO...
1056 55     55   1665044 keytype Bases is /is (?&PerlNWS) (?&PerlQualifiedIdentifier)/x;
  65         115  
1057 65 50 50     419 keyword class (
1058 65         2696 QualIdent $class_name,
1059             Bases* @bases,
1060             Block $block
1061             )
1062 65 100   48   921 {{{ { package <{$class_name}>; use Object::InsideOut <{ s{^ is (?&WS) (?(DEFINE) (? \s*+ (?: \# .*+ \n \s*+ )*+ ))}{}x for @bases; (@bases ? qq{qw{@bases}} : q{}) }>; do <{ $block }> } }}}
  48 100       3861371  
  48         169  
  48         1355435  
  21         106  
  21         96  
  1010         1846  
  48         8410  
  48         154  
  48         109  
  48         184  
  48         318  
  48         312  
  48         729  
1063              
1064 55     55   1751586 # Function definitions are translated to subroutines with extra argument-unpacking code...
  65         4615  
1065 65 50 50     223 keyword func (
1066 65         1916 QualIdent $sub_name = '',
1067             ParamList $parameter_list = '',
1068 55 0       430 Attributes $attrs = '',
  0 0       0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
1069             Block $block
1070 53     53   3672913 )
  53         179  
  53         149  
  53         103  
  53         109  
  53         106  
1071             {
1072 53         284 # Generate code that unpacks and tests arguments...
1073             $parameter_list = _translate_parameters($parameter_list, func => "$sub_name");
1074              
1075 53 100       237 # Assemble and return the sub definition...
1076 30         351 if (my $return_type = $parameter_list->{return_type}) {
1077             qq{sub $sub_name $attrs { $parameter_list->{code} Dios::Types::_validate_return_type [q{$sub_name}, $return_type], \@_, sub $block } };
1078             }
1079 23 100       371 else {
1080             ($sub_name ? "sub $sub_name;" : q{} )
1081             . qq{sub $sub_name $attrs { $parameter_list->{code} do $block } };
1082 65         492 }
1083             }
1084 55     55   2050019  
1085 65         2720 # Multi definitions are translated to subroutines with extra argument-unpacking code...
1086 65 50 50     210 keyword multi (
1087 65         1457 /method|func/ $type = 'func',
1088 0         0 QualIdent $sub_name = '',
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
1089             ParamList $parameter_list = '',
1090 0         0 Attributes $attrs = '',
1091 34     34   2413761 Block $block
  34         100  
  34         64  
  34         64  
  34         64  
  34         69  
  34         52  
1092             )
1093 0 0       0 {
  34         151  
1094 0         0 # Generate code that unpacks and tests arguments...
  34         94  
1095             $parameter_list = _translate_parameters($parameter_list, $type => "$sub_name");
1096             my $parameter_types = $parameter_list->{spec};
1097 0 0       0  
  34         133  
1098             # Assemble and return the method definition...
1099 34         221 my $code = qq{ BEGIN { *$sub_name = sub { my \$best_variant = Dios::_multi_dispatch('$sub_name', '$type', \@_); \@_ = \@{\$best_variant->{args}//[]}; goto &{\$best_variant->{impl}}; } if ! *${sub_name}{CODE}; } };
1100 55         432  
1101             my $multiname = sprintf 'DIOS_multi_%010d', ++$Dios::multinum;
1102 34 50       105  
1103 0         0 # Assemble and return the sub definition...
1104             if (my $return_type = $parameter_list->{return_type}) {
1105             $code .= qq{sub $multiname; sub $multiname $attrs { local *$multiname = '$sub_name'; $parameter_list->{code}; return { args => \\\@_, impl => sub { local *__ANON__ = '$sub_name'; Dios::Types::_validate_return_type [q{$sub_name}, $return_type], \@_, sub $block } } } };
1106 34         118 }
1107 34         281 else {
1108             $block = substr($block,1,-1);
1109 34         194 $code .= qq{sub $multiname; sub $multiname $attrs { local *$multiname = '$sub_name'; $parameter_list->{code}; return { args => \\\@_, impl => sub { local *__ANON__ = '$sub_name'; $block } } } };
1110             }
1111 34         592 $code .= qq{BEGIN{ push \@{ \$Dios::multis{q{$sub_name}} }, { sig => [$parameter_types], class => __PACKAGE__, validator => \\&$multiname }; }};
1112 65         506  
1113             return $code;
1114 55     55   2281803 }
1115              
1116 65         2840 # Method definitions are translated to subroutines with extra invocant-and-argument-unpacking code...
1117 65 50 50     218 keyword method (
1118 0         0 QualIdent $sub_name = '',
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  65         1426  
1119             ParamList $parameter_list = '',
1120 0         0 Attributes $attrs = '',
1121 0         0 Block $block
1122 131     131   9756643 )
  131         465  
  131         302  
  131         281  
  131         301  
  131         280  
1123             {
1124 0 50       0 # Which kind of aliasing do we need (to create local vars bound to the object's fields)???
  131         680  
1125 131 100       660 my $use_aliasing = $] < 5.022 ? q{use Data::Alias} : q{use experimental 'refaliasing'};
1126 0         0 my $attr_binding = $^H{'Dios attrs'} ? "$use_aliasing; $^H{'Dios attrs'}" : q{};
1127              
1128 131         770 # Generate code that unpacks and tests arguments...
1129 0 0       0 $parameter_list = _translate_parameters($parameter_list, method => "$sub_name");
1130 0         0  
1131 131 100       1899 # Assemble and return the method definition...
1132             ($sub_name ? "sub $sub_name;" : q{} )
1133 0         0 . qq{sub $sub_name $attrs { $attr_binding { $parameter_list->{code}; do $block } } };
  65         425  
1134 0         0 }
1135 55     55   2186692  
1136 0         0 # Submethod definitions are translated like methods, but with special re-routing...
  65         2540  
1137 65 50 50     209 keyword submethod (
1138 0         0 QualIdent $sub_name = '',
  65         1483  
1139 55         475 ParamList $parameter_list = '',
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
1140             Attributes $attrs = '',
1141 0 0       0 Block $block
1142 0 0   8   0 )
  8         585021  
  8         26  
  8         16  
  8         18  
  8         24  
  8         18  
1143             {
1144 8 50       41 # Which kind of aliasing do we need (to create local vars bound to the object's fields)???
1145 0 100       0 my $use_aliasing = $] < 5.022 ? q{use Data::Alias} : q{use experimental 'refaliasing'};
  8         49  
1146             my $attr_binding = $^H{'Dios attrs'} ? "$use_aliasing; $^H{'Dios attrs'}" : q{};
1147              
1148 0 0       0 # Handle any special submethod names...
  8         25  
1149 8 100       36 my $init_args = q{};
    100          
1150 55         404 if ($sub_name eq 'BUILD') {
1151 4         29 # Extract named args for :InitArgs hash (TODO: this should pull out type/required info too)...
1152             my @param_names = $parameter_list =~ m{ : [\$\@%]?+ (\w++) }gxms;
1153              
1154 4         29 # Tell OIO about this constructor args...
1155             $init_args = qq{ BEGIN{ my %$sub_name :InitArgs = map { \$_ => {} } qw{@param_names}; } };
1156              
1157 4         11 # Mark the sub as an initializer
1158             $attrs .= ' :Private :Init';
1159              
1160 4         15 # Repack the arguments from ($self, {attr=>val, et=>cetera}) to ($self, attr=>val, et=>cetera)...
1161             $attr_binding = q{@_ = ($_[0], %{$_[1]});} . $attr_binding;
1162             }
1163             elsif ($sub_name eq 'DESTROY') {
1164 3 50 66     27 # Parameter list will never be satisfied (which breaks cleanup), so don't allow it at all...
1165             return q{die 'submethod DESTROY cannot have a parameter list';}
1166             if $parameter_list && $parameter_list !~ /^\(\s*+\)$/;
1167              
1168 3         9 # Mark it as a destructor...
1169             $attrs .= ' :Private :Destroy';
1170              
1171 3         7 # Rename it so as not to clash with OIO's DESTROY...
1172             $sub_name = '___DESTROY___';
1173             }
1174 1         6 else {
1175             $attr_binding = qq{ if ((ref(\$_[0])||\$_[0]) ne __PACKAGE__) { return \$_[0]->SUPER::$sub_name(\@_[1..\$#_]); } } . $attr_binding;
1176             }
1177              
1178 8         46 # Generate the code to unpack and test arguments...
1179             $parameter_list = _translate_parameters($parameter_list, method => "$sub_name");
1180              
1181 8 50       102 # Assemble and return the method definition...
1182             ($sub_name ? "sub $sub_name;" : q{} )
1183 65         489 . qq{$init_args sub $sub_name $attrs { $attr_binding { $parameter_list->{code}; do $block } } };
1184             }
1185 55     55   2511488  
1186 65         2770 # Components of variable declaration...
1187 55     55   1675909 keytype TypeSpec is m{ (?&TypeSpec)
1188             (?(DEFINE)
1189 0         0 (?
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
1190             (?&TypeName) (?: (?: [&|] | => ) (?&TypeName) )*+
1191 0 0       0 )
1192 0 0       0 (?
1193             \s* (?&TypeName) (?: \s* (?: [&|] | => ) \s* (?&TypeName) )*+ \s*
1194             )
1195 0         0 (?
1196 0 0       0 Match \[ [^]]*+ \]
    0          
1197             |
1198 0         0 (?&PerlIdentifier) \[ (?&TypeSpecSpacey) \]
1199             |
1200             (?&PerlQualifiedIdentifier)
1201 0         0 )
1202             )
1203 65         119 }x;
1204 0     55   0 keytype Var is / [\$\@%] [.!]?+ (?&PerlIdentifier) /x;
  55         1641883  
  65         109  
1205 55     55   1666155 keytype Traits is / (?: (?&PerlOWS) is (?&PerlOWS) (?: ro | rw | req(?:uired)? ) )++ /x;
  65         111  
1206 55     55   1667021 keytype Handles is / (?: (?&PerlOWS) handles (?&PerlOWS)
1207 0         0 (?: (?&PerlIdentifier) | :(?&PerlIdentifier)<(?&PerlIdentifier)> )
1208 65         106 )++ /x;
1209 55     55   1672581 keytype Init is m{ (?: // )?+ = (?&PerlOWS) (?&PerlExpression) }x;
  65         103  
1210 55     55   1658679 keytype Constraint is m{ where (?&PerlOWS) (?&PerlBlock) }x;
1211 0 0 0     0  
1212 65         108 # An attribute definition is translated into an array with a :Field attribute...
1213 65 50 50     208 keyword has (
1214 65         1485 TypeSpec $type = '',
1215 0         0 Var $variable,
1216             Constraint $constraint = '',
1217             Traits $traits = '',
1218 0     30   0 Handles $handles = '',
  30         2200250  
  30         103  
  30         63  
  30         66  
  30         78  
  30         67  
  30         79  
  30         80  
1219 30         173 Init $init = '',
1220 65         420 ) {
1221 0         0 _compose_field($type, $variable, $traits, $handles, $init, $constraint)
1222 55     55   2199855 }
1223 65         2181  
1224 55     55   1659219 keytype ReadTraits is / (?&PerlOWS) is (?&PerlOWS) (?: ro | rw ) /x;
1225 0         0  
1226 0         0 # An attribute definition is translated into an my var with extra code for accessors...
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  65         110  
1227 0 50 50     0 keyword shared (
  65         210  
1228 0 0       0 TypeSpec $type = '',
  55         443  
  65         1420  
1229             Var $variable,
1230 55         460 Constraint $constraint = '',
1231             ReadTraits $traits = '',
1232 5     5   418856 Init $init = '',
  5         16  
  5         11  
  5         8  
  5         10  
  5         16  
  5         12  
1233 5         24 ) {
1234 65         422 _compose_shared($type, $variable, $traits, $init, $constraint)
1235             }
1236 55     55   2205411  
1237 65         2188 # An lexical variable definition is translated into a typed lexical...
1238 65 50 50     213 keyword lex (TypeSpec? $type, Var $variable, Constraint? $constraint) {
1239 65         1533 _compose_lexical($type, $variable, $constraint)
1240 0         0 }
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
1241 0         0  
1242 55         421  
1243 3     3   268036 # Subtypes are handled by Dios::Types...
  3         13  
  3         9  
  3         7  
  3         7  
  65         2913  
1244 3 50 50     20 keyword subtype {{{ use Dios::Types; subtype }}}
  65         239  
1245 65         1394  
  65         1534  
1246 65         2175 # Tail recursion is handled as in Perl 6...
1247 55 50 50 55   2197608 keyword callwith () {{{ goto &{+do{no strict 'refs'; \&{(caller 0)[3]} }} for 1, @_ = grep 1, }}}
  65         209  
  65         2012  
1248 65 50 50     1399 keyword callsame () {{{ goto &{+do{no strict 'refs'; \&{(caller 0)[3]} }} }}}
  65         190  
1249 65     2   366  
  2         179094  
  2         17  
  65         1373  
1250             }
1251 0     55   0  
  0         0  
  0         0  
  0         0  
  0         0  
  55         2032083  
1252 0     1   0 1; # Magic true value required at end of module
  65         550  
  1         66084  
  1         9  
1253 55     1   395  
  65         355  
  1         64717  
  1         8  
1254 55     55   1989532 __END__