File Coverage

blib/lib/Switch/Right.pm

Criterion	Covered	Total	%
statement	395	653	60.4
branch	107	258	41.4
condition	37	105	35.2
subroutine	56	66	84.8
pod	0	2	0.0
total	595	1084	54.8

package Switch::Right;

use 5.036;
our $VERSION = '0.000006';

use experimental qw< builtin refaliasing try >;
use builtin      qw< true false is_bool blessed created_as_number reftype >;
use Scalar::Util qw < looks_like_number >;
use overload;

use Multi::Dispatch;
use PPR::X;
use Carp qw< croak carp >;

# Useful patterns...
my $OWS; BEGIN { $OWS = q{(?>(?&PerlOWS))}; }
my $CONTAINER_VARIABLE;
BEGIN { $CONTAINER_VARIABLE
    = qr{ \A (?>             (?&PerlVariableArray) | (?&PerlVariableHash)
             |   my $OWS (?> (?&PerlVariableArray) | (?&PerlVariableHash) ) $OWS = .*
             )
          \z $PPR::GRAMMAR
      }xms;
}
my $ARRAY_SLICE;
BEGIN { $ARRAY_SLICE
    = qr{ \A (?>         (?&PerlArrayAccess)
             |   my $OWS (?&PerlArrayAccess) $OWS = .*
             )
          \z $PPR::GRAMMAR
      }xms;
}
my $HASH_SLICE;
BEGIN { $HASH_SLICE
    = qr{ \A (?>         (?&PerlHashAccess)
             |   my $OWS (?&PerlHashAccess) $OWS = .*
             )
          \z $PPR::GRAMMAR
      }xms;
}
my $FLIP_FLOP;
BEGIN { $FLIP_FLOP
    = qr{ \A (?&FlipFlop) \z
          (?(DEFINE)
              (?
                    \( (?>(?&PerlOWS)) (?&FlipFlop) (?>(?&PerlOWS)) \)
              |
                    (?>(?&PerlBinaryExpression)) (?>(?&PerlOWS))
                     \.\.\.?                       (?>(?&PerlOWS))
                     (?>(?&PerlBinaryExpression))
              )
              (?
                    (?>  [=!][~=] |    <= >?+ |    >=
                    |    cmp |    [lg][te] |    eq |    ne
                    |    [+]             (?! [+=] )
                    |     -              (?! [-=] )
                    |    [.%x]           (?! [=]  )
                    |    [&|^][.]        (?! [=]  )
                    |    [<>*&|/]{1,2}+  (?! [=]  )
                    |    \^              (?! [=]  )
                    |    ~~ | isa
                    )
              )
          )
          $PPR::GRAMMAR
      }xms;
}

# Install the new keywords, functions, and smartmatching...
sub import {
    # Export replacement keywords...
    use Keyword::Simple;
    Keyword::Simple::define given    => \&_given_impl;
    Keyword::Simple::define when     => \&_when_impl;
    Keyword::Simple::define default  => \&_default_impl;

    # Outside a given a 'break' is an error; outside a when a 'continue' is too...
    {
        no strict 'refs';
        no warnings qw< redefine >;
        *{caller.'::break'}     = \&break;
        *{caller.'::continue'}  = \&continue;
    }

    # Export smartmatch()...
    multi smartmatch :export;
}

# Error messages shared by *_given_impl()...
my $WHENTRUEMSG  = q{BEGIN{warn q{"when (true) {...}" better written as "default {...}"}}};
my $WHENFALSEMSG = q{BEGIN{warn q{Useless use of "when (false)"}}};

sub _pure_given_impl { my ($source) = @_;

    # Recognize a valid "pure" given block (i.e. containing only when and default blocks)...
    state @pure_statements;
    @pure_statements = ();
    state $VALIDATE_PURE_GIVEN = qr{
        \A  given (?  (?   $OWS    )  \(
                             (?     (?: $OWS (?> any | all | none )  $OWS  => )?+  )
                             (?  $OWS    )  (?>(? (?&PerlExpression)))
                             (? $OWS    )  \)
                             (? $OWS \{ $OWS )  (?>(?  (?&PureBlock)  ))  \}
            )
            (?>(?  .*  ))

            (?(DEFINE)
                (?    # Distinguish "when", "default", and "given" from other statements...
                    (?:
                        when (? $OWS \( $OWS )
                        (?>
                            (? (?  true  )
                            |            (? false )
                            ) \b
                        |
                            (? (?: (?> any | all | none ) $OWS => $OWS )?+ )
                            (? (?>(?&PerlExpression)))
                        )
                        (? $OWS \) $OWS )
                        (?>(? (?&PerlBlock) ))
                        (? $OWS )
                            (?{ push @pure_statements, { TYPE => 'when', %+ }; })
                    |
                        default (?  $OWS )
                                (?>(? (?&PerlBlock) ))
                                (? $OWS )
                            (?{ push @pure_statements, { TYPE => 'default', %+ }; })
                    |
                        (?
                            given \b $OWS  \(
                                (?: $OWS (?> any | all | none )  $OWS  => )?+
                                    $OWS (?>(? (?>(?&PerlExpression))))
                                    $OWS \)
                                    $OWS (?>(?  (?&NestedPureBlock)  )) $OWS
                        )
                            (?{ push @pure_statements, { TYPE => 'given', %+ }; })
                    |
                        (?! $OWS (?> when | default ) \b )
                        (?>(? (?&PerlStatement)  $OWS ))
                            (?{ push @pure_statements, { TYPE => 'other', %+ }; })
                    )*+

                    # Possible trailing whitespace at the end of the block...
                    ( (?>(? (?&PerlNWS) ))
                        (?{ push @pure_statements, { TYPE => 'other', %+ }; })
                    )?+
                )
                (?    # Non-capturing version of the above
                    \{  $OWS
                    (?:
                        when $OWS \( (?: $OWS (?> any | all | none ) $OWS => )?+
                                         $OWS (?>(?&PerlExpression))
                             $OWS \) $OWS (?>(?&PerlBlock))  $OWS
                    |
                        default $OWS (?>(?&PerlBlock))  $OWS
                    |
                        given \b $OWS \( (?: $OWS (?> any | all | none )  $OWS  => )?+
                                              $OWS (?>(?&PerlExpression))
                                 $OWS \)
                                 $OWS (?>(?&NestedPureBlock)) $OWS
                    |
                        (?! when \b | default | given \b ) (?>(?&PerlStatement)) $OWS
                    )*+
                    \}
                )
                (?
                    # Pure given can't have a continue or break or goto in it...
                    (?: continue | break | goto ) \b (*COMMIT)(*FAIL)
                |
                    (?&PerlStdBuiltinFunction)
                )
                (?
                    # "Pure" given can't have a postfix "when" modifier in it...
                    (?> if | for(?:each)?+ | while | unless | until | when (*COMMIT)(*FAIL) )
                    \b
                    (?>(?&PerlOWS))
                    (?&PerlExpression)
                ) # End of rule (?)
            )
            $PPR::X::GRAMMAR
    }xms;

    # Generate an optimized given/when implementation if the given is "pure"...
    no warnings 'once';
    if ($source =~ $VALIDATE_PURE_GIVEN) {
        my %matched = %+;
        my $nesting_depth     = 0;
        my $after_a_statement = 0;
        my $GIVEN_EXPR = _apply_term_magic($matched{EXPR});

        return
              "if (1) $matched{ws_post_kw} { local *_ = $matched{ws_pre_expr} \\scalar($GIVEN_EXPR); $matched{ws_pre_close} if(0) $matched{ws_pre_block} }"
            . join("", map {
                my $PREFIX = $after_a_statement ? 'if(0){}' : q{};
                if ($_->{TYPE} eq 'when') {
                    my $BLOCK = $_->{WHENBLOCK};
                       if ($_->{WHENTRUE})  { substr($BLOCK,1,0) = $WHENTRUEMSG;  }
                    elsif ($_->{WHENFALSE}) { substr($BLOCK,1,0) = $WHENFALSEMSG; }
                    my $JUNC = $_->{WHENJUNC} // q{};
                    $after_a_statement = 0;
                      "$PREFIX elsif $_->{WHENOPEN} smartmatch($matched{JUNC} \$_, $JUNC scalar("
                    . _apply_term_magic($_->{WHENEXPR}) . ")) $_->{WHENCLOSE} $BLOCK $_->{WHENPOST}"
                }
                elsif ($_->{TYPE} eq 'default') {
                    $after_a_statement = 0;
                    "$PREFIX elsif (1) $_->{DEFPRE} $_->{DEFBLOCK} $_->{DEFPOST}"
                }
                elsif ($_->{TYPE} eq 'given') {
                    my $nested = _pure_given_impl($_->{NESTEDGIVEN});
                    if ($after_a_statement) {
                        $nested;
                    }
                    else {
                        $after_a_statement = 1;
                        $nesting_depth++;
                        "else { $nested ";
                    }
                }
                else { # Must be a regular statement...
                    if ($after_a_statement) {
                        $_->{STATEMENT};
                    }
                    else {
                        $after_a_statement = 1;
                        $nesting_depth++;
                        "else { $_->{STATEMENT}";
                    }
                }
              } @{[@pure_statements]} )
            . (!$after_a_statement ? "else{}" : q{})
            . ('}' x $nesting_depth)
            . "}$matched{TRAILING_CODE}";
    }

    # Otherwise, fail...
    return;
}

# Implement "given" keyword...
sub _given_impl { my ($source_ref) = @_;  # Has to be this way because of code blocks in regex

    # First try the "pure" approach (only works on a limited selection of "given" blocks)...
    my $REPLACEMENT_CODE = _pure_given_impl('given ' . ${$source_ref});

    # Otherwise recognize a valid general-purpose given block (with a single scalar argument)...
    if (!defined $REPLACEMENT_CODE) {
        state $VALIDATE_GIVEN = qr{
            \A  (?
                    $OWS  \(
                    (? (?: $OWS (?> any | all | none )  $OWS  => )?+ )
                                 $OWS (?>(? (?&PerlExpression)))
                    $OWS \)
                    (?>
                        $OWS  (?>(?  (?&PerlBlock)  ))
                    |
                        (?)
                    )
                )
                (?>(?  .*  ))
                $PPR::GRAMMAR
        }xms;
        ${$source_ref} =~ $VALIDATE_GIVEN;

        # Extract components...
        my %result = %+;

        # It's a valid "given"...
        if (exists $result{BLOCK}) {
            my ($GIVEN, $JUNC, $EXPR, $BLOCK, $TRAILING_CODE)
                = @result{qw< GIVEN JUNC EXPR BLOCK TRAILING_CODE >};
            $JUNC //= q{};

            # Augment the block with control flow and other necessary components...
            $BLOCK = _augment_block(given => "$BLOCK", $JUNC);

            # Topicalize the "given" argument...
            $EXPR = _apply_term_magic($EXPR);
            substr($BLOCK, 1, 0) = qq{local *_ = \\($EXPR);};

            # Implement "given" as a (trivial) "if" block...
            $REPLACEMENT_CODE = qq{ if (1) $BLOCK };

            # At what line should the "given" end???
            my $end_line = (caller)[2] + $GIVEN =~ tr/\n//;

            # Append the trailing code (at the right line number)...
            $REPLACEMENT_CODE .= "\n#line $end_line\n$TRAILING_CODE";
        }

        # Otherwise, report the error in context...
        elsif (exists $result{EXPR}) {
            $REPLACEMENT_CODE = q{ BEGIN { warn  q{Invalid code somewhere in "given" block starting} } }
                            . q{ BEGIN { warn qq{(Note: the error reported below may be misleading)\\n}}}
                            . qq{ if ${$source_ref} };
        }
    }

    # Install standard code in place of keyword...
    ${$source_ref} = $REPLACEMENT_CODE;
}



# Implementation of "when" keyword...
sub _when_impl ($source_ref) {
    my ($REPLACEMENT_CODE, $TRAILING_CODE);

    # What various kinds of "when" look like...
    state $WHEN_CLASSIFIER = qr{
            \A  (? $OWS
                         (   \(
                             (?:
                                $OWS (? (?  true  )
                                     |        (? false )
                                     ) \b
                             |
                                (? (?: $OWS (?> any | all | none ) $OWS => )?+ )
                                             $OWS (? (?&PerlExpression))
                             )
                             $OWS \)
                             $OWS (?>(? (?&PerlBlock) )
                                  | (?)
                                  )
                         |
                             (?>(? (?&PerlCommaList)))
                             (?>(?&PerlOWSOrEND)) (?> ; | (?= \} | \z ))
                         |
                             (? \N{0,20} )
                         )
                )
                (? .* )
            $PPR::GRAMMAR
    }xms;

    # Classify the type of "when" we're processing...
    ${$source_ref} =~ $WHEN_CLASSIFIER;
    my %matched = %+;

    # Handle a valid when block (with a list of scalar arguments)...
    if (defined $matched{BLOCK} && defined $matched{EXPR}) {
        my ($WHEN, $JUNC, $EXPR, $WHENTRUE, $WHENFALSE, $BLOCK, $TRAILING_CODE)
            = @matched{qw< WHEN JUNC EXPR WHENTRUE WHENFALSE BLOCK TRAILING_CODE>};
        $JUNC //= q{};

        # Adjust when's expression appropriately...
        $EXPR = _apply_term_magic($EXPR);

        # Augment the block with control flow and other necessary components...
        $BLOCK = _augment_block(when => "$BLOCK");
           if ($WHENTRUE)  { substr($BLOCK, 1, 0) = $WHENTRUEMSG;  }
        elsif ($WHENFALSE) { substr($BLOCK, 1, 0) = $WHENFALSEMSG; }

        # Is the current "given" junctive???
        my $given_junc = $^H{'Switch::Right/GivenJunctive'} // q{};

        # Implement the "when" as an "if"...
        $REPLACEMENT_CODE = qq{if(1)\{local \$Switch::Right::when_value = }
                          . qq{smartmatch($given_junc \$_, $JUNC scalar($EXPR));}
                          . qq{if(1){if (\$Switch::Right::when_value) $BLOCK }\}};

        # At what line should the "when" end???
        my $end_line = (caller)[2] + $WHEN =~ tr/\n//;

        # Append the trailing code (at the right line number)...
        $REPLACEMENT_CODE .= "\n#line $end_line\n$TRAILING_CODE";
    }

    # Otherwise, reject the "when" with extreme prejudice...
    elsif (defined $matched{MODIFIER}) {
        $REPLACEMENT_CODE = qq{ BEGIN { die q{Can't specify postfix "when" modifier outside a "given"} } };
    }
    elsif (exists $matched{INVALID_BLOCK}) {
        $REPLACEMENT_CODE = qq{ BEGIN { warn  q{Invalid code block in "when"} } }
                          . qq{ BEGIN { warn qq{(Note: the error reported below may be misleading)\\n} } }
                          . qq{ if ${$source_ref} };
    }
    else {
        $REPLACEMENT_CODE = qq{ BEGIN { die q{Incomprehensible "when" (near: $matched{INCOMPREHENSIBLE})} } };
    }

    # Install code implementing keyword behaviour...
    ${$source_ref} = $REPLACEMENT_CODE;
}

sub _default_impl ($source_ref) {
    state $DEFAULT_CLASSIFIER = qr{
            (? $OWS (?>(? (?&PerlBlock) )) )
            (? .* )
            $PPR::GRAMMAR
    }xms;

    # Verify that we match the syntax for a "default" block...
    ${$source_ref} =~ $DEFAULT_CLASSIFIER;
    my %matched = %+;

    # Implement the "default" block...
    if (defined $matched{BLOCK}) {
        # Install the necessary extras...
        my $BLOCK = _augment_block(default => $matched{BLOCK});

        # Build the implementation of the "default"...
        my $REPLACEMENT_CODE = qq{ if (1) $BLOCK };

        # At what line should the "default" end???
        my $end_line = (caller)[2] + $matched{DEFAULT} =~ tr/\n//;

        # Append the trailing code (at the right line number)...
        ${$source_ref} = "$REPLACEMENT_CODE\n#line $end_line\n$matched{TRAILING_CODE}";
    }

    # Report the error...
    else {
        ${$source_ref}
            = qq{ BEGIN { die q{Incomprehensible "default" (near: $matched{INCOMPREHENSIBLE})} } };
    }
}

# Implement the "continue" command...
sub continue () {
    # Which "when" block are we in???
    my $AFTERWHEN = (caller 0)[10]{'Switch::Right/Afterwhen'};

    # Jump out of it, if possible...
    no warnings;
    eval { goto $AFTERWHEN };

    # If not possible, that's fatal...
    croak q{Can't "continue" outside a "when" or "default"};
}

# Implement the "break" command...
sub break () {
    # Which "given" block are we in???
    my $AFTERGIVEN = (caller 0)[10]{'Switch::Right/Aftergiven'};

    # Jump out of it, if possible...
    no warnings;
    eval { goto $AFTERGIVEN };

    # If we weren't in a "given", can we jump out of a surrounding loop???
    eval { next };

    # Otherwise, the "break" was illegal and must be punished...
    croak q{Can't "break" outside a "given"};
}


# Insert unique identifying information into a "given"/"when"/"default" source code block...
sub _augment_block ($TYPE, $BLOCK, $JUNC = q{}) {
        # Unique identifiers for each type of block...
        state %ID;

        # Who and what is this block???
        my $KIND = $TYPE eq 'default' ? "when" : $TYPE;
        my $NAME = "After$KIND";
        my $ID   = $NAME . ++$ID{$KIND};

        # Give each block a unique name (uses refaliasing to create a lexical constant)...
        substr($BLOCK, 1,0)
            = qq{ BEGIN { \$^H{'Switch::Right/$NAME'} = '$ID'; } };

        # A when block auto-breaks at the end of its block...
        if ($KIND eq 'when') {
            my $AFTERGIVEN = $^H{'Switch::Right/Aftergiven'};
            substr($BLOCK,-1,0)
                = ';'
                . (defined($AFTERGIVEN) ? qq{eval { no warnings; goto $AFTERGIVEN } || } : q{})
                . qq{eval { no warnings; next } || die q{Can't "$TYPE" outside a topicalizer} };
        }

        elsif ($KIND eq 'given') {
            # Remember whether (and how) given was junctive...
            substr($BLOCK, 1,0) = qq{ BEGIN { \$^H{'Switch::Right/GivenJunctive'} = '$JUNC'; } };

            # Given blocks must to pre-convert postfix "when" modifiers (which can't be keyworded)...
            $BLOCK = _convert_postfix_whens($BLOCK);
        }

        # Return identified block...
        return "$BLOCK $ID:;";
}

# Identify and pre-convert "EXPR when EXPR" syntax...
sub _convert_postfix_whens ($BLOCK) {
    # Track locations of "when" modifiers in the block's source...
    my @target_pos;

    # Extract those locations, whenever a statement has a "when" modifier...
    $BLOCK =~ m{
        \{ (?&PerlStatementSequence) \}

        (?(DEFINE)
            (?
                (?>
                    (?>(?&PerlPodSequence))
                    (?: (?>(?&PerlLabel)) (?&PerlOWSOrEND) )?+
                    (?>(?&PerlPodSequence))

                    (?> (?&PerlKeyword)
                    |   (?&PerlSubroutineDeclaration)
                    |   (?&PerlMethodDeclaration)
                    |   (?&PerlUseStatement)
                    |   (?&PerlPackageDeclaration)
                    |   (?&PerlClassDeclaration)
                    |   (?&PerlFieldDeclaration)
                    |   (?&PerlControlBlock)
                    |   (?&PerlFormat)
                    |
                        # POSTFIX when HAS TO BE REWRITTEN BEFORE OTHER POSTFIX MODIFIERS ARE MATCHED...
                        (?
                            (? (?>(?&PerlExpression))    (?>(?&PerlOWS))      )
                                     (?= when \b )
                            (?  (?&PerlStatementModifier) (?>(?&PerlOWSOrEND)) )
                            (?  (?> ; | (?= \} | \z ))                         )
                        )
                        (?{ my $len = length($+{MATCH});
                            unshift @target_pos, {
                                expr        => $+{EXPR},
                                mod         => substr($+{MOD},4),
                                end         => $+{END},
                                from        => pos() - $len,
                                len         => $len,
                            }
                        })
                    |
                        (?>(?&PerlExpression))          (?>(?&PerlOWS))
                        (?&PerlStatementModifier)?+     (?>(?&PerlOWSOrEND))
                        (?> ; | (?= \} | \z ))
                    |   (?&PerlBlock)
                    |   ;
                    )
                | # A yada-yada...
                    \.\.\. (?>(?&PerlOWSOrEND))
                    (?> ; | (?= \} | \z ))

                | # Just a label...
                    (?>(?&PerlLabel)) (?>(?&PerlOWSOrEND))
                    (?> ; | (?= \} | \z ))

                | # Just an empty statement...
                    (?>(?&PerlOWS)) ;
                )
            )
        )
        $PPR::X::GRAMMAR
    }xms;

    # Replace each postfix "when"...
    for my $pos (@target_pos) {
        # Unique ID for the "when" (needed by continue())...
        state $ID; $ID++;
        state $JUNCTIVE_EXPR = qr{
            $OWS  (?>(? (?: any | all | none ) $OWS => $OWS | ))  (? .* )
            $PPR::GRAMMAR
        }xms;

        # Unpack and enchant the "when" expression...
        my ($JUNCTIVE, $MOD_EXPR) = (q{}, $pos->{mod});
        if ($MOD_EXPR =~ $JUNCTIVE_EXPR) {
            ($JUNCTIVE, $MOD_EXPR) = ( $+{JUNC}, _apply_term_magic($+{EXPR}) );
        }

        # Convert postfix "when" to a postfix "if" (preserving Afterwhen info for continue())...
        substr($BLOCK, $pos->{from}, $pos->{len})
            = "BEGIN { \$^H{'Switch::Right/Afterwhenprev'} = \$^H{'Switch::Right/Afterwhen'};"
            . "        \$^H{'Switch::Right/Afterwhen'} = 'Afterpostfixwhen$ID'; }"
            . "$pos->{expr}, break if smartmatch(\$_, $JUNCTIVE scalar($MOD_EXPR))"
            . ";Afterpostfixwhen$ID:"
            . "BEGIN { \$^H{'Switch::Right/Afterwhen'} = \$^H{'Switch::Right/Afterwhenprev'}; }"
            . $pos->{end};
    }

    return $BLOCK;
}

# Change the target expression of a "when" to implement all the magic behaviours...
sub _apply_term_magic ($EXPR) {

    # Apply compile-time expression folding...
    $EXPR = _simplify_expr($EXPR);

    # Adjust flip..flips to canonical booleans...
    if ($EXPR =~ /\.\./ && $EXPR =~ $FLIP_FLOP) {
        return "!!($EXPR)";
    }

    # An @array or %hash gets enreferenced and then smartmatched.
    # An @array[@slice] or %kv[@slice] gets appropriately wrapped and then smartmatched.
    # Anything else is evaluated as-is...
    return ($EXPR =~ /[\@%]/ && $EXPR =~ $CONTAINER_VARIABLE) ? "\\$EXPR"
         : ($EXPR =~ /[\@]/  && $EXPR =~ $ARRAY_SLICE)        ?  "[$EXPR]"
         : ($EXPR =~ /[\%]/  && $EXPR =~ $HASH_SLICE)         ?  "{$EXPR}"
         :                                                         $EXPR;
}


# Reduce a compile-time expression to what the compiler actually sees...
# (Essential because that's what when() actually sees and how it decides
#  whether or not smartmatch is magically distributive over a boolean expression)...
sub _simplify_expr ($code) {
    no warnings;
    use B::Deparse;
    use builtin qw;
    state $deparse = B::Deparse->new;
    return $deparse->coderef2text(eval qq{no strict; sub{ANSWER( scalar($code) );DONE()}})
                =~ s{.* ANSWER \( \s* scalar \s* (.*) \) \s* ; \s* DONE() .* \z}{$1}gxmsr;
}


# Implement the new simpler, but shinier smartmatch operator...
# (Every one of the following four variants could each have been a set of multiple variants,
#  but this way is currently still significantly faster)...

multi smartmatch ($left, $right) {
    # The standard error message for args that are objects (and which shouldn't be)...
    state $OBJ_ARG = "Smartmatching an object breaks encapsulation";

    # Track "use integer" status in original caller (passing it down to nested smartmatches)...
    local $Switch::Right::_use_integer = $Switch::Right::_use_integer // (caller 0)[8] & 0x1;

    # RHS undef only matches LHS undef...
    return !defined $left if !defined $right;

    # RHS distinguished boolean always returns RHS value...
    return $right if is_bool($right);

    # RHS objects use their SMARTMATCH method (if they have one)...
    my $right_type  = reftype($right) // 'VAL';
    if ($right_type ne 'REGEXP' && blessed $right) {
        try          { return $right->SMARTMATCH($left) }
        catch ($ERR) { croak "$OBJ_ARG ($ERR)"          }
    }

    # Otherwise, branch to the appropriate comparator (if any)...
    my $left_type   = reftype($left)  // 'VAL';
    my $left_is_obj = $left_type ne 'REGEXP' && blessed($left);
    eval { goto ($left_is_obj ? 'OBJECT' : $left_type) . $right_type };

    # Otherwise, a RHS subref (with any non-subref LHS) acts like a boolean-returning test...
    return $right->($left) if $right_type eq 'CODE';

    # At thi spoint, no other combination of arguments will ever match...
    return false;

    # Objects can be used as LHS when matching an RHS value, but must be preprocessed...
    OBJECTVAL:
        if (created_as_number($right) ) {
            croak $OBJ_ARG if !overload::Method($left, '0+');
            $left = 0+$left;
        }
        else {
            croak $OBJ_ARG if !overload::Method($left, q{""});
            $left = "$left";
        }

    # Compare two scalar values (or a suitably overloaded LHS object and an RHS value)...
    VALVAL:
        # 1. undef doesn't match a number or a string...
        return false if !defined $left;

        # 2. Match primordial RHS numbers using == (respecting any ambient "use integer")...
        if (created_as_number($right) ) {
            if    (!looks_like_number($left))    {              return false;           }
            elsif ($Switch::Right::_use_integer) { use integer; return $left == $right; }
            else                                 {              return $left == $right; }
        }

        # 3. Otherwise just use string equality...
        return $left eq $right;

    # RHS regexes match any defined non-ref value via =~ pattern-matching...
    VALREGEXP:
        return defined($left) && $left =~ $right;

    # Compare two refs of the same type...
    CODECODE:
        return $left == $right;

    REGEXPREGEXP:
        return $left == $right || $left eq $right;

    ARRAYARRAY:
        return true  if $left == $right;        # ...they're the same array
        return false if @{$left} != @{$right};  # ...different lengths so their contents can't match

        # Handle non-identical self-referential structures...
        local %Sm4r7m4tCh::seen = %Sm4r7m4tCh::seen;
        return false if $Sm4r7m4tCh::seen{"L$left"}++ || $Sm4r7m4tCh::seen{"R$right"}++;

        # Otherwise, corresponding pairs of array elements must all smartmatch...
        for my $n (keys @{$right}) {
            return false if !smartmatch($left->[$n], $right->[$n]);
        }
        return true;

    HASHHASH:
        return true if $left == $right;                    # ...they're the same hash
        return false if keys %{$left} != keys %{$right};   # ...different numbers of keys, can't match

        # Handle non-identical self-referential structures...
        local %Sm4r7m4tCh::seen = %Sm4r7m4tCh::seen;
        return false if $Sm4r7m4tCh::seen{"L$left"}++ || $Sm4r7m4tCh::seen{"R$right"}++;

        # Otherwise, are they identical is structure???
        for my $key (keys %{$left}) {
            return false if !exists $right->{$key}                       # ...must have same keys
                         || !smartmatch($left->{$key}, $right->{$key});  # ...every value must match
        }
        return true;

    # Every other REF/REF comparison, just checks for the same address..
    FORMATFORMAT:;
    IOIO:;
    SCALARSCALAR:;
    VSTRINGVSTRING:;
    REFREF:;
    GLOBGLOB:;
    LVALUELVALUE:;
        return $left == $right;
}

# Junctive smartmatching of the RHS list...
multi smartmatch ($left, $junction =~ /^(?:any|all|none)$/, \@right) {

    # Track "use integer" status in original caller (passing it down to nested smartmatches)...
    local $Switch::Right::_use_integer = $Switch::Right::_use_integer // (caller 0)[8] & 0x1;

    # Select junctive behaviour...
    goto $junction;

    # Disjunction...
    any: for my $rval (@right) {
            return true if smartmatch($left, $rval);
         }
         return false;

    # Conjunction...
    all: for my $rval (@right) {
            return false if !smartmatch($left, $rval);
         }
         return true;

    # Injunction...
    none: for my $rval (@right) {
            return false if smartmatch($left, $rval);
          }
          return true;
}

# Junctive smartmatching of the LHS list...
multi smartmatch ($junction =~ /^(?:any|all|none)$/, \@left, $right) {
    # Track "use integer" status in original caller (passing it down to nested smartmatches)...
    local $Switch::Right::_use_integer = $Switch::Right::_use_integer // (caller 0)[8] & 0x1;

    # Dispatch on junctive type...
    goto $junction;

    # Disjunction...
    any: for my $lval (@left) {
            return true if smartmatch($lval, $right);
         }
         return false;

    # Conjunction...
    all: for my $lval (@left) {
            return false if !smartmatch($lval, $right);
         }
         return true;

    # Injunction:
    none: for my $lval (@left) {
            return false if smartmatch($lval, $right);
          }
          return true;
}


# Junctive smartmatching of both LHS and RHS lists...
multi smartmatch (
            $ljunction =~ m/^(?:any|all|none)$/, \@left,
            $rjunction =~ m/^(?:any|all|none)$/, \@right
) {
    # Track "use integer" status in original caller (passing it down to nested smartmatches)...
    local $Switch::Right::_use_integer = $Switch::Right::_use_integer // (caller 0)[8] & 0x1;

    # Dispatch according to the combination of junctive types...
    goto "$ljunction$rjunction";

    # The nine combinations...
    anyany: for my $lval (@left)  {
            for my $rval (@right) {
                return true if smartmatch($lval, $rval);   # ...because any match is sufficient
            }}
            return false;  # ...because no LHS value matched any RHS value

    anyall: for my $lval (@left)  {
                for my $rval (@right) {
                    next anyall if !smartmatch($lval, $rval);  # ...because not all RHS vals match LHS
                }
                return true;  # ...because all RHS values have matched some LHS value
            }
            return false;  # ...because no LHS value matched all RHS values

    nonenone:; # This one's tricky: it means there isn't an LHS elem that matches no RHS elem,
               # which is the same as all LHS elems matching at least one (i.e. any) RHS elem
               # so we just fall through to...

    allany: for my $lval (@left)  {
                for my $rval (@right) {
                    next allany if smartmatch($lval, $rval);  # ...because at least 1 RHS value matched
                }
                return false;  # ...because no RHS value matched the current LHS value
            }
            return true;  # ...because every RHS value matched at least one RHS value

    allall: for my $lval (@left)  {
            for my $rval (@right) {
                return false if !smartmatch($lval, $rval);  # ...because a single mismatch is failure
            }}
            return true;  # ...because every possible LHS/RHS combination matched

    noneany: for my $lval (@left)  {
             for my $rval (@right) {
                 return false if smartmatch($lval, $rval);  # ...because a single match is failure
             }}
             return true;  # ...because every LHS value failed to match any RHS value

    noneall: for my $lval (@left)  {
                 for my $rval (@right) {
                     # This left elem is okay if it doesn't match at least one right elem...
                     next noneall if !smartmatch($lval, $rval);
                     # ...because every LHS value must mismatch at least one RHS value
                 }
                 return false;  # ...because an LHS value did match all RHS values
             }
             return true;  # ...because every LHS value failed to match at least one RHS value

    anynone: for my $lval (@left)  {
                 for my $rval (@right) {
                     next anynone if smartmatch($lval, $rval);
                     # ...because this left elem matched an RHS value, so it can't be the chosen one
                 }
                 return true;  # ...because an LHS did match none of the RHS values
             }
             return false;  # ...because we didn''t find an LHS value that matched no RHS value

    allnone: for my $lval (@left)  {
             for my $rval (@right) {
                return false if smartmatch($lval, $rval);  # ...because any match is disqualifying
             }}
             return true;  # ...because every LHS/RHS combination has now failed to match
}

1; # Magic true value required at end of module
__END__