Multimethod hack - example of pluggable keyword

Multimethod.pm

die "This code should not be used, ever!" unless $ENV{MULTIMETHOD_DEATHWISH};
package Multimethod;

use v5.38;
use experimental qw/ try /;
use List::Util qw/ uniq /;
use List::MoreUtils qw/ each_array /;
use Scalar::Util qw/ blessed /;
use Keyword::Declare;
use Object::Pad::MOP::Class qw/ :experimental(mop) /;
use Types::Standard;

my $methods  = {};
my $checkers = {};

sub _extract_signature( $raw_params ) {
    $raw_params =~ s/^\(//;
    $raw_params =~ s/\)$//;
    +{
        map {
            my @param = split " ", $_;
            $param[1]
                ? ( $param[1] => $param[0] )
                : ( $param[0] => undef )
        } split ",", $raw_params
    }
}

sub _inject_proxy_method( $class, $method ) {
    return if $class->can( $method );

    my $meta = Object::Pad::MOP::Class->for_class( $class );
    $meta->add_method(
        "$method",
        sub {
            Multimethod::delegate( $class, $method, @_ )
        }
    );
}

sub _build_type_checkers( @types ) {
    for my $type ( uniq sort grep { $_ } @types ) {
        next if $checkers->{ $type };
        $checkers->{ $type } = sub( $datum ) {
            state $ts_type = Types::Standard->can( $type );
            $ts_type
                ? $ts_type->()->assert_valid( $datum )
                : blessed $datum && $datum->isa( $type )
                    or die("$datum is not an instance of $type");
        };
    }
}

sub _find_signature_match( $delegates, @params ) {
    OUTER: for my $delegate ( $delegates->@* ) {
        my @types = values $delegate->{ signature }->%*;
        # return unless @types == @params;

        my $iter = each_array( @types, @params );
        while ( my ( $type, $param ) = $iter->() ) {
            next unless $type;
            try {
                $checkers->{ $type }->( $param );
            } catch( $e ) {
                next OUTER;
            }
        }

        return $delegate->{ method };
    }
}

sub delegate( $class, $method, $instance, @params ) {
    my $delegates = $methods->{ $class }->{ $method };
    my $delegate_method = _find_signature_match( $delegates, @params );
    die "No delegate method found for ${class}::$method" unless $delegate_method;
    $instance->$delegate_method( @params );
}

sub import {
    my $class = caller();

    keyword multi (
        /sub|method/ $sub,
        Ident $method,
        Attributes? $attribs,
        List? $raw_params,
    ) {
        my $signature      = _extract_signature( $raw_params );
        my $param_string   = join ',', keys $signature->%*;
        my @types          = values $signature->%*;
        my $signature_name = join '_', map { $_ // 'undef' } @types;
        my $target_method  = "_multimethod_${signature_name}_$method";

        die "Ambiguous signature in $method declaration"
            if $class->can( $target_method );

        $methods->{ $class }->{ $method } //= [];
        push $methods->{ $class }->{ $method }->@*, {
            signature => $signature, method => $target_method
        };

        _build_type_checkers( @types );
        _inject_proxy_method( $class, $method );

        "$sub $target_method $attribs ( $param_string )";
    }
}

multimethod.t

use lib '.';
use v5.38.0;
use Test2::V0;
use Object::Pad;

# This is not a comprehensive test suit - it's more a demo

# Two classes to check namespaces are set up as expected
class One {
    use Multimethod;

    method this() { "this" }

    multi method that( Int $that ) { "int $that" }
    multi method that( Str $that ) { "string $that" }
    multi method that( $that ) { "something $that" }
};

class Two {
    use Multimethod;

    multi method that( Int $that ) { "INT $that" }
    multi method that( Str $that ) { "STRING $that" }

    # Turns out this arbitrary 'isa' hack is really limited -
    # putting a typical package name in the signature really
    # confuses the parser. Or maybe I am confused.
    multi method other( One $one ) { $one->that( 456 ) }
};

my $one = One->new;
my $two = Two->new;

is( $one->this          => 'this' );
is( $one->that( 1 )     => 'int 1' );
is( $one->that( 'foo' ) => 'string foo' );
like( $one->that( {} )  => qr/something\ HASH\(/ );

is( $two->that( 1 )     => 'INT 1' );
is( $two->that( 'foo' ) => 'STRING foo' );

like( $two->other( $one ) => 'int 456' );

ok( dies { $two->that( {} ) } );
ok( dies { $two->other( 123 ) } );
ok( dies {
    eval '
        class Foo {
            use Multimethod;
            multi method foo( Int $foo ) {};
            multi method foo( Int $foo ) {};
        }
    ' || die;
} );

done_testing;

Write up here: https://fuzzix.org/how-easy-are-perls-pluggable-keywords