File Coverage

blib/lib/Function/Parameters.pm
Criterion Covered Total %
statement 202 214 94.3
branch 88 110 80.0
condition 12 16 75.0
subroutine 31 33 93.9
pod 0 1 0.0
total 333 374 89.0


line stmt bran cond sub pod time code
1             package Function::Parameters;
2              
3 48     48   3131709 use v5.14.0;
  48         574  
4 48     48   269 use warnings;
  48         99  
  48         1424  
5 48     48   281 use warnings::register;
  48         92  
  48         7387  
6              
7 48     48   373 use Carp qw(croak confess);
  48         95  
  48         2881  
8 48     48   338 use Scalar::Util qw(blessed);
  48         88  
  48         5226  
9              
10             sub _croak {
11 247     247   280643 my (undef, $file, $line) = caller 1;
12 247         1934 die @_, " at $file line $line.\n";
13             }
14              
15 48     48   367 use XSLoader;
  48         116  
  48         2119  
16             BEGIN {
17 48     48   165 our $VERSION = '2.002002';
18             #$VERSION =~ s/-TRIAL[0-9]*\z//;
19 48         56811 XSLoader::load;
20             }
21              
22             sub _warn_config_not_a_reference {
23 2     2   1957 warnings::warnif sprintf q{%s: $^H{'%s'} is not a reference; skipping: %s}, __PACKAGE__, HINTK_CONFIG, $^H{+HINTK_CONFIG};
24             }
25              
26             sub _assert_valid_identifier {
27 275     275   561 my ($name, $with_dollar) = @_;
28 275 100       565 my $bonus = $with_dollar ? '\$' : '';
29 275 100       11309 $name =~ /\A${bonus}[^\W\d]\w*\z/
30             or confess qq{"$name" doesn't look like a valid identifier};
31             }
32              
33             sub _assert_valid_attributes {
34 77     77   185 my ($attrs) = @_;
35 77 100       1070 $attrs =~ m{
36             \A \s*+
37             : \s*+
38             (?&ident) (?! [^\s:(] ) (?¶m)?+ \s*+
39             (?:
40             (?: : \s*+ )?
41             (?&ident) (?! [^\s:(] ) (?¶m)?+ \s*+
42             )*+
43             \z
44              
45             (?(DEFINE)
46             (?
47             [^\W\d]
48             \w*+
49             )
50             (?
51             \(
52             [^()\\]*+
53             (?:
54             (?:
55             \\ .
56             |
57             (?¶m)
58             )
59             [^()\\]*+
60             )*+
61             \)
62             )
63             )
64             }sx or confess qq{"$attrs" doesn't look like valid attributes};
65             }
66              
67             sub _reify_type_moose {
68 0     0   0 require Moose::Util::TypeConstraints;
69 0         0 Moose::Util::TypeConstraints::find_or_create_isa_type_constraint($_[0])
70             }
71              
72             sub _malformed_type {
73 0     0   0 my ($type, $msg) = @_;
74 0         0 my $pos = pos $_[0];
75 0         0 substr $type, $pos, 0, ' <-- HERE ';
76 0         0 croak "Malformed type: $msg marked by <-- HERE in '$type'";
77             }
78              
79             sub _reify_type_auto_parameterized {
80             # (str, caller)
81 67 50   67   226 $_[0] =~ /\G ( \w+ (?: :: \w+)* ) \s* /xgc or _malformed_type $_[0], "missing type name";
82 67         166 my $name = $1;
83 67 50       195 $name = "$_[1]::$name" unless $name =~ /::/;
84 67         98 my $fun = do {
85 48     48   413 no strict 'refs';
  48         107  
  48         128991  
86 67 100       644 defined &$name or croak "Undefined type name $name";
87 65         123 \&$name
88             };
89              
90 65 100       182 $_[0] =~ /\G \[ \s* /xgc
91             or return $fun;
92              
93 8         13 my @args;
94 8         16 until ($_[0] =~ /\G \] \s* /xgc) {
95 16 100 33     51 $_[0] =~ /\G , \s* /xgc or _malformed_type $_[0], "missing ',' or ']'"
96             if @args;
97 16         36 push @args, &_reify_type_auto_union;
98             }
99              
100 8     8   34 sub { $fun->([map $_->(), @args]) }
101 8         45 }
102              
103             sub _reify_type_auto_term {
104             # (str, caller)
105 71     71   103 my $compl = 0;
106 71         173 while ($_[0] =~ /\G ~ \s* /xgc) {
107 8         18 $compl++;
108             }
109              
110 71         104 my $inner;
111 71 100       135 if ($_[0] =~ /\G \( \s* /xgc) {
112 4         9 $inner = &_reify_type_auto_union;
113 4 50       13 $_[0] =~ /\G \) \s* /xgc or _malformed_type $_[0], "missing ')'";
114             } else {
115 67         117 $inner = &_reify_type_auto_parameterized;
116             }
117              
118             !$compl
119             ? $inner
120             : sub {
121 4     4   128 my $t = $inner->();
122 4         42 for my $i (1 .. $compl) {
123 8         53 $t = ~$t;
124             }
125             $t
126 4         44 }
127 69 100       169 }
128              
129             sub _reify_type_auto_alternative {
130             # (str, caller)
131 67     67   160 my $fun = &_reify_type_auto_term;
132 65         166 while ($_[0] =~ m!\G / \s* !xgc) {
133 4         8 my $right = &_reify_type_auto_term;
134 4         8 my $left = $fun;
135 4     4   15 $fun = sub { $left->() / $right->() };
  4         165  
136             }
137             $fun
138 65         105 }
139              
140             sub _reify_type_auto_intersection {
141             # (str, caller)
142 59     59   98 my $fun = &_reify_type_auto_alternative;
143 57         124 while ($_[0] =~ /\G & \s* /xgc) {
144 8         14 my $right = &_reify_type_auto_alternative;
145 8         11 my $left = $fun;
146 8     8   35 $fun = sub { $left->() & $right->() };
  8         139  
147             }
148             $fun
149 57         91 }
150              
151             sub _reify_type_auto_union {
152             # (str, caller)
153 45     45   90 my $fun = &_reify_type_auto_intersection;
154 43         104 while ($_[0] =~ /\G \| \s* /xgc) {
155 14         26 my $right = &_reify_type_auto_intersection;
156 14         18 my $left = $fun;
157 14     14   66 $fun = sub { $left->() | $right->() };
  14         236  
158             }
159             $fun
160 43         105 }
161              
162             sub _reify_type_auto {
163 25     25   72988 my ($type) = @_;
164 25         59 my $caller = caller;
165              
166 25         75 $type =~ /\G \s+ /xgc;
167 25         95 my $tfun = _reify_type_auto_union $type, $caller;
168 23 50       94 $type =~ /\G \z/xgc or _malformed_type $type, "trailing garbage";
169 23         1264 $tfun->()
170             }
171              
172             sub _delete_default {
173 1162     1162   2037 my ($href, $key, $default) = @_;
174 1162 100       2697 exists $href->{$key} ? delete $href->{$key} : $default
175             }
176              
177             sub _find_or_add_idx {
178 1     1   2 my ($array, $x) = @_;
179 1         2 my $index;
180 1         5 for my $i (0 .. $#$array) {
181 0 0       0 if ($array->[$i] == $x) {
182 0         0 $index = $i;
183 0         0 last;
184             }
185             }
186 1 50       4 unless (defined $index) {
187 1         3 $index = @$array;
188 1         3 push @$array, $x;
189             }
190             $index
191 1         2 }
192              
193             my %type_map = (
194             function_strict => {},
195             function_lax => {
196             defaults => 'function_strict',
197             strict => 0,
198             },
199             function => { defaults => 'function_strict' },
200              
201             method_strict => {
202             defaults => 'function_strict',
203             attributes => ':method',
204             shift => '$self',
205             invocant => 1,
206             },
207             method_lax => {
208             defaults => 'method_strict',
209             strict => 0,
210             },
211             method => { defaults => 'method_strict' },
212              
213             classmethod_strict => {
214             defaults => 'method_strict',
215             shift => '$class',
216             },
217             classmethod_lax => {
218             defaults => 'classmethod_strict',
219             strict => 0,
220             },
221             classmethod => { defaults => 'classmethod_strict' },
222              
223             around => {
224             defaults => 'method',
225             name => 'required',
226             install_sub => 'around',
227             shift => ['$orig', '$self'],
228             runtime => 1,
229             },
230             (
231             map +(
232             $_ => {
233             defaults => 'method',
234             name => 'required',
235             install_sub => $_,
236             runtime => 1,
237             }
238             ), qw(
239             before after augment override
240             ),
241             ),
242             );
243              
244             my %import_map = (
245             fun => 'function',
246             (
247             map +($_ => $_),
248             qw(
249             method
250             classmethod
251             before
252             after
253             around
254             augment
255             override
256             )
257             ),
258              
259             ':strict' => {
260             fun => 'function_strict',
261             method => 'method_strict',
262             },
263              
264             ':lax' => {
265             fun => 'function_lax',
266             method => 'method_lax',
267             },
268              
269             ':std' => [qw(fun method)],
270             ':modifiers' => [qw(
271             before
272             after
273             around
274             augment
275             override
276             )],
277             );
278             for my $v (values %import_map) {
279             if (ref $v eq 'ARRAY') {
280             $v = {
281             map +($_ => $import_map{$_} || die "Internal error: $v => $_"),
282             @$v
283             };
284             }
285             }
286              
287             sub import {
288 95     95   26087 my $class = shift;
289              
290 95         169 my %imports;
291 95 100       336 @_ = qw(:std) if !@_;
292 95         226 for my $item (@_) {
293 101         174 my $part;
294 101 100       288 if (ref $item) {
295 51         96 $part = $item;
296             } else {
297 50 100       423 my $type = $import_map{$item}
298             or croak qq{"$item" is not exported by the $class module};
299 48 100       177 $part = ref $type
300             ? $type
301             : { $item => $type };
302             }
303 99         526 @imports{keys %$part} = values %$part;
304             }
305              
306 93         178 my %spec;
307              
308 93         364 for my $name (sort keys %imports) {
309 174         509 _assert_valid_identifier $name;
310 169         478 my $proto_type = $imports{$name};
311              
312 169 100       595 $proto_type = {defaults => $proto_type} unless ref $proto_type;
313              
314 169         633 my %type = %$proto_type;
315 169         581 while (my $defaults = delete $type{defaults}) {
316 340 100       923 my $base = $type_map{$defaults}
317 1         191 or confess qq["$defaults" doesn't look like a valid type (one of ${\join ', ', sort keys %type_map})];
318 339         1458 %type = (%$base, %type);
319             }
320              
321 168 100       421 if (exists $type{strict}) {
322 21   66     130 $type{check_argument_count} ||= $type{strict};
323 21         40 delete $type{strict};
324             }
325              
326 168         261 my %clean;
327              
328 168   100     738 $clean{name} = delete $type{name} // 'optional';
329 168 50       839 $clean{name} =~ /\A(?:optional|required|prohibited)\z/
330             or confess qq["$clean{name}" doesn't look like a valid name attribute (one of optional, required, prohibited)];
331              
332 168   100     645 $clean{attrs} = delete $type{attributes} // '';
333 168 100       518 _assert_valid_attributes $clean{attrs} if $clean{attrs};
334              
335 166 100       430 if (!exists $type{reify_type}) {
336 162         371 $clean{reify_type} = \&_reify_type_auto;
337             } else {
338 4   50     15 my $rt = delete $type{reify_type} // '(undef)';
339 4 50       21 if (!ref $rt) {
    50          
340 0 0       0 $rt =
    0          
341             $rt eq 'auto' ? \&_reify_type_auto :
342             $rt eq 'moose' ? \&_reify_type_moose :
343             confess qq{"$rt" isn't a known predefined type reifier};
344             } elsif (ref $rt ne 'CODE') {
345 0         0 confess qq{"$rt" doesn't look like a type reifier};
346             }
347              
348 4         9 $clean{reify_type} = $rt;
349             }
350              
351 166 100       358 if (!exists $type{install_sub}) {
352 148         289 $clean{install_sub} = '';
353             } else {
354 18         32 my $is = delete $type{install_sub};
355 18 100       35 if (!ref $is) {
    50          
356 17         40 _assert_valid_identifier $is;
357             } elsif (ref $is ne 'CODE') {
358 0         0 confess qq{"$is" doesn't look like a sub installer};
359             }
360              
361 18         83 $clean{install_sub} = $is;
362             }
363              
364 166         248 $clean{shift} = do {
365 166   100     549 my $shift = delete $type{shift} // [];
366 166 100       503 $shift = [$shift] if !ref $shift;
367 166         308 my $str = '';
368 166         447 my @shifty_types;
369 166         400 for my $item (@$shift) {
370 84         184 my ($name, $type);
371 84 100       228 if (ref $item) {
372 1 50       4 @$item == 2 or confess "A 'shift' item must have 2 elements, not " . @$item;
373 1         3 ($name, $type) = @$item;
374             } else {
375 83         157 $name = $item;
376             }
377 84         241 _assert_valid_identifier $name, 1;
378 84 50       360 $name eq '$_' and confess q[Using "$_" as a parameter is not supported];
379 84         199 $str .= $name;
380 84 100       226 if (defined $type) {
381 1 50       7 blessed($type) or confess "${name}'s type must be an object, not $type";
382 1         4 my $index = _find_or_add_idx \@shifty_types, $type;
383 1         3 $str .= "/$index";
384             }
385 84         200 $str .= ' ';
386             }
387 166         360 $clean{shift_types} = \@shifty_types;
388 166         489 $str
389             };
390              
391 166         430 $clean{default_arguments} = _delete_default \%type, 'default_arguments', 1;
392 166         347 $clean{named_parameters} = _delete_default \%type, 'named_parameters', 1;
393 166         379 $clean{types} = _delete_default \%type, 'types', 1;
394 166         344 $clean{invocant} = _delete_default \%type, 'invocant', 0;
395 166         350 $clean{runtime} = _delete_default \%type, 'runtime', 0;
396 166         342 $clean{check_argument_count} = _delete_default \%type, 'check_argument_count', 1;
397 166         407 $clean{check_argument_types} = _delete_default \%type, 'check_argument_types', 1;
398              
399 166 100       400 %type and confess "Invalid keyword property: @{[sort keys %type]}";
  1         269  
400              
401 165         583 $spec{$name} = \%clean;
402             }
403              
404 84   100     174 my %config = %{$^H{+HINTK_CONFIG} // {}};
  84         533  
405 84         336 for my $kw (keys %spec) {
406 165         316 my $type = $spec{$kw};
407              
408             my $flags =
409             $type->{name} eq 'prohibited' ? FLAG_ANON_OK :
410 165 100       526 $type->{name} eq 'required' ? FLAG_NAME_OK :
    100          
411             FLAG_ANON_OK | FLAG_NAME_OK
412             ;
413 165 100       389 $flags |= FLAG_DEFAULT_ARGS if $type->{default_arguments};
414 165 100       359 $flags |= FLAG_CHECK_NARGS if $type->{check_argument_count};
415 165 50       383 $flags |= FLAG_CHECK_TARGS if $type->{check_argument_types};
416 165 100       348 $flags |= FLAG_INVOCANT if $type->{invocant};
417 165 50       346 $flags |= FLAG_NAMED_PARAMS if $type->{named_parameters};
418 165 50       388 $flags |= FLAG_TYPES_OK if $type->{types};
419 165 100       367 $flags |= FLAG_RUNTIME if $type->{runtime};
420             $config{$kw} = {
421             HINTSK_FLAGS, => $flags,
422             HINTSK_SHIFT, => $type->{shift},
423             HINTSK_ATTRS, => $type->{attrs},
424             HINTSK_REIFY, => $type->{reify_type},
425             HINTSK_INSTL, => $type->{install_sub},
426 165         860 !@{$type->{shift_types}} ? () : (
427             HINTSK_SHIF2, => $type->{shift_types},
428 165 100       307 ),
429             };
430             }
431 84         14699 $^H{+HINTK_CONFIG} = \%config;
432             }
433              
434             sub unimport {
435 8     8   70 my $class = shift;
436              
437 8 100       26 if (!@_) {
438 3         14 delete $^H{+HINTK_CONFIG};
439 3         267 return;
440             }
441              
442 5         8 my %config = %{$^H{+HINTK_CONFIG}};
  5         48  
443 5         19 delete @config{@_};
444 5         489 $^H{+HINTK_CONFIG} = \%config;
445             }
446              
447              
448             our %metadata;
449              
450             sub _register_info {
451             my (
452 547     547   113141 $key,
453             $declarator,
454             $shift,
455             $positional_required,
456             $positional_optional,
457             $named_required,
458             $named_optional,
459             $slurpy,
460             $slurpy_type,
461             ) = @_;
462              
463 547 100       2874 my $info = {
464             declarator => $declarator,
465             shift => $shift,
466             positional_required => $positional_required,
467             positional_optional => $positional_optional,
468             named_required => $named_required,
469             named_optional => $named_optional,
470             slurpy => defined $slurpy ? [$slurpy, $slurpy_type] : undef,
471             };
472              
473 547         121310 $metadata{$key} = $info;
474             }
475              
476             sub _mkparam1 {
477 16     16   35 my ($pair) = @_;
478 16 100       25 my ($v, $t) = @{$pair || []} or return undef;
  16 100       126  
479 4         16 Function::Parameters::Param->new(
480             name => $v,
481             type => $t,
482             )
483             }
484              
485             sub _mkparams {
486 64     64   87 my @r;
487 64         176 while (my ($v, $t) = splice @_, 0, 2) {
488 38         109 push @r, Function::Parameters::Param->new(
489             name => $v,
490             type => $t,
491             );
492             }
493             \@r
494 64         206 }
495              
496             sub info {
497 18     18 0 7912 my ($func) = @_;
498 18 50       89 my $key = _cv_root $func or return undef;
499 18 100       69 my $info = $metadata{$key} or return undef;
500 16         2062 require Function::Parameters::Info;
501             Function::Parameters::Info->new(
502             keyword => $info->{declarator},
503             nshift => $info->{shift},
504             slurpy => _mkparam1($info->{slurpy}),
505             (
506 16         67 map +("_$_" => _mkparams @{$info->{$_}}),
  64         164  
507             qw(
508             positional_required
509             positional_optional
510             named_required
511             named_optional
512             )
513             )
514             )
515             }
516              
517             'ok'
518              
519             __END__