Multi-Dispatch
view release on metacpan or search on metacpan
lib/Multi/Dispatch.pm view on Meta::CPAN
if (*$target_name {CODE}) {
my \$info = \$Multi::Dispatch::dispatcher_info_for{*$target_name {CODE}};
if (!\$info) {
\$redefining = 1;
package Multi::Dispatch::Warning;
warn 'Subroutine $name() redefined as $keyword $name()'
if warnings::enabled('redefine');
}
elsif (\$info->{keyword} ne '$keyword') {
die qq{Can't declare a \$info->{keyword} and a $keyword of the same name ("$name") in a single package};
}
elsif (\$info->{package} ne $target_package ) {
\$redefining = 1;
package Multi::Dispatch::Warning;
warn ucfirst "\$info->{keyword} $name() [imported from \$info->{package}] redefined as $keyword $name()"
if ('$frommodule' ne \$info->{package})
&& warnings::enabled('redefine');
}
}
else {
\$redefining = 1;
}
if (\$redefining) {
no warnings 'redefine';
my \$impl = $declarator $common {
my \@variants = \@{\$Multi::Dispatch::impl{'$name'}{$target_package}//[]};
$dispatcher_code;
};
*$target_name = \$impl;
\$Multi::Dispatch::dispatcher_info_for{\$impl} = {
keyword => '$keyword',
package => $target_package,
};
}
$annotator
$implementation
}
} =~ s/\n//gr
=~ s/<BODY>/_fix_state_vars($body)/egr;
# Install that code (and adjust the line numbering)...
${$src_ref} = $clone_multi . $installer . "\n#line $endline\n" . ${$src_ref};
};
}
# Export the two new keywords...
sub import {
my $package = shift;
if (grep /\A-?debug\Z/, @_) { $^H{'Multi::Dispatch verbose'} = 1;
$^H{'Multi::Dispatch debug'} = 1; }
if (grep /\A-?verbose\Z/, @_) { $^H{'Multi::Dispatch verbose'} = 1; }
if (grep /\A-?annotate\Z/, @_) { $^H{'Multi::Dispatch annotate'} = 1; }
# Set up for redispatch...
my $redispatcher = '$' . join q{}, map { ('a'..'z', 'A'..'Z')[rand 52] } 1..20;
# Enable warnings for this module class...
warnings->import('Multi::Dispatch');
Keyword::Simple::define multi => gen_handler_for('multi', (caller)[0]);
Keyword::Simple::define multimethod => gen_handler_for('multimethod', (caller)[0]);
}
sub _annotate {
my ($package, $file) = @_;
# Only call once per file...
state $seen;
return if $seen->{$file}++;
# Iterate the package's various multis...
my %line;
for my $impl (values %Multi::Dispatch::impl) {
# Rank each variant of the multi...
for my $n (keys @{$impl->{$package} // [] }) {
# Extract the variant and convert it's index to an ordinal...
my $variant = $impl->{$package}[$n];
my $nth = _ordinal($n);
# Create (or append) the ordinal to the annotation for that line...
my $linenum = $variant->{line};
$line{$linenum} .= ', ' if $line{$linenum};
$line{$linenum} .= "$nth ($variant->{level})";
}
}
# Print out the rankings...
for my $n (sort {$a<=>$b} keys %line) {
warn "$line{$n} at $file line $n\n";
}
}
sub _fix_state_vars {
use PPR::X;
my $str = PPR::X::decomment(shift);
local %Multi::Dispatch::____STATEEND;
state $STATE_EXTRACTOR = qr{ (?&PerlEntireDocument)
(?(DEFINE)
(?<PerlVariableDeclaration>
(?{ pos })
((?&PerlStdVariableDeclaration))
(?= (?>(?&PerlOWS)) = (?{ -$^R }) )?+
(?{ $Multi::Dispatch::____STATEEND{$^R} = pos(); })
)
)
$PPR::X::GRAMMAR
}xms;
$str =~ $STATE_EXTRACTOR;
return $str if !keys %Multi::Dispatch::____STATEEND;
for my $start (reverse sort { abs($a) <=> abs($b) } keys %Multi::Dispatch::____STATEEND) {
my $assign = $start < 0;
my $end = $Multi::Dispatch::____STATEEND{$start};
$start = -$start if $assign;
my $len = $end - $start;
my $state_var = substr( $str, $start, $len);
lib/Multi/Dispatch.pm view on Meta::CPAN
for my $partition (@partitions) {
$partition = [sort { $b->{prec} cmp $a->{prec}
||
( $a->{pack} eq $b->{pack} ? 0
: $a->{pack}->isa($b->{pack}) ? -1
: $b->{pack}->isa($a->{pack}) ? +1
: 0
)
||
$a->{inception} <=> $b->{inception}
} @{$partition}
];
}
# 5. Concatenate all partitions and return...
return map { @{$_} } @partitions;
}
sub _narrowness {
my ($x, $y) = map { $_->{sig} } @_;
my $order = 0;
for my $n (0..($#$x < $#$y ? $#$y : $#$x)) {
my ($xn, $yn) = ($x->[$n], $y->[$n]);
if (!defined($xn) && !defined($yn)) { next; }
elsif ( defined($xn) && !defined($yn)) { return 0 if $order > 0; $order = -1; }
elsif (!defined($xn) && defined($yn)) { return 0 if $order < 0; $order = +1; }
elsif ( ref($xn) && ref($yn) ) {
if ($xn->is_subtype_of($yn) ) { return 0 if $order > 0; $order = -1; }
elsif ($yn->is_subtype_of($xn) ) { return 0 if $order < 0; $order = +1; }
}
elsif ( !ref($xn) && !ref($yn) ) {
if ($xn eq $yn) { next }
elsif ($yn eq 'OBJ' || eval{$xn->isa($yn)}) { return 0 if $order > 0; $order = -1; }
elsif ($xn eq 'OBJ' || eval{$yn->isa($xn)} ) { return 0 if $order < 0; $order = +1; }
else { return 0; }
}
}
return $order;
}
sub _build_dispatcher_sub {
my %arg = @_;
# Code to redispatch to deepest non-multi ancestor method, if no suitable multimethod...
my $updispatch = $arg{keyword} eq 'multimethod'
? 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; ...
: q{};
# Generate the dispatch code...
my $code = q{
<ADDSELF>
<VERBOSE>
my @failures;
</VERBOSE>
<DEBUG>
warn sprintf "\nDispatching call to <NAME>("
. join(', ', map({Data::Dump::dump($_)} @_))
. ") at %s line %s\\n", (caller)[1,2];
</DEBUG>
while (my $variant = shift @variants) {
# Skip variants that can't possibly work...
<VERBOSE>
# Extract the debugging information...
my ($level, $name, $package, $file, $line)
= @{$variant}{qw<level name pack file line>};
$name = $package.'::'.$name;
</VERBOSE>
if (@_ < $variant->{min}) {
<VERBOSE>
# Record skipped dispatch candidates...
my $at_least = $variant->{min} == $variant->{max} ? 'exactly' : 'at least';
push @failures, qq{ $level: $name\n},
qq{ defined at $file line $line\n},
qq{ --> SKIPPED: need $at_least $variant->{min} args but found only }. scalar(@_) . "\n";
</VERBOSE>
next;
}
if (@_ > $variant->{max}) {
<VERBOSE>
# Record skipped dispatch candidates...
my $at_most = $variant->{min} == $variant->{max} ? 'exactly' : 'at most';
push @failures, qq{ $level: $name\n},
qq{ defined at $file line $line\n},
qq{ --> SKIPPED: need $at_most $variant->{max} args but found }. scalar(@_) . "\n";
</VERBOSE>
next;
}
# Test the viability of this variant...
my $handler = <VARIANT_CODE>;
# Execute the variant if appropriate...
if (ref $handler) {
<DEBUG>
# Report the successful dispatch (and the preceding failures)...
warn $_ for @failures,
qq{ $level: $name\n},
qq{ defined at $file line $line\n},
qq{ ==> SUCCEEDED\n};
</DEBUG>
# Add the redispatch mechanism to the argument list...
push @_, __SUB__();
# And then execute the variant...
goto &{$handler};
}
<VERBOSE>
# Otherwise, record another unviable variant...
else {
push @failures, qq{ $level: $name\n},
qq{ defined at $file line $line\n},
qq{ --> $handler\n};
}
</VERBOSE>
}
<UPDISPATCH>
# If no viable variant, throw an exception (with the extra debugging info)...
<VERBOSE>
if (1 == grep /-->/, @failures) {
die sprintf( "Can't call <NAME>(%s)\\n"
. "at %s line %s\\n",
join(', ', map({Data::Dump::dump($_)} @_)),
(caller)[1,2]), map { s/SKIPPED: //r } grep /-->/, @failures;
}
</VERBOSE>
die sprintf( "No suitable variant for call to <KEYWORD> <NAME>()\\n"
. "with arguments: (%s)\\n"
. "at %s line %s\\n",
join(', ', map({Data::Dump::dump($_)} @_)),
(caller)[1,2]) <VERBOSE>, @failures</VERBOSE>;
} =~ s{ <VERBOSE> (.*?) </VERBOSE> }{ $arg{verbose} ? $1 : q{} }egxmsr
=~ s{ <DEBUG> (.*?) </DEBUG> }{ $arg{debug} ? $1 : q{} }egxmsr
=~ s{ <VARIANT_CODE> }{ $arg{invocant} ? q{$_[0]->${\$variant->{code}}(@_[1..$#_])}
: q{&{$variant->{code}}} }egxmsr
=~ s{ <ADDSELF> }{ $arg{invocant} ? "unshift \@_, $arg{invocant};" : q{} }egxmsr
=~ s{ <UPDISPATCH> }{ $updispatch }egxmsr
=~ s{ < ([A-Z_]++) > }{ $arg{lc $1} // die 'Internal error' }egxmsr
=~ s{ \s \# \N* }{}gxmsr;
if ($arg{as_sub}) {
$code = "goto &{sub{$code}}";
}
return $code;
}
# Break a single parameter list into individual parameters, classifying their components...
sub _split_params {
my ($params) = @_;
my @split_params;
while ($params =~ m{\G (?&comma)?+ (?<source> $PARAMETER_PARSER ) }gxmso) {
push @split_params, {%+};
}
return \@split_params;
}
# Convert a textual parameter list to an actual list of params...
sub _extract_params {
my ($package, $keyword, $name, $constraint_count, $params, $source_var, $source_var_desc, $before) = @_;
my $seen_option;
my $seen_slurpy = 0;
my ($req_count, $opt_count, $destructure_count) = (0,0,0);
# "Nameless" parameters get an improbable name...
state $nameless_name = '$______' . join('', map { ('a'..'Z','A'..'Z')[rand 52] } 1..20) . '_____';
state $nameless_num = 1;
# Split parameter list (if not already done)...
if (!ref $params) {
$params = _split_params($params);
}
# Extract and process each parameter...
my @params;
my @sig;
for my $param (@{$params}) {
# Extend signature (trivially, so far)...
push @sig, 'undef';
# Handle defaults...
$param->{default} = 'undef'
if exists $param->{default} && $param->{default} =~ /\A\s*\Z/;
my $default = $param->{default};
if (defined $default) {
if (exists $param->{slurpy}) {
_die(1, "A slurpy parameter ($param->{var}) may not have a default value: = $default");
( run in 1.643 second using v1.01-cache-2.11-cpan-cdf2f3d4e48 )