line
stmt
bran
cond
sub
pod
time
code
1
package Multi::Dispatch;
2
3
1
1
131049
use 5.022;
1
3
4
1
1
19
use warnings;
1
6
1
75
5
1
1
9
use warnings::register 'noncontiguous';
1
2
1
119
6
1
1
8
use re 'eval';
1
2
1
70
7
1
1
5
use mro;
1
3
1
6
8
1
1
461
use Data::Dump;
1
6959
1
71
9
10
our $VERSION = '0.000006';
11
12
1
1
467
use Keyword::Simple;
1
957
1
27
13
1
1
1062
use PPR;
1
54823
1
1174
14
15
# Implement expectation tracking for regexes...
16
{
17
my $expected = q{};
18
my $lastpos = -1;
19
20
sub expect {
21
0
0
0
0
my $pos = pos();
22
0
0
0
if ($pos > $lastpos) {
0
23
0
0
$expected = $_[0];
24
0
0
$lastpos = $pos;
25
}
26
elsif ($pos == $lastpos) {
27
0
0
0
if (index($expected, $_[0]) < 0) {
28
0
0
$expected .= " or $_[0]";
29
}
30
}
31
0
0
return;
32
}
33
34
sub expect_first {
35
0
0
0
0
($expected) = @_;
36
0
0
$lastpos = pos();
37
0
0
return;
38
}
39
40
sub expect_status {
41
0
0
0
0
my ($source, $prefix) = @_;
42
43
0
0
my $before = substr($source, 0, $lastpos) =~ s/\s/ /gxmsr;
44
0
0
my $after = substr($source, $lastpos) =~ s/\n.*//xmsr;
45
0
0
my $indent = "$prefix$before" =~ s/\S/ /gxmsr;
46
47
0
0
return "Expected $expected here:\n\n"
48
. " $prefix$before$after\n"
49
. " $indent^\n"
50
}
51
}
52
53
# This parses a single :where()...
54
my $WHERE_ATTR_PARSER = qr{
55
(?
56
: (?&PerlOWS) where
57
(?{ expect 'the opening paren of the :where constraint' })
58
\(
59
(?&PerlOWS)
60
(?{ expect 'a valid constraint (a value, regex, type, or block)' })
61
(?>(?
62
(?> (? (?>(?&PerlNumber)) )
63
| (? (?>(?&PerlString)) )
64
| (? (?>(?&PerlRegex)) )
65
| (? (?> true | false ) )
66
| (? (?>(?&complex_type)) )
67
| (? undef )
68
| (? (?>(?&PerlBlock)) )
69
| (? \\& (?>(?&PerlIdentifier)) )
70
)
71
|
72
(?= (? [^\)]*+ ) ) # (
73
(?!)
74
))
75
(?{ expect('the closing paren of the :where constraint') })
76
(?&PerlOWS) \)
77
)
78
79
(?(DEFINE)
80
(? (?>(?&unary_type))
81
(?: (?>(?&PerlOWS)) [|&] (?>(?&PerlOWS)) (?>(?&unary_type)) )*+
82
)
83
84
(? \~ (?>(?&PerlOWS)) (?>(?&unary_type))
85
| (?>(?&atomic_type))
86
)
87
88
(? \( (?>(?&PerlOWS)) (?>(?&complex_type)) (?>(?&PerlOWS)) \)
89
| (?> (?>(?&PerlQualifiedIdentifier)) | [[:alpha:]_]\w*:: )
90
(?: (?>(?&PerlOWS)) \[ (?>(?&PPR_balanced_squares)) \] )?+
91
)
92
)
93
94
$PPR::GRAMMAR
95
}xms;
96
97
my $HAS_RETURN_STATEMENT = qr{
98
(?&PerlEntireDocument)
99
100
(?(DEFINE)
101
(?
102
(?>
103
return \b (?: (?>(?&PerlOWS)) (?&PerlExpression) )?+
104
(?{ $Multi::Dispatch::has_return = 1 })
105
|
106
(?> my | state | our ) \b (?>(?&PerlOWS))
107
(?: (?&PerlQualifiedIdentifier) (?&PerlOWS) )?+
108
(?>(?&PerlLvalue)) (?>(?&PerlOWS))
109
(?&PerlAttributes)?+
110
|
111
(?&PerlAnonymousSubroutine)
112
|
113
(?&PerlVariable)
114
|
115
(?>(?&PerlNullaryBuiltinFunction)) (?! (?>(?&PerlOWS)) \( )
116
|
117
(?> do | eval ) (?>(?&PerlOWS)) (?&PerlBlock)
118
|
119
(?&PerlCall)
120
|
121
(?&PerlTypeglob)
122
|
123
(?>(?&PerlParenthesesList))
124
(?: (?>(?&PerlOWS)) (?&PerlArrayIndexer) )?+
125
(?:
126
(?>(?&PerlOWS))
127
(?>
128
(?&PerlArrayIndexer)
129
| (?&PerlHashIndexer)
130
)
131
)*+
132
|
133
(?&PerlAnonymousArray)
134
|
135
(?&PerlAnonymousHash)
136
|
137
(?&PerlDiamondOperator)
138
|
139
(?&PerlContextualMatch)
140
|
141
(?&PerlQuotelikeS)
142
|
143
(?&PerlQuotelikeTR)
144
|
145
(?&PerlQuotelikeQX)
146
|
147
(?&PerlLiteral)
148
)
149
) # End of rule (?)
150
151
)
152
153
$PPR::GRAMMAR
154
}xms;
155
156
# This parses a single parameter specification (they're complicated!)...
157
my $PARAMETER_PARSER = qr{
158
(?
159
(?: (?
160
(?! undef | true | false )
161
(?: (? ! (?&ows) ) )?+
162
(?&PerlQualifiedIdentifier) (?: :: )?+
163
(?: \[ (?>(?&PPR_balanced_squares)) \] )?+
164
(?! (?&ows) => | : ) # Not a named parameter introducer
165
)
166
(?>(?&PerlOWS))
167
)?+
168
(?>
169
(?> (? \\ )
170
(? (? [\$\@%] | (? \& ) )
171
(? (?&varname) )
172
)
173
| (? (?>(?&PerlNumber)) )
174
| (? (?>(?&PerlString)) )
175
| (? (?> true | false ) )
176
| (? (?>(?&PerlRegex)) )
177
| (? undef )
178
| (?
179
(?: (? (? (? \@ ) ) (? (?&varname) ) ) :
180
| (? (? \@ ) ) :
181
)?+
182
\[ (?&ows)
183
(? (?: (?>(?¶meter))
184
(?: (?&comma) (?>(?¶meter)) )*+ )?+
185
)
186
(?&comma)?+
187
(?&ows) \]
188
)
189
| (?
190
(?)
191
(? (?>(?&keyedparam)) (?: (?&comma) (?>(?&keyedparam)) )*+ )
192
(?> (?&comma) (? (?&hashvar) | % (?! (?&ows) \w) ) | )
193
(?&comma)?+
194
|
195
\{ (?&ows)
196
(?>
197
(? (?>(?&keyedparam)) (?: (?&comma) (?>(?&keyedparam)) )*+ )
198
(?> (?&comma) (? (?&hashvar) | % (?! (?&ows) \w) ) | )
199
(?&comma)?+
200
|
201
(?)
202
(?> (? (?&hashvar) | % (?! (?&ows) \w)) (?&comma)?+
203
| (?) (?&ows)
204
)
205
)
206
(?&ows) \}
207
)
208
| (?=
209
(? (? \$ | (? [\@%] ) )
210
(? (?&varname) )
211
)
212
)
213
(? (?>(?&PerlBinaryExpression)) )
214
| (? (? \$ | (? [\@%] ) | (? \& ) )
215
(? (?&varname) )
216
)
217
)
218
(?: (?&ows) (? (?&where_attr) ) )?+
219
(?: (?&ows) (? = )
220
(?&ows) (? (?>(?&PerlConditionalExpression)) )
221
)?+
222
|
223
(? \$ )
224
(?: (?&ows) (? = )
225
(?&ows) (? (?&PerlConditionalExpression)?+ )
226
)?+
227
|
228
(? (? [\@%] ))
229
)
230
)
231
232
(?(DEFINE)
233
(? multi )
234
235
(?
236
(?>
237
(? (?>(?&PerlIdentifier)) | (?>(?&PerlString)) )?+
238
(?&ows) (?: => | : ) (?&ows)
239
(? (?¶meter) )
240
)
241
)
242
243
(? (?>(?&PerlOWS)) )
244
(? (?> (?>(?&PerlOWS)) , (?>(?&PerlOWS)) ) )
245
(? (?> _ \w++ | [[:alpha:]] \w*+) )
246
(? % (?> _ \w++ | [[:alpha:]] \w*+) )
247
248
$WHERE_ATTR_PARSER
249
)
250
}xms;
251
252
our $errpos = 0;
253
my $MULTI_PARSER = qr{
254
(?
255
(?&ows)
256
(?{ expect_first('the name of the multi') })
257
(? (?>(?&PerlIdentifier)) )
258
259
(?>
260
(?&ows) (?{ expect('a valid attribute') }) : (?&ows) (? auto)?+ from
261
(?{ expect('opening paren') }) \(
262
(?&ows) (?{ expect('module name or qualified multi name') })
263
(?
264
(? (?>(?&PerlQualifiedIdentifier)))
265
|
266
\& (? (?>(?&PerlQualifiedIdentifier)))
267
)
268
(?&ows) (?{ expect('closing paren') }) \)
269
(?&ows) (?{ expect('end of declaration') }) (?= ; | \} | \z )
270
|
271
(?&ows) (?{ expect('a valid attribute') }) : (?&ows) (? export)
272
|
273
(?{ expect('a valid attribute') })
274
(?
275
(?: (?&ows)
276
(?: (?&where_attr)
277
| (?&before_attr)
278
| (?&common_attr)
279
| (?&permute_attr)
280
)
281
)*+
282
)
283
284
(?&ows)
285
(?{ expect('a signature') })
286
\(
287
288
(?&ows)
289
(?
290
(?{ expect('a parameter declaration') })
291
(?:
292
(?>(?¶meter))
293
(?: (?&comma)
294
(?{ expect('a parameter declaration') })
295
(?>(?¶meter)) )*+
296
)?+
297
)
298
(?&comma)?+
299
300
(?&ows)
301
(?{ expect('the closing paren of the signature') })
302
\)
303
304
(?&ows)
305
(?{ expect('a valid code block') })
306
(? (?>(?&PerlBlock)) )
307
)
308
309
(?=
310
(?: ; | \} | (?&ows) )*+ (? multimethod | multi )
311
(?&ows) (? (?>(?&PerlIdentifier)) )
312
)?
313
)
314
315
(?(DEFINE)
316
(? : (?&ows) before \b )
317
(? : (?&ows) common \b )
318
(? : (?&ows) permute \b )
319
$PARAMETER_PARSER
320
)
321
}xms;
322
323
my $KEYEDPARAM_PARSER = qr{
324
(?
325
(?>
326
(? (?>(?&PerlIdentifier)) | (?>(?&PerlString)) )?+
327
(?&ows) (?: => | : ) (?&ows)
328
(? $PARAMETER_PARSER )
329
)
330
)
331
}xms;
332
333
# Try to work out what went wrong, if something goes wrong...
334
my $ERROR_PARSER = qr{
335
(?>(?&PerlOWS))
336
(?
337
(? (?>(?&PerlIdentifier)) )
338
(? (?>(?&PerlOWS)) (?>(?&PerlIdentifier)) | )
339
|
340
[^;\}\s]*+
341
)
342
343
$PPR::GRAMMAR
344
}xms;
345
346
# Default redispatcher just punishes bad behaviour...
347
sub next::variant {
348
0
my $subname = (caller 1)[3] || 'main scope';
349
_die(0, "Can't redispatch via next::variant ",
350
"(attempted to redispatch from $subname, which is not a multi)" );
351
}
352
353
sub gen_handler_for {
354
2
2
0
6
my ($keyword, $package) = @_;
355
356
2
5
my $object_pad_active = $^H{'Object::Pad/method'};
357
358
return sub {
359
0
0
0
my ($src_ref) = @_;
360
0
0
my ($caller_package, $file, $line) = caller();
361
362
# Track each multi...
363
0
0
state $multi_ID; $multi_ID++;
0
0
364
365
# Parse the entire multi declaration (if possible)...
366
0
0
${$src_ref} =~ s{\A $MULTI_PARSER }{}xo
367
# Otherwise, report the error...
368
0
0
0
or do {
369
0
0
${$src_ref} =~ m{\A $ERROR_PARSER }xo;
0
0
370
0
0
my %found = %+;
371
0
0
0
my $what = $keyword . ($found{name} ? " $found{name}" : q{});
372
my $DYM = $keyword ne 'multi' ? q{}
373
: $found{name} =~ /\bsub$/ ? qq{(Did you mean: $keyword$found{name2} ...)\n}
374
0
0
0
: $found{name} =~ /\bmethod$/ ? qq{(Did you mean: multimethod$found{name2} ...)\n}
0
0
375
: q{};
376
die "Invalid declaration of $what at $file line $line\n"
377
0
0
. expect_status( ${$src_ref}, $keyword)
0
0
378
. $DYM;
379
};
380
381
# Unpack and normalize the various components of the declaration...
382
my ( $name, $attrs, $params, $body, $nextkeyword, $nextname)
383
0
0
= @+{qw< name attributes params body nextkeyword nextname >};
384
my ( $from, $autofrom, $frommodule, $fromname, $export)
385
0
0
= @+{qw< from autofrom frommodule fromname export>};
386
0
0
0
0
if ($from && $frommodule) {
0
0
387
0
0
0
$fromname //= $name;
388
}
389
elsif ($from && $fromname) {
390
0
0
($frommodule, $fromname) = $fromname =~ m{(.*)::(.*)};
391
}
392
0
0
0
$from //= 0;
393
0
0
0
$frommodule //= q{};
394
0
0
0
$params //= q{};
395
0
0
0
$body //= q{};
396
397
0
0
my ($common, $before, $permute, $constraint) = (q{}, q{}, q{});
398
0
0
0
if ($attrs) {
399
0
0
0
$common = $attrs =~ m{ : (?&PerlOWS) common \b $PPR::GRAMMAR }xo ? $& : q{};
400
0
0
0
$before = $attrs =~ m{ : (?&PerlOWS) before \b $PPR::GRAMMAR }xo ? $& : q{};
401
0
0
0
$permute = $attrs =~ m{ : (?&PerlOWS) permute \b $PPR::GRAMMAR }xo ? $& : q{};
402
0
0
0
$constraint = $attrs =~ m{ (?&where_attr) (?(DEFINE) $WHERE_ATTR_PARSER ) }xo ? $& : q{};
403
}
404
405
# Track contiguity of this declaration...
406
0
0
0
0
my $noncontiguous = !$nextkeyword || $nextkeyword ne $keyword || $nextname ne $name ? 1 : 0;
407
408
# Where are we installing the new variant (normally into the package where it's declared)???
409
0
0
my $target_package = '__PACKAGE__()';
410
0
0
my $target_name = $name;
411
412
# Handle :from imports...
413
0
0
my $new_variants;
414
0
0
0
if ($from) {
0
415
# Find out where the multisub is coming from, and what it's called...
416
0
0
0
my $from_arg = $name eq $fromname ? $from : "&${frommodule}::$fromname";
417
0
0
0
if ($keyword eq 'multimethod') {
418
0
0
_die(0, qq{Can't import multimethod variants via a :from attribute \n}
419
. qq{(Did you mean: "multi $name :from($from_arg)" instead?)});
420
}
421
422
# Are there any variants to be imported???
423
0
0
my $extra_variants = $Multi::Dispatch::impl{$fromname}{$frommodule};
424
0
0
0
if (!$extra_variants) {
425
# Try loading the module, if necessary...
426
0
0
eval "require $frommodule";
427
0
0
$extra_variants = $Multi::Dispatch::impl{$fromname}{$frommodule};
428
0
0
0
if (!$extra_variants) {
429
0
0
_die(0, "Can't find any variants of $keyword $fromname() in package $frommodule");
430
}
431
}
432
433
# Is the requested multi of the right type???
434
{
435
1
1
9
no warnings 'once';
1
1
1
37
0
0
436
1
1
3
no strict 'refs';
1
1
1
513
437
my $from_info
438
0
0
= $Multi::Dispatch::dispatcher_info_for{*{"${frommodule}::$fromname"}{CODE}};
0
0
439
0
0
0
if ($from_info->{keyword} ne $keyword) {
440
0
0
_die(0, "Can't import $keyword $name() variants from $from \n"
441
. "(${from}::$name() is a $from_info->{keyword}, not a $keyword)");
442
}
443
}
444
445
# If we get to here, we have variants, so remember them...
446
0
0
$new_variants = qq{ \@{ \$Multi::Dispatch::impl{'$fromname'}{'$frommodule'} } };
447
}
448
449
# Handle :export requests...
450
elsif ($export) {
451
0
0
$new_variants = qq{ \@{ \$Multi::Dispatch::impl{'$name'}{__PACKAGE__()} } };
452
0
0
$target_package = q{caller()};
453
0
0
$target_name = qq{{caller()."::$name"}};
454
}
455
456
# Can't use :common on multis (only on multimethods)...
457
0
0
0
0
_die(0, "The multi $name can't be given a :common attribute ",
458
"(Did you mean: multimethod $name :common...?)"
459
) if $keyword eq 'multi' && $common;
460
461
# Normalize the :before counter...
462
0
0
0
$before = $before ? '1' : '0';
463
464
# Add the appropriate parameters for methods...
465
0
0
0
0
if ($keyword eq 'multimethod' && !$object_pad_active) {
466
0
0
0
$params = ($common ? '$class :where({$class = ref($class) || $class; 1}), '
467
: '$self :where({ref $self}), '
468
)
469
. $params;
470
}
471
472
0
0
0
0
my $declarator = $object_pad_active && $keyword eq 'multimethod' ? 'method' : 'sub';
473
0
0
0
my $invocant = $declarator eq 'sub' ? undef
0
474
: $common ? '$class'
475
: '$self'
476
;
477
478
# Remember the line number after the keyword (so we can reset it after the new code)...
479
0
0
my $endline = $line + ($& =~ tr/\n//);
480
481
# Unpack the constraint...
482
0
0
my $global_constraint = 0;
483
0
0
my $constraint_desc = $constraint;
484
0
0
0
if ($constraint) {
485
# It's not a per-parameter constraint...
486
0
0
$global_constraint++;
487
488
# Unpack it and normalize it...
489
0
0
$constraint =~ $WHERE_ATTR_PARSER;
490
0
0
my %match = %+;
491
0
0
0
$match{where_class} //= q{};
492
493
# Constraints are tested one level down the call tree (so we need a special wantarray)...
494
0
0
state $WANTARRAY = q{((caller 1)[5])};
495
0
0
state $WANTARRAY_DEF = q{ no warnings 'once'; use experimental 'lexical_subs'; my sub wantarray () { (caller 2)[5] }; };
496
497
# Build the code that implements it...
498
$constraint
499
= $match{where_block} ? "do { $WANTARRAY_DEF do $match{where_block} }"
500
: $match{where_sub} ? "(($match{where_sub})->())"
501
: $match{where_class} eq 'LIST' ? "do { $WANTARRAY }"
502
: $match{where_class} eq 'NONLIST' ? "do { !$WANTARRAY }"
503
: $match{where_class} eq 'SCALAR' ? "do { !$WANTARRAY && defined $WANTARRAY }"
504
: $match{where_class} eq 'NONSCALAR' ? "do { $WANTARRAY || !defined $WANTARRAY }"
505
: $match{where_class} eq 'VOID' ? "do { !defined $WANTARRAY }"
506
: $match{where_class} eq 'NONVOID' ? "do { defined $WANTARRAY }"
507
0
0
0
: $match{where_error} ? _die(0,
0
0
0
0
0
0
0
0
508
"Incomprehensible constraint: :where($match{where_expr})",
509
"in declaration of $keyword $name() ")
510
: _die(0,
511
"Invalid $keyword constraint: :where($match{where_expr})",
512
"in declaration of $keyword $name() ",
513
"(Can't use a literal value or regex or classname there. "
514
."What would it be compared to?)" );
515
}
516
517
518
# First test the variant's overall constraint (if any)...
519
0
0
my $precode = q{};
520
0
0
0
if ($constraint) {
521
0
0
0
0
if ($keyword eq 'multimethod' && !$object_pad_active) {
522
0
0
0
if ($common) {
523
0
0
$constraint = "do {my \$class = \$_[0]; $constraint}";
524
}
525
else {
526
0
0
$constraint = "do {my \$self = \$_[0]; $constraint}";
527
}
528
}
529
530
0
0
$precode .= "return q{Did not satisfy constraint on entire variant: $constraint_desc}
531
unless $constraint;\n"
532
}
533
534
# Dispense with :common from here if implementation will be via sub instead of method...
535
0
0
0
$common = q{} if $declarator eq 'sub';
536
537
# Construct the code that inserts the variant impl into the precedence list...
538
0
0
0
my $existing_variants
539
= $keyword eq 'multimethod'
540
? "map( {\@{\$Multi::Dispatch::impl{$name}{\$_} // []}} \@{mro::get_linear_isa(__PACKAGE__)} )"
541
: "\@{\$Multi::Dispatch::impl{$name}{$target_package}}";
542
543
0
0
0
my $update_derived_classes
544
= $keyword eq 'multimethod'
545
? qq{ for my \$class (\@{mro::get_isarev(__PACKAGE__)}) {
546
next if \$class eq __PACKAGE__;
547
my \$namespace = \$Multi::Dispatch::impl{$name};
548
\@{\$namespace->{\$class}}
549
= Multi::Dispatch::_AtoIsort(
550
map {\@{\$namespace->{\$_} // []}} \@{mro::get_linear_isa(\$class)}
551
);
552
}
553
}
554
: q{};
555
556
# Extract the parameters...
557
0
0
my $orig_param_list = _split_params($params);
558
559
# Build a list of parameter lists (normally just one, unless permuted)...
560
0
0
my @param_lists;
561
0
0
0
if ($export) {
0
562
# No parameter list to process
563
}
564
elsif (!$permute) {
565
0
0
@param_lists = $orig_param_list;
566
}
567
else { # Deep copy each permutation (to avoid aliasing issues)...
568
0
0
0
my @optionals = grep { $_->{optional} || $_->{slurpy} } @{$orig_param_list};
0
0
0
0
569
0
0
0
my @requireds = grep { !$_->{optional} && !$_->{slurpy} } @{$orig_param_list};
0
0
0
0
570
1
1
452
use Algorithm::FastPermute;
1
580
1
507
571
0
0
permute { push @param_lists, [map { {%$_} } @requireds, @optionals] } @requireds;
0
0
0
0
572
}
573
574
# Iterate all permutations and build appropriate variant implementations...
575
0
0
for my $param_list (@param_lists) {
576
0
0
my $constraint_count = $global_constraint;
577
578
# Convert them to argument-processing and validation code (plus other useful info)...
579
0
0
$params = _extract_params($package, $keyword, $name, $constraint_count, $param_list, '@_', undef, $before);
580
0
0
my $code = $precode . $params->{code};
581
0
0
$constraint_count += $params->{constraint_count};
582
583
# Construct the code that detects and allows for the possibility of Object::Pad roles...
584
0
0
0
0
my $add_role_variants = $keyword eq 'multimethod' && exists $INC{'Object/Pad.pm'}
585
? qq{map {\@{\$Multi::Dispatch::impl{$name}{\$_->name}//[]}} eval {use Object::Pad::MOP::Class ':experimental(mop)'; Object::Pad::MOP::Class->for_class(__PACKAGE__())->direct_roles() }}
586
: q{};
587
588
# Implement this as a sub or a method???
589
0
0
0
if ($declarator eq 'method') {
590
0
0
$params->{min_args}++;
591
0
0
$params->{max_args}++;
592
}
593
594
# Generate a suitable signature for use in diagnostic messages...
595
0
0
my $signature = join ', ', map { $_->{source} } @{$param_list};
0
0
0
0
596
0
0
0
if (length($signature) > 50) { $signature = substr($signature,0,50).' ...'; }
0
0
597
0
0
$signature =~ s/[{}]/\\$&/g;
598
599
600
# Create data structure for new variant (if not already imported via a :from)...
601
0
0
0
if (!$from) {
602
0
0
$new_variants .= qq{
603
{
604
pack => $target_package,
605
file => q{$file},
606
line => $line,
607
name => q{$name ($signature)},
608
before => $before,
609
prec => q{$params->{precedence}},
610
sig => $params->{sig},
611
level => '$params->{level}',
612
min => $params->{min_args},
613
max => $params->{max_args},
614
ID => $multi_ID,
615
inception => do { no warnings 'once'; ++\$Multi::Dispatch::inception},
616
code => $declarator $common { no warnings 'redefine'; $code return sub { local *next::variant; *next::variant = pop; local *__ANON__ = q{$name}; } },
617
}, $add_role_variants,
618
};
619
}
620
}
621
622
0
0
my $implementation = qq{
623
\@{\$Multi::Dispatch::impl{$name}{$target_package}}
624
= Multi::Dispatch::_AtoIsort( $existing_variants, $new_variants );
625
$update_derived_classes
626
};
627
628
0
0
0
my $redispatches = $body =~ /\b next::variant \b/x ? 1 : 0;
629
my $dispatcher_code = _build_dispatcher_sub( debug => $^H{'Multi::Dispatch debug'},
630
0
0
verbose => $^H{'Multi::Dispatch verbose'},
631
name => $name,
632
keyword => $keyword,
633
as_sub => $redispatches,
634
invocant => $invocant,
635
);
636
637
# Do we need to clone an existing dispatcher sub that was imported from elsewhere???
638
0
0
my $clone_multi = q{};
639
0
0
0
0
if ($keyword eq 'multi' && !$autofrom) {
640
1
1
8
no strict 'refs';
1
1
1
29
641
1
1
3
no warnings 'once';
1
2
1
999
642
0
0
my $qualified_name = $caller_package.'::'.$name;
643
0
0
0
if (*{$qualified_name}{CODE}) {
0
0
644
0
0
my $info = $Multi::Dispatch::dispatcher_info_for{*{$qualified_name}{CODE}};
0
0
645
0
0
0
0
if ($info && $info->{package} ne $caller_package) {
646
0
0
$clone_multi = "multi $name :autofrom($info->{package}); BEGIN { no warnings;"
647
. "\$Multi::Dispatch::closed{'$keyword'}{'$name'}{$target_package}=0;}";
648
}
649
}
650
}
651
652
# Some components are unnecessary under :export...
653
0
0
my $BEGIN = q{BEGIN};
654
0
0
my $ISOLATION_TEST = qq{
655
if (\$Multi::Dispatch::closed{'$keyword'}{'$name'}{$target_package}) {
656
package Multi::Dispatch::Warning;
657
warn "Isolated variant of $keyword $name()"
658
if warnings::enabled('Multi::Dispatch::noncontiguous');
659
}
660
else {
661
\$Multi::Dispatch::closed{'$keyword'}{'$name'}{$target_package} = $noncontiguous;
662
}
663
};
664
0
0
0
if ($export) {
665
0
0
$BEGIN = $ISOLATION_TEST = q{};
666
}
667
668
0
0
0
my $annotator = $^H{'Multi::Dispatch annotate'}
669
? q{ UNITCHECK { Multi::Dispatch::_annotate(__PACKAGE__, __FILE__) } }
670
: q{};
671
672
0
0
my $installer = qq{
673
$BEGIN {
674
no strict 'refs';
675
$ISOLATION_TEST
676
my \$redefining = $redispatches;
677
if (*$target_name {CODE}) {
678
my \$info = \$Multi::Dispatch::dispatcher_info_for{*$target_name {CODE}};
679
if (!\$info) {
680
\$redefining = 1;
681
package Multi::Dispatch::Warning;
682
warn 'Subroutine $name() redefined as $keyword $name()'
683
if warnings::enabled('redefine');
684
}
685
elsif (\$info->{keyword} ne '$keyword') {
686
die qq{Can't declare a \$info->{keyword} and a $keyword of the same name ("$name") in a single package};
687
}
688
elsif (\$info->{package} ne $target_package ) {
689
\$redefining = 1;
690
package Multi::Dispatch::Warning;
691
warn ucfirst "\$info->{keyword} $name() [imported from \$info->{package}] redefined as $keyword $name()"
692
if ('$frommodule' ne \$info->{package})
693
&& warnings::enabled('redefine');
694
}
695
}
696
else {
697
\$redefining = 1;
698
}
699
if (\$redefining) {
700
no warnings 'redefine';
701
my \$impl = $declarator $common {
702
my \@variants = \@{\$Multi::Dispatch::impl{'$name'}{$target_package}//[]};
703
$dispatcher_code;
704
};
705
*$target_name = \$impl;
706
\$Multi::Dispatch::dispatcher_info_for{\$impl} = {
707
keyword => '$keyword',
708
package => $target_package,
709
};
710
}
711
$annotator
712
$implementation
713
}
714
} =~ s/\n//gr
715
0
0
=~ s//_fix_state_vars($body)/egr;
716
717
# Install that code (and adjust the line numbering)...
718
0
0
${$src_ref} = $clone_multi . $installer . "\n#line $endline\n" . ${$src_ref};
0
0
0
0
719
2
147
};
720
}
721
722
# Export the two new keywords...
723
sub import {
724
1
1
21
my $package = shift;
725
726
1
50
5
if (grep /\A-?debug\Z/, @_) { $^H{'Multi::Dispatch verbose'} = 1;
0
0
727
0
0
$^H{'Multi::Dispatch debug'} = 1; }
728
1
50
4
if (grep /\A-?verbose\Z/, @_) { $^H{'Multi::Dispatch verbose'} = 1; }
0
0
729
1
50
3
if (grep /\A-?annotate\Z/, @_) { $^H{'Multi::Dispatch annotate'} = 1; }
0
0
730
731
# Set up for redispatch...
732
1
4
my $redispatcher = '$' . join q{}, map { ('a'..'z', 'A'..'Z')[rand 52] } 1..20;
20
78
733
734
# Enable warnings for this module class...
735
1
92
warnings->import('Multi::Dispatch');
736
737
1
6
Keyword::Simple::define multi => gen_handler_for('multi', (caller)[0]);
738
1
29
Keyword::Simple::define multimethod => gen_handler_for('multimethod', (caller)[0]);
739
}
740
741
sub _annotate {
742
0
0
my ($package, $file) = @_;
743
744
# Only call once per file...
745
0
state $seen;
746
0
0
return if $seen->{$file}++;
747
748
# Iterate the package's various multis...
749
0
my %line;
750
0
for my $impl (values %Multi::Dispatch::impl) {
751
752
# Rank each variant of the multi...
753
0
0
for my $n (keys @{$impl->{$package} // [] }) {
0
754
755
# Extract the variant and convert it's index to an ordinal...
756
0
my $variant = $impl->{$package}[$n];
757
0
my $nth = _ordinal($n);
758
759
# Create (or append) the ordinal to the annotation for that line...
760
0
my $linenum = $variant->{line};
761
0
0
$line{$linenum} .= ', ' if $line{$linenum};
762
0
$line{$linenum} .= "$nth ($variant->{level})";
763
}
764
}
765
766
# Print out the rankings...
767
0
for my $n (sort {$a<=>$b} keys %line) {
0
768
0
warn "$line{$n} at $file line $n\n";
769
}
770
}
771
772
sub _fix_state_vars {
773
1
1
937
use PPR::X;
1
50038
1
4792
774
0
0
my $str = PPR::X::decomment(shift);
775
776
0
local %Multi::Dispatch::____STATEEND;
777
state $STATE_EXTRACTOR = qr{ (?&PerlEntireDocument)
778
(?(DEFINE)
779
(?
780
0
(?{ pos })
781
((?&PerlStdVariableDeclaration))
782
0
(?= (?>(?&PerlOWS)) = (?{ -$^R }) )?+
783
0
(?{ $Multi::Dispatch::____STATEEND{$^R} = pos(); })
784
)
785
)
786
$PPR::X::GRAMMAR
787
0
}xms;
788
789
0
$str =~ $STATE_EXTRACTOR;
790
791
0
0
return $str if !keys %Multi::Dispatch::____STATEEND;
792
793
0
for my $start (reverse sort { abs($a) <=> abs($b) } keys %Multi::Dispatch::____STATEEND) {
0
794
0
my $assign = $start < 0;
795
0
my $end = $Multi::Dispatch::____STATEEND{$start};
796
0
0
$start = -$start if $assign;
797
0
my $len = $end - $start;
798
0
my $state_var = substr( $str, $start, $len);
799
0
0
$state_var =~ m{
800
\A state \s*+
801
(?> (? (? [\$\@%]) \s*+ \w++ ) \s*+
802
| \( \s*+ (? [^)]*+ ) \s*+ \)
803
)
804
}xms
805
or next;
806
0
my %cap = %+;
807
0
state $next_varname = 'static0000000000';
808
0
0
if (exists $cap{single}) {
0
809
0
my $varname = 'Multi::Dispatch::_____' . $next_varname++;
810
0
0
substr($str, $start, $len) = "\\state $cap{single} = \\$cap{sigil}$varname;"
811
. ($assign ? "\$${varname}_init++ or $cap{single}" : q{});
812
}
813
elsif (exists $+{multiple}) {
814
0
my $replacement;
815
0
for my $state_var (split /\s*+,\s*+/, $cap{multiple}) {
816
0
my $sigil = substr($state_var,0,1);
817
0
my $varname = 'Multi::Dispatch::_____' . $next_varname++;
818
0
$replacement .= "\\state $state_var = \\$sigil$varname;";
819
}
820
0
substr($str, $start, $len) = $replacement;
821
}
822
}
823
824
0
return $str;
825
}
826
827
# Topological sort of a list of signatures...
828
sub _AtoIsort {
829
return
830
0
_toposort_sigs( grep { $_->{before} } @_ ),
831
0
0
_toposort_sigs( grep { !$_->{before} } @_ );
0
832
}
833
834
sub _toposort_sigs {
835
0
0
my @sigs = @_;
836
837
# 0. Build look-up table for signature records and original ordering...
838
0
my %sig = map { $_ => $_ } @sigs;
0
839
840
# 1. Compute narrowness relationships between signatures...
841
0
my %narrowness;
842
0
for my $i (keys @sigs) {
843
0
for my $j ($i+1..$#sigs) {
844
0
my $narrower = _narrowness($sigs[$i], $sigs[$j]);
845
0
$narrowness{ $sigs[$i] }{ $sigs[$j] } = $narrower;
846
0
$narrowness{ $sigs[$j] }{ $sigs[$i] } = -$narrower;
847
}
848
}
849
850
# 2. Compute relative narrowness of all possible pairs of signatures...
851
0
my %less_narrow = map { $_ => {} } keys %sig;
0
852
0
for my $sig1 (keys %narrowness) {
853
0
for my $sig2 (keys %narrowness) {
854
0
0
next if $sig1 eq $sig2;
855
856
0
my $narrowness = $narrowness{$sig1}{$sig2};
857
0
0
if ($narrowness > 0) { $less_narrow{$sig1}{$sig2} = 1; }
0
0
858
0
elsif ($narrowness < 0) { $less_narrow{$sig2}{$sig1} = 1; }
859
}}
860
861
# 3. Partition into sets of equally narrow signatures...
862
0
my @partitions;
863
0
while ( my @narrowest = grep { ! %{ $less_narrow{$_} } } keys %less_narrow ) {
0
0
864
865
# Put full signature records into each partition (not just signature descriptors)...
866
0
push @partitions, [map { $sig{$_} } @narrowest];
0
867
868
# Update graph by removing now-partitioned nodes...
869
0
delete @less_narrow{@narrowest};
870
0
delete @{$_}{@narrowest} for values %less_narrow;
0
871
}
872
873
# 4. Sort each partition by its precedence or originating class/package or inception...
874
0
for my $partition (@partitions) {
875
$partition = [sort { $b->{prec} cmp $a->{prec}
876
||
877
( $a->{pack} eq $b->{pack} ? 0
878
: $a->{pack}->isa($b->{pack}) ? -1
879
: $b->{pack}->isa($a->{pack}) ? +1
880
: 0
881
)
882
||
883
$a->{inception} <=> $b->{inception}
884
0
0
0
} @{$partition}
0
0
0
0
0
885
];
886
}
887
888
# 5. Concatenate all partitions and return...
889
0
return map { @{$_} } @partitions;
0
0
890
}
891
892
sub _narrowness {
893
0
0
my ($x, $y) = map { $_->{sig} } @_;
0
894
0
my $order = 0;
895
896
0
0
for my $n (0..($#$x < $#$y ? $#$y : $#$x)) {
897
0
my ($xn, $yn) = ($x->[$n], $y->[$n]);
898
899
0
0
0
if (!defined($xn) && !defined($yn)) { next; }
0
0
0
0
0
0
0
0
0
900
0
0
elsif ( defined($xn) && !defined($yn)) { return 0 if $order > 0; $order = -1; }
0
901
0
0
elsif (!defined($xn) && defined($yn)) { return 0 if $order < 0; $order = +1; }
0
902
elsif ( ref($xn) && ref($yn) ) {
903
0
0
if ($xn->is_subtype_of($yn) ) { return 0 if $order > 0; $order = -1; }
0
0
0
0
904
0
0
elsif ($yn->is_subtype_of($xn) ) { return 0 if $order < 0; $order = +1; }
0
905
}
906
elsif ( !ref($xn) && !ref($yn) ) {
907
0
0
0
if ($xn eq $yn) { next }
0
0
0
0
908
0
0
elsif ($yn eq 'OBJ' || eval{$xn->isa($yn)}) { return 0 if $order > 0; $order = -1; }
0
0
909
0
0
elsif ($xn eq 'OBJ' || eval{$yn->isa($xn)} ) { return 0 if $order < 0; $order = +1; }
0
0
910
0
else { return 0; }
911
}
912
}
913
914
0
return $order;
915
}
916
917
sub _build_dispatcher_sub {
918
0
0
my %arg = @_;
919
920
# Code to redispatch to deepest non-multi ancestor method, if no suitable multimethod...
921
0
0
my $updispatch = $arg{keyword} eq 'multimethod'
922
? qq{ { no strict 'refs'; my \$uptarget; for my \$nexttarget (\@{mro::get_linear_isa(__PACKAGE__)} ) { next if exists \$Multi::Dispatch::impl{'$arg{name}'}{\$nexttarget} || ! *{\$nexttarget . '::$arg{name}'}{CODE}; \$uptarget = \$nexttarget; last; } goto &{\$uptarget . '::$arg{name}'} if \$uptarget; } }
923
: q{};
924
925
# Generate the dispatch code...
926
0
my $code = q{
927
928
929
my @failures;
930
931
932
warn sprintf "\nDispatching call to ("
933
. join(', ', map({Data::Dump::dump($_)} @_))
934
. ") at %s line %s\\n", (caller)[1,2];
935
936
while (my $variant = shift @variants) {
937
# Skip variants that can't possibly work...
938
939
# Extract the debugging information...
940
my ($level, $name, $package, $file, $line)
941
= @{$variant}{qw};
942
$name = $package.'::'.$name;
943
944
945
if (@_ < $variant->{min}) {
946
947
# Record skipped dispatch candidates...
948
my $at_least = $variant->{min} == $variant->{max} ? 'exactly' : 'at least';
949
push @failures, qq{ $level: $name\n},
950
qq{ defined at $file line $line\n},
951
qq{ --> SKIPPED: need $at_least $variant->{min} args but found only }. scalar(@_) . "\n";
952
953
next;
954
}
955
if (@_ > $variant->{max}) {
956
957
# Record skipped dispatch candidates...
958
my $at_most = $variant->{min} == $variant->{max} ? 'exactly' : 'at most';
959
push @failures, qq{ $level: $name\n},
960
qq{ defined at $file line $line\n},
961
qq{ --> SKIPPED: need $at_most $variant->{max} args but found }. scalar(@_) . "\n";
962
963
next;
964
}
965
966
# Test the viability of this variant...
967
my $handler = ;
968
969
# Execute the variant if appropriate...
970
if (ref $handler) {
971
972
# Report the successful dispatch (and the preceding failures)...
973
warn $_ for @failures,
974
qq{ $level: $name\n},
975
qq{ defined at $file line $line\n},
976
qq{ ==> SUCCEEDED\n};
977
978
979
# Add the redispatch mechanism to the argument list...
980
push @_, __SUB__();
981
982
# And then execute the variant...
983
goto &{$handler};
984
}
985
986
# Otherwise, record another unviable variant...
987
else {
988
push @failures, qq{ $level: $name\n},
989
qq{ defined at $file line $line\n},
990
qq{ --> $handler\n};
991
}
992
993
}
994
995
996
997
# If no viable variant, throw an exception (with the extra debugging info)...
998
999
if (1 == grep /-->/, @failures) {
1000
die sprintf( "Can't call (%s)\\n"
1001
. "at %s line %s\\n",
1002
join(', ', map({Data::Dump::dump($_)} @_)),
1003
(caller)[1,2]), map { s/SKIPPED: //r } grep /-->/, @failures;
1004
}
1005
1006
die sprintf( "No suitable variant for call to ()\\n"
1007
. "with arguments: (%s)\\n"
1008
. "at %s line %s\\n",
1009
join(', ', map({Data::Dump::dump($_)} @_)),
1010
(caller)[1,2]) , @failures ;
1011
1012
0
0
} =~ s{ (.*?) }{ $arg{verbose} ? $1 : q{} }egxmsr
1013
0
0
=~ s{ (.*?) }{ $arg{debug} ? $1 : q{} }egxmsr
1014
0
0
=~ s{ }{ $arg{invocant} ? q{$_[0]->${\$variant->{code}}(@_[1..$#_])}
1015
: q{&{$variant->{code}}} }egxmsr
1016
0
0
=~ s{ }{ $arg{invocant} ? "unshift \@_, $arg{invocant};" : q{} }egxmsr
1017
0
=~ s{ }{ $updispatch }egxmsr
1018
0
0
=~ s{ < ([A-Z_]++) > }{ $arg{lc $1} // die 'Internal error' }egxmsr
1019
=~ s{ \s \# \N* }{}gxmsr;
1020
1021
0
0
if ($arg{as_sub}) {
1022
0
$code = "goto &{sub{$code}}";
1023
}
1024
0
return $code;
1025
}
1026
1027
# Break a single parameter list into individual parameters, classifying their components...
1028
sub _split_params {
1029
0
0
my ($params) = @_;
1030
1031
0
my @split_params;
1032
0
while ($params =~ m{\G (?&comma)?+ (? $PARAMETER_PARSER ) }gxmso) {
1033
0
push @split_params, {%+};
1034
}
1035
1036
0
return \@split_params;
1037
}
1038
1039
# Convert a textual parameter list to an actual list of params...
1040
sub _extract_params {
1041
0
0
my ($package, $keyword, $name, $constraint_count, $params, $source_var, $source_var_desc, $before) = @_;
1042
1043
0
my $seen_option;
1044
0
my $seen_slurpy = 0;
1045
0
my ($req_count, $opt_count, $destructure_count) = (0,0,0);
1046
1047
# "Nameless" parameters get an improbable name...
1048
0
state $nameless_name = '$______' . join('', map { ('a'..'Z','A'..'Z')[rand 52] } 1..20) . '_____';
0
1049
0
state $nameless_num = 1;
1050
1051
# Split parameter list (if not already done)...
1052
0
0
if (!ref $params) {
1053
0
$params = _split_params($params);
1054
}
1055
1056
# Extract and process each parameter...
1057
0
my @params;
1058
my @sig;
1059
0
for my $param (@{$params}) {
0
1060
1061
# Extend signature (trivially, so far)...
1062
0
push @sig, 'undef';
1063
1064
# Handle defaults...
1065
$param->{default} = 'undef'
1066
0
0
0
if exists $param->{default} && $param->{default} =~ /\A\s*\Z/;
1067
0
my $default = $param->{default};
1068
0
0
if (defined $default) {
1069
0
0
if (exists $param->{slurpy}) {
1070
0
_die(1, "A slurpy parameter ($param->{var}) may not have a default value: = $default");
1071
}
1072
1073
0
local $Multi::Dispatch::has_return = 0;
1074
0
0
0
if ($default =~ /\b return \b/x
0
1075
&& $default =~ $HAS_RETURN_STATEMENT
1076
&& $Multi::Dispatch::has_return) {
1077
0
_die(1, "Default value for parameter $param->{var} "
1078
. "cannot include a 'return' statement\n");
1079
}
1080
}
1081
0
0
0
if ($seen_slurpy) {
0
0
1082
0
_die(1,"Can't specify another parameter ($param->{parameter}) after the slurpy parameter",
1083
"in declaration of $keyword $name()")
1084
}
1085
elsif ($seen_option && !$param->{slurpy} && !$param->{optional}) {
1086
0
_die(1, "Can't specify a required parameter ($param->{parameter}) "
1087
."after an optional or slurpy parameter",
1088
"in declaration of $keyword $name()");
1089
}
1090
1091
0
0
$seen_option ||= $param->{optional};
1092
0
0
$seen_slurpy++ if $param->{slurpy};
1093
1094
# Track number of constraints on this param...
1095
0
my $param_constraint_count = 0;
1096
0
my $param_constraint = undef;
1097
1098
# Normalize code parameters...
1099
0
0
$param->{subby} = '\\' if $param->{subby};
1100
1101
# Name any unnamed parameter...
1102
0
0
$param->{var} //= $nameless_name . $nameless_num++;
1103
1104
# Convert constraints to code (if not already done)...
1105
0
0
if (!exists $param->{constraint_code}) {
1106
# Handle prefix type constraints...
1107
0
0
if ($param->{type}) {
1108
0
$param_constraint_count++;
1109
0
$param->{constraint_desc} = $param->{type};
1110
1111
0
$param_constraint = do {
1112
0
my $type = $param->{type} =~ s{^!}{}r;
1113
0
0
my $not = $param->{antitype} ? '!' : '';
1114
0
0
if ($type eq 'OBJ') {
0
1115
0
$sig[-1] = qq{q{$not$type}};
1116
$param->{antitype}
1117
0
0
? qq{ (eval { !Scalar::Util::blessed($param->{var}) || Scalar::Util::reftype($param->{var}) eq 'REGEXP'}) }
1118
: qq{ (eval { Scalar::Util::blessed($param->{var}) && Scalar::Util::reftype($param->{var}) ne 'REGEXP'}) };
1119
}
1120
elsif ($type =~ m{ \A [[:upper:]]++ \Z }xms) {
1121
$param->{antitype}
1122
0
0
? "((Scalar::Util::reftype($param->{var})//q{}) ne '$type')"
1123
: "((Scalar::Util::reftype($param->{var})//q{}) eq '$type')";
1124
}
1125
else {
1126
0
0
my $sigil = substr($param->{var}//'$',0,1);
1127
0
0
_die(1, "Can't specify return type ($not$type) on code parameter $param->{var}\nin declaration of $keyword $name()")
1128
if $sigil eq '&';
1129
my $type_check = eval qq{ no warnings; package $package; } .
1130
( $sigil eq '@' ? qq{ ((ArrayRef[$type])->inline_check('\\$param->{var}')) }
1131
: $param->{array} ? qq{ ((ArrayRef[$type])->inline_check( '$param->{var}')) }
1132
: $sigil eq '%' ? qq{ (( HashRef[$type])->inline_check('\\$param->{var}')) }
1133
0
0
: $param->{hash} ? qq{ (( HashRef[$type])->inline_check( '$param->{var}')) }
0
0
0
1134
: qq{ (($type)->isa('Type::Tiny') || die
1135
and ( $type )->inline_check( '$param->{var}')) }
1136
);
1137
0
0
if (defined $type_check) {
1138
0
state %seen;
1139
0
0
0
if (!$seen{$type}++
0
1140
&& eval qq{ no warnings; grep defined, \@${type}::{qw} }
1141
&& warnings::enabled('ambiguous')
1142
) {
1143
0
warn qq{"$type" constraint is ambiguous (did you mean "Object::" instead?)}
1144
. ' at ' . join(' line ', (caller 1)[1,2]) . "\n";
1145
}
1146
0
$sig[-1] = "($not$type)";
1147
0
"$not$type_check";
1148
}
1149
else {
1150
0
$type =~ s/^::|::$//g;
1151
0
$sig[-1] = qq{q{$not$type}};
1152
$param->{antitype}
1153
0
0
? qq{ (eval { !Scalar::Util::blessed($param->{var}) || !$param->{var}->isa(q{$type}) }) }
1154
: qq{ (eval { Scalar::Util::blessed($param->{var}) && $param->{var}->isa(q{$type}) }) };
1155
}
1156
}
1157
};
1158
}
1159
1160
# Handle expression constraints...
1161
0
0
0
if ($param->{expr} && $param->{expr} ne $param->{var}) {
1162
0
$param_constraint_count++;
1163
0
0
$param_constraint .= '&&' if defined $param_constraint;
1164
0
$param_constraint .= qq{eval{$param->{expr}}};
1165
0
0
$param->{constraint_desc} .= ' and ' if $param->{constraint_desc};
1166
0
$param->{constraint_desc} .= $param->{expr};
1167
}
1168
1169
# Handle :where constraints...
1170
0
0
if ($param->{constraint}) {
1171
0
$param_constraint_count++;
1172
0
0
$param->{constraint_desc} .= ' and ' if $param->{constraint_desc};
1173
0
$param->{constraint_desc} .= $param->{constraint} =~ s{\A:where\(\{? | \}?\)\Z}{}gxmsr;
1174
0
0
$param_constraint .= '&&' if defined $param_constraint;
1175
0
$param->{constraint} =~ $WHERE_ATTR_PARSER;
1176
0
my %match = %+;
1177
$param_constraint
1178
.= $match{where_block} ? "do $match{where_block}"
1179
: $match{where_sub} ? "(($match{where_sub})->($param->{var}))"
1180
: $match{where_undef} ? "do { ! defined($param->{var}) }"
1181
: $match{where_bool} ? "do { BEGIN { die 'Use of $match{where_bool} as a parameter"
1182
. "constraint requires Perl v5.36 or later'"
1183
. "if \$] < 5.036 }"
1184
. "use builtin 'is_bool';"
1185
. "defined($param->{var})"
1186
. "!ref($param->{var})"
1187
. "&& $param->{var} == $match{where_bool}"
1188
. "&& builtin::is_bool($param->{var})"
1189
. "}"
1190
: exists $match{where_num}
1191
? "do { no warnings 'numeric';"
1192
. "defined($param->{var})"
1193
. "&& ($match{where_num} == $param->{var}) }"
1194
: $match{where_error} ? _die(1, "Incomprehensible constraint: "
1195
. "$param->{constraint}",
1196
"in declaration of parameter $param->{var} "
1197
. "of $keyword $name()\n"
1198
)
1199
: $match{slurpy} ? _die(1, "Slurpy parameter $param->{var} can't be given"
1200
. " a string, an undef, or a regex"
1201
. " as a constraint: "
1202
. "$param->{constraint}",
1203
"in declaration of parameter $param->{var} "
1204
. "of $keyword $name() ",
1205
"(Perhaps you wanted: "
1206
. ":where({ $param->{var} ~~ $match{where_expr} })"
1207
)
1208
: $match{where_str} ? "(defined($param->{var}) && $match{where_str} eq $param->{var})"
1209
: $match{where_pat} ? "(defined($param->{var}) && $param->{var} =~ $match{where_pat})"
1210
1211
0
0
: $match{where_class} ? do {
0
0
0
0
0
0
0
0
0
1212
0
my $type = $match{where_class};
1213
0
0
if ($type =~ m{ \A [[:upper:]]++ \Z }xms) {
1214
0
"((Scalar::Util::reftype($param->{var})//q{}) eq q{$type})"
1215
}
1216
else {
1217
0
my $type_check = eval qq{ package $package; ($type)->isa('Type::Tiny') || die and ($type)->inline_check(q{$param->{var}}); };
1218
0
0
if (defined $type_check) {
1219
0
0
0
$sig[-1] = $sig[-1] eq 'undef' || $sig[-1] =~ /^q\{/
1220
? "($type)"
1221
: "(($sig[-1])&($type))";
1222
0
$type_check;
1223
}
1224
else {
1225
_die(1, "Can't parameterize a Perl class ($type})\nin a :where constraint")
1226
0
0
if $match{where_class_params};
1227
0
$type =~ s/^::|::$//g;
1228
0
0
$sig[-1] = qq{q{$type}}
1229
if $sig[-1] eq 'undef';
1230
0
"(eval { Scalar::Util::blessed($param->{var}) && $param->{var}->isa(q{$type}) })";
1231
}
1232
}
1233
}
1234
: _die(1, "Internal error in constraint processing")
1235
;
1236
}
1237
1238
# Finalize constraints...
1239
0
$param->{constraint_code} = $param_constraint;
1240
}
1241
1242
# Handle aliasing...
1243
0
0
if ($param->{alias}) {
1244
0
$param_constraint_count++;
1245
$param->{alias_constraint}
1246
= $param->{sigil} eq '$' ? 'SCALAR'
1247
: $param->{sigil} eq '@' ? 'ARRAY'
1248
: $param->{sigil} eq '%' ? 'HASH'
1249
0
0
: $param->{sigil} eq '&' ? 'CODE'
0
0
0
1250
: _die(1, "Internal error in alias processing");
1251
}
1252
1253
# Track the precedence and arities of the surrounding variant...
1254
0
$constraint_count += $param_constraint_count;
1255
0
0
0
$destructure_count++ if $param->{array} || $param->{hash};
1256
0
0
0
$req_count++ if !$param->{optional} && !exists $param->{slurpy};
1257
0
0
$opt_count++ if $param->{optional};
1258
1259
# Remember the parameter...
1260
0
push @params, $param;
1261
}
1262
1263
# Convert the parameter to inlineable code...
1264
0
my $code = q{};
1265
1266
# Does the variant handle this many arguments???
1267
0
0
my $invocant_count = ($keyword eq 'multimethod' ? 1 : 0);
1268
0
0
if ($source_var ne '@_') {
1269
0
my $min_args = $req_count - $invocant_count;
1270
0
my $max_args = $req_count - $invocant_count + $opt_count;
1271
0
$code .= "return q{Not enough arguments (need at least $min_args)}
1272
if $source_var < $req_count;\n";
1273
0
0
if (!$seen_slurpy) {
1274
0
$code .= "return q{Too many arguments (need at most $max_args)}
1275
if $source_var > $req_count + $opt_count;\n";
1276
}
1277
}
1278
1279
# Validate slurpy (if any)...
1280
0
my $slurpables = "($source_var - $req_count - $opt_count)";
1281
0
0
0
if ($seen_slurpy && $params[-1]{sigil} eq '%') {
1282
$code .= "{Multi::Dispatch::_die(1, 'Odd number of arguments passed to slurpy "
1283
. (!$params[-1]{var} || $params[-1]{var} =~ /\A._____/ ? 'final' : $params[-1]{var})
1284
0
0
0
. " parameter of $keyword $name()') if $slurpables > 0 && $slurpables % 2;}\n"
1285
}
1286
1287
# Install defaults and check constraints on aliased params and code params...
1288
0
for my $param_num (0..$#params) {
1289
0
my $param = $params[$param_num];
1290
0
my $param_ord = _ordinal($param_num);
1291
1292
$code .= "local \$_[$param_num] = $param->{default} if \$#_ < $param_num;"
1293
0
0
if exists $param->{default};
1294
1295
0
0
if ($param->{subby}) {
0
1296
0
$code .= "{ use Scalar::Util 'reftype'; return q{$param_ord argument was not a subroutine reference, so it could not be bound to code parameter $param->{var}} if \@_ > $param_num && (reftype(\$_[$param_num])//'') ne 'CODE';}";
1297
1298
# For unaliased code parameters, have to "copy" the sub...
1299
0
0
if (!$param->{alias}) {
1300
0
$code .= "local \$_[$param_num] = do{ my \$s = \$_[$param_num]; sub { goto &\$s }; };";
1301
}
1302
}
1303
elsif ($param->{alias}) {
1304
0
my $desc = lc($param->{alias_constraint});
1305
0
$code .= "{ use Scalar::Util 'reftype'; return q{$param_ord argument was not a $desc reference, so it could not be aliased to parameter \\$param->{var}} if \@_ > $param_num && (reftype(\$_[$param_num])//'') ne '$param->{alias_constraint}';}";
1306
}
1307
}
1308
1309
# Declare and initialize non-slurpy parameters...
1310
0
0
my $paramassignlist = '('.join(', ', map {($_->{subby}//$_->{alias}//q{}).$_->{var}} @params).')';
0
0
1311
0
0
my $paramdecllist = '('.join(', ', map { $_->{subby} ? () : $_->{var} } @params).')';
0
1312
0
0
my $paramsubdecllist = join(' ', map { $_->{subby} ? "sub $_->{name};" : () } @params);
0
1313
1314
0
$code .= "my $paramdecllist; $paramsubdecllist { no warnings 'misc'; $paramassignlist = $source_var;}\n";
1315
1316
# Construct the code to destructure and validate each argument...
1317
0
for my $param_num (keys @params) {
1318
0
my $param = $params[$param_num];
1319
0
my $param_ord = _ordinal($param_num);
1320
0
my $varname = $param->{var};
1321
0
0
0
my $showname = $varname =~ /\A\Q$nameless_name/ ? $source_var_desc // "\\\$ARG[$param_num]"
1322
: $varname;
1323
1324
# Handle implicit value constraints and destructures...
1325
0
0
if (exists $param->{bool}) {
0
0
0
0
0
0
1326
0
$constraint_count++;
1327
0
$code .= "BEGIN { die 'Use of $param->{bool} as a parameter constraint requires Perl v5.36 or later' if \$] < 5.036 } use builtin 'is_bool'; return q{$param_ord argument did not satisfy parameter constraint: $showname must be the distinguished boolean $param->{bool} value}
1328
unless do { no warnings 'numeric';
1329
defined($varname)
1330
&& !ref($varname)
1331
&& $varname == $param->{bool}
1332
&& builtin::is_bool($varname) };\n";
1333
}
1334
elsif (exists $param->{num}) {
1335
0
$constraint_count++;
1336
0
$code .= "return q{$param_ord argument did not satisfy parameter constraint: $showname must be the number $param->{num}}
1337
unless do { no warnings 'numeric';
1338
defined($varname) && $varname == $param->{num} };\n";
1339
}
1340
elsif (exists $param->{str}) {
1341
0
$constraint_count++;
1342
0
$code .= "return q{$param_ord argument did not satisfy parameter constraint: $showname must be the string $param->{str}}
1343
unless defined($varname) && $varname eq $param->{str};\n";
1344
}
1345
elsif (exists $param->{pat}) {
1346
0
$constraint_count++;
1347
0
$code .= "return q{$param_ord argument did not satisfy parameter constraint: $showname must match the pattern $param->{pat}}
1348
unless defined($varname) && $varname =~ $param->{pat};\n";
1349
}
1350
elsif (exists $param->{undef}) {
1351
0
$constraint_count++;
1352
0
$code .= "return q{$param_ord argument did not satisfy parameter constraint: $showname must be undefined}
1353
unless !defined($varname);\n";
1354
}
1355
elsif (exists $param->{array}) {
1356
0
$constraint_count++; # Must be an array ref
1357
0
$param->{array} =~ $PARAMETER_PARSER;
1358
0
$code .= "return q{$param_ord argument did not satisfy parameter constraint: $showname must be an array ref} unless do{ use Scalar::Util 'reftype'; (reftype($varname)//'') eq 'ARRAY' }\n;";
1359
my $subparams
1360
# Desc of this multi, Constraints, Params, Arg source
1361
# | | | / |
1362
0
= _extract_params($package, $keyword, $name, 0, $param->{subparams}, "\@{$varname}");
1363
0
$constraint_count += $subparams->{constraint_count};
1364
0
$destructure_count += $subparams->{destructure_count};
1365
0
$code .= $subparams->{code};
1366
}
1367
elsif (exists $param->{hash}) {
1368
# Is it an implicit slurpy hash sequence???
1369
0
my $implicit_slurpy = exists $param->{slurpy};
1370
0
my $internal_slurpy = $param->{hashslurpy};
1371
1372
# Track degree of slurpiness (which affects the ordering of variants)...
1373
0
0
$seen_slurpy++ if $implicit_slurpy;
1374
0
0
$seen_slurpy++ if length $internal_slurpy;
1375
1376
# Set up internal slurpy var...
1377
0
my $internal_slurpy_varname = substr($nameless_name,1) . $nameless_num++;
1378
1379
# Destructuring hashes expect hashrefs unless they're slurpy...
1380
0
0
if ($implicit_slurpy) {
1381
0
$code .= "return q{Can't pass odd number of arguments to named parameter sequence}"
1382
. " unless (\$#_ - $param_num) % 2;\n"
1383
. "my %$internal_slurpy_varname = \@_[$param_num..\$#_];\n";
1384
}
1385
else {
1386
0
$constraint_count++; # Must be a hash ref
1387
0
$code .= "return q{$param_ord argument did not satisfy parameter constraint: "
1388
. "$showname must be a hash ref} unless do{ use Scalar::Util 'reftype'; (reftype($varname)//q{}) eq 'HASH'};\n"
1389
. "my %$internal_slurpy_varname = %{$varname};\n";
1390
}
1391
1392
# Check that the hashref has sufficient entries...
1393
0
my $arity = 0;
1394
0
$code .= ";\n";
1395
1396
# Then check that every specified key exists in the hashref and extract it...
1397
0
my $has_optionals;
1398
0
while ($param->{hashreq} =~ m{\G (?&comma)?+ $KEYEDPARAM_PARSER $PPR::GRAMMAR}gcxmso) {
1399
0
my %cap = %+;
1400
0
0
$cap{key} //= $cap{name};
1401
0
my $entry = '$'.$internal_slurpy_varname . '{'.Data::Dump::dump($cap{key}).'}';
1402
0
my $entry_desc = $showname . '{'.Data::Dump::dump($cap{key}).'}';
1403
1404
0
0
if (!exists $cap{default}) {
1405
0
$arity++;
1406
0
0
$code .= $implicit_slurpy
1407
? "return q{Required named argument ('$cap{key}') not found in argument list} unless exists $entry;\n"
1408
: "return q{Required key (\->{'$cap{key}'}) not found in hashref argument $showname} unless exists $entry;\n";
1409
}
1410
else {
1411
0
$has_optionals = 1;
1412
}
1413
1414
0
0
my $default_val = $cap{default} // 'undef';
1415
my $subparam
1416
0
= _extract_params($package, $keyword, $name, 0, $cap{subparam}, "\@{[exists $entry ? $entry : $default_val]}", $entry_desc);
1417
0
$constraint_count += $subparam->{constraint_count};
1418
0
$destructure_count += $subparam->{destructure_count};
1419
0
$code .= $subparam->{code};
1420
0
0
$code .= qq{$entry = $cap{default} if !exists $entry;} if exists $cap{default};
1421
0
$code .= 'delete $' . $internal_slurpy_varname . '{' . Data::Dump::dump($cap{key}) . "};\n"
1422
}
1423
1424
# Insert the early arity check (once we know the correct arity...
1425
0
0
0
my $op = length $internal_slurpy || $has_optionals ? '>= ' : '== ';
1426
0
0
0
my $op_desc = length $internal_slurpy || $has_optionals ? 'at least' : 'exactly';
1427
0
$code =~ s{}
1428
0
0
{ $implicit_slurpy
1429
? qq{return q{Incorrect number of named arguments: expected $op_desc $arity but found } . keys(%{$internal_slurpy_varname}) unless keys %{$internal_slurpy_varname} $op $arity;\n}
1430
: qq{return q{Incorrect number of entries in hashref argument $param_num: expected $op_desc $arity entries but found } . keys(%{$internal_slurpy_varname}) unless keys %{$internal_slurpy_varname} $op $arity;\n}
1431
}xmse;
1432
1433
# If no internal slurpy, make sure no other args were passed...
1434
0
0
if (!length $internal_slurpy) {
0
1435
0
0
$code .= $implicit_slurpy
1436
? "return qq{Invalid named argument} . (keys(%$internal_slurpy_varname)==1 ? '' : 's') . qq{ found in argument list: } . substr(Data::Dump::dump(\\%$internal_slurpy_varname),1,-1) if keys %$internal_slurpy_varname;\n"
1437
: "return qq{Invalid entr} . (keys(%$internal_slurpy_varname)==1 ? 'y' : 'ies') . qq{ found in hashref argument $showname: } . substr(Data::Dump::dump(\\%$internal_slurpy_varname),1,-1) if keys %$internal_slurpy_varname;\n";
1438
}
1439
# If named internal slurpy, copy remaining named args into it...
1440
elsif (length($internal_slurpy) > 1) {
1441
0
$code .= "my $internal_slurpy = %$internal_slurpy_varname;\n";
1442
}
1443
}
1444
1445
1446
# Finally, validate the parameter against its constraint (if any)...
1447
0
0
if (defined $param->{constraint_code}) {
1448
0
$code .= "return q{$param_ord argument did not satisfy constraint on parameter $showname: "
1449
. "$param->{constraint_desc}} unless $param->{constraint_code};\n"
1450
}
1451
}
1452
1453
# Do we have a sig???
1454
0
my $sig_count = grep( {/[[:upper:]]/} @sig);
0
1455
0
0
my $sig = $sig_count ? '['.join(',', @sig).']' : '[]';
1456
1457
# Build a precedence string (variants are sorted on this)...
1458
0
my $precedence
1459
= sprintf("%07dA%07dC%07dD%07dE%07dF%01dG1H",
1460
$sig_count,
1461
$constraint_count, $destructure_count, $req_count,
1462
1e7-1-$opt_count, (9-$seen_slurpy));
1463
0
0
0
my $level = $before && $before =~ 1 ? "B1"
0
0
0
0
0
1464
: $constraint_count && $constraint_count > $destructure_count ? "C$constraint_count"
1465
: $destructure_count ? "D$destructure_count"
1466
: $req_count ? "E$req_count"
1467
: $opt_count ? "F$opt_count"
1468
: "G" . (9-$seen_slurpy);
1469
1470
return {
1471
0
0
min_args => $req_count,
1472
max_args => ($seen_slurpy ? 1_000_000_000_000 : $req_count + $opt_count),
1473
precedence => $precedence,
1474
level => $level,
1475
code => $code,
1476
constraint_count => $constraint_count,
1477
destructure_count => $destructure_count,
1478
sig => $sig,
1479
};
1480
}
1481
1482
# Compute the 1-based ordinal position of a zero-based index...
1483
sub _ordinal {
1484
0
0
my ($n) = 1 + shift();
1485
1486
0
return $n =~ s{ (?: 1\d(? ) | 1(?) | 2(?) | 3(?) | (?) ) \K\z }
1487
0
{ (keys %+)[0] }exmsr;
1488
}
1489
1490
# Use this to throw exceptions inside keyword processors...
1491
sub _die {
1492
0
0
my $level = shift;
1493
0
my (undef, $file, $line) = caller($level+1);
1494
0
my $msg = join("\n", @_);
1495
0
0
0
$msg =~ s{ \n }{\nat $file line $line}gxms
1496
or $msg =~ s{ \h* }{ at $file line $line}gxms
1497
or $msg =~ s{ \h* \Z} { at $file line $line}gxms;
1498
0
die "$msg\n";
1499
}
1500
1501
1; # Magic true value required at end of module
1502
__END__