File Coverage

blib/lib/Switch/Back.pm

Criterion	Covered	Total	%
statement	189	487	38.8
branch	44	216	20.3
condition	9	37	24.3
subroutine	37	51	72.5
pod	0	2	0.0
total	279	793	35.1

package Switch::Back;

use 5.036;
our $VERSION = '0.000005';

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

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 $SMARTMATCHABLE;
BEGIN { $SMARTMATCHABLE
    = qr{ \A
             (?> \\ $OWS   (?&PerlVariableArray)
             |   \\ $OWS   (?&PerlVariableHash)
             |   \\ $OWS & (?&PerlQualifiedIdentifier)
             |             (?&PerlPrefixUnaryOperator) (?&PerlScalarAccess)
             |             (?&PerlScalarAccess) (?&PerlPostfixUnaryOperator)?+
             |             (?&PerlAnonymousArray)
             |             (?&PerlAnonymousHash)
             |             (?&PerlAnonymousSubroutine)
             |             (?&PerlString)
             |             (?&PerlNumber)
             |             (?&PerlQuotelikeQR)
             |             (?&PerlBareword)
             |             undef
             )
          $OWS
          \z $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;
}

# Detect and rewrite "pure" given blocks (recursively if necessary)...
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    )  (?>(? (?&PerlExpression)))
                             (? $OWS    )  \)
                             (? $OWS \{ $OWS )  (?>(?  (?&PureBlock)  ))  \}
            )
            (?>(?  .*  ))

            (?(DEFINE)
                (?    # Distinguish "when", "default", and "given" from other statements...
                    (?:
                        when (? $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;

        return
              "if (1) $matched{ws_post_kw} { local *_ = $matched{ws_pre_expr} \\scalar($matched{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};
                    $after_a_statement = 0;
                      "$PREFIX elsif $_->{WHENOPEN}" . _apply_when_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) {

        # Recognize a valid given block (with a single scalar argument)...
        state $VALIDATE_GIVEN = qr{
            \A  (? $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, $EXPR, $BLOCK, $TRAILING_CODE) = @result{qw< GIVEN EXPR BLOCK TRAILING_CODE >};

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

            # Topicalize the "given" argument...
            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 (? (?&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, $EXPR, $BLOCK, $TRAILING_CODE)
            = @matched{qw< WHEN EXPR BLOCK TRAILING_CODE>};

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

        # Implement the boolean operator magic...
        $EXPR = _apply_when_magic($EXPR);

        # Implement the "when" as an "if"...
        $REPLACEMENT_CODE = qq{if(1){local \$Switch::Back::when_value = ($EXPR); if(1){if (\$Switch::Back::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::Back/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::Back/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) {
        # 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::Back/$NAME'} = '$ID'; } };

        # A when block auto-breaks at the end of its block...
        if ($KIND eq 'when') {
            my $AFTERGIVEN = $^H{'Switch::Back/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} };
        }

        # Given blocks must to pre-convert postfix "when" modifiers (which can't be keyworded)...
        # and must also preprocess "continue" to a unpunned name...
        elsif ($KIND eq 'given') {
            $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++;

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

    return $BLOCK;
}

# Change the target expression of a "when" to implement all the magic behaviours...
sub _apply_when_magic ($EXPR) {
    # Reduce the expression to what the compiler would see...
    $EXPR = _simplify_expr($EXPR);

    # Split on low-precedence or...
    my @low_disj = grep { defined }
                   $EXPR =~ m{ (                 (?>(?&PerlLowPrecedenceNotExpression))
                                (?:
                                    (?>(?&PerlOWS)) and
                                    (?>(?&PerlOWS)) (?&PerlLowPrecedenceNotExpression)
                                )*+
                               )
                               (?>(?&PerlOWS))  (?: or | \z )  (?>(?&PerlOWS))

                               (?(DEFINE)
                                    (?
                                                                (?>(?&PerlAssignment))
                                        (?:
                                            (?: (?>(?&PerlOWS)) (?>(?&PerlComma))  )++
                                                (?>(?&PerlOWS)) (?>(?&PerlAssignment))
                                        )*+
                                            (?: (?>(?&PerlOWS)) (?>(?&PerlComma)) )*+
                                    ) # End of rule (?)
                               )

                               $PPR::GRAMMAR }gxms;

    # If expression is a low-precedence or, apply any appropriate magic...
    if (@low_disj > 1) {
        # If the left-most operand isn't smartmatchable, the expression as a whole isn't,
        # so just return it...
        my $low_lhs   = shift @low_disj;
        my $magic_lhs = _apply_low_conj_magic($low_lhs);
        if ($low_lhs eq $magic_lhs) {
            return $EXPR;
        }

        # Otherwise, every operand has magic applied to it...
        else {
            return join ' or ', $magic_lhs, map { _apply_low_conj_magic($_) } @low_disj;
        }
    }

    # Otherwise, see if it's a low-precedence conjunction...
    return _apply_low_conj_magic($EXPR);
}

sub _apply_low_conj_magic ($EXPR) {
    # Split on low-precedence and...
    my @low_conj = grep { defined }
                   $EXPR =~ m{ ( (?>(?&PerlLowPrecedenceNotExpression)) )
                               (?>(?&PerlOWS))  (?: and | \z )  (?>(?&PerlOWS))

                               (?(DEFINE)
                                    (?
                                                                (?>(?&PerlAssignment))
                                        (?:
                                            (?: (?>(?&PerlOWS)) (?>(?&PerlComma))  )++
                                                (?>(?&PerlOWS)) (?>(?&PerlAssignment))
                                        )*+
                                            (?: (?>(?&PerlOWS)) (?>(?&PerlComma)) )*+
                                    ) # End of rule (?)
                               )

                               $PPR::GRAMMAR }gxms;

    # If expression is a low-precedence and, apply any appropriate magic...
    if (@low_conj > 1) {
        # Every operand must be recursively magical, or none of them are...
        my @magic_expr;
        for my $next_operand (@low_conj) {
            my $magic_operand = _apply_high_disj_magic($next_operand);

            # If any operand isn't smartmatchable, the whole expr isn't magical,
            # so just smartmatch the entire expression...
            if ($magic_operand eq $next_operand) {
                return $EXPR;
            }

            # Otherwise, accumulate the magic...
            push @magic_expr, $magic_operand;
        }
        return join " and ", @magic_expr;
    }

    # Otherwise, see if it's a high-precedence disjunction...
    return _apply_high_disj_magic($EXPR);
}

sub _apply_high_disj_magic ($EXPR) {
    # Split on high-precedence or...
    my @high_disj = grep { defined }
                   $EXPR =~ m{ ( (?>(?&PerlBinaryExpression)) )
                               (?>(?&PerlOWS))  ( \|\| | // | \z )  (?>(?&PerlOWS))

                               (?(DEFINE)
                                    (?
                                        (?! \|\| | // ) (?&PerlStdInfixBinaryOperator)
                                    )
                               )
                               $PPR::X::GRAMMAR
                           }gxms;

    # If expression is a high-precedence || or //, apply any appropriate magic...
    if (@high_disj > 1) {
        # If the left-most operand isn't smartmatchable, the expression as a whole isn't,
        # so just return it...
        my $high_lhs    = shift @high_disj;
        my $magic_expr = _apply_high_conj_magic($high_lhs);
        if ($high_lhs eq $magic_expr) {
            return $EXPR;
        }

        # Otherwise, every operand has magic applied to it...
        else {
            while (@high_disj > 1) {
                my $next_operator = shift @high_disj;
                my $next_operand  = shift @high_disj;
                $magic_expr .= " $next_operator " . _apply_high_conj_magic($next_operand);
            }
            return $magic_expr;
        }
    }

    # Otherwise, see if it's a high-precedence conjunction...
    return _apply_high_conj_magic($EXPR);
}

sub _apply_high_conj_magic ($EXPR) {
    # Split on high-precedence &&...
    my @high_conj = grep { defined }
                   $EXPR =~ m{ ( (?>(?&PerlBinaryExpression)) )
                               (?>(?&PerlOWS))  (?: && | \z )  (?>(?&PerlOWS))

                               (?(DEFINE)
                                    (?
                                        (?! && ) (?&PerlStdInfixBinaryOperator)
                                    )
                               )
                               $PPR::X::GRAMMAR
                           }gxms;

    # If expression is a high-precedence &&, apply any appropriate magic...
    if (@high_conj > 1) {
        # Every operand must be recursively smartmatchable, or none of them are...
        my @magic_expr;
        for my $next_operand (@high_conj) {
            my $magic_operand = _apply_term_magic($next_operand);

            # If any operand isn't smartmatchable, the whole expr isn't magical,
            # so just treat the entire expression as a boolean expression...
            if ($magic_operand eq $next_operand) {
                return $EXPR;
            }

            # Otherwise, accumulate the magic...
            push @magic_expr, $magic_operand;
        }
        return join " && ", @magic_expr;
    }

    # Otherwise, see if it's a magical term...
    return _apply_term_magic($EXPR);
}

# Detect whether a term in a "when" expression is magical and adjust it accordingly...
sub _apply_term_magic ($EXPR) {

    # An @array or %hash gets enreferenced and then smartmatched...
    if ($EXPR =~ $CONTAINER_VARIABLE) {
        return " smartmatch(\$_, \\$EXPR) ";
    }

    # An @array[@slice] or %kv[@slice] gets appropriately wrapped and then smartmatched...
    if ($EXPR =~ $ARRAY_SLICE) {
        return " smartmatch(\$_, [$EXPR]) ";
    }
    if ($EXPR =~ $HASH_SLICE) {
        return " smartmatch(\$_, {$EXPR}) ";
    }

    # Non-magical values get smartmatched...
    if ($EXPR =~ $SMARTMATCHABLE) {
        return " smartmatch(\$_, $EXPR) ";
    }

    # Anything else is magically NOT smartmatched (it's treated as a simple boolean test)...
    return $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;
    state $deparse = B::Deparse->new;
    return $deparse->coderef2text(eval qq{no strict; sub{ANSWER( $code );DONE()}})
                =~ s{.* ANSWER \( (.*) \) \s* ; \s* DONE() .* \z}{$1}gxmsr;
}


# Reimplement the standard smartmatch operator
# (This could have been a set of multis, but a single multi is currently much faster)...

multi smartmatch ($left, $right) {

    # Categorize the two args...
    my $right_type = ref $right;
    my $left_type  = ref $left;

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

    # 1. Handle RHS undef...
    if (!defined $right) {
        return !defined $left;
    }

    # 2. Objects on the RHS can't be handled (at all, because no ~~ overloading available)...
    croak 'Smart matching an object breaks encapsulation'
        if $right_type ne 'Regexp' && blessed($right);

    # 3. Array on the RHS..
    if ($right_type eq 'ARRAY') {

        # 3a. Array of the LHS too...
        if ($left_type eq 'ARRAY') {
            # Match if identical array refs...
            return true if $left == $right;

            # Different lengths, so won't match...
            return false if @{$left} != @{$right};

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

            # Otherwise every pair of elements from the two arrays must smartmatch...
            for my $n (keys @{$right}) {
                return false if !smartmatch($left->[$n], $right->[$n]);
            }
            return true;
        }

        # 3b. Hash on the LHS...
        elsif ($left_type eq 'HASH') {
            # Matches if any right array element is a left hash key...
            for my $r (@{$right}) {
                if (!defined $r) {
                    carp 'Use of uninitialized value in smartmatch'
                        if warnings::enabled('uninitialized');
                }
                return true if exists $left->{ $r // q{} };
            }
            return false;
        }

        # 3c. Regex on the LHS...
        elsif ($left_type eq 'Regexp') {
            # Matches if left arg pattern-matches any element of right array...
            for my $r (@{$right}) {
                return true if $r =~ $left;
            }
            return false;
        }

        # 3d. undef on the LHS...
        elsif (!defined $left) {
            # Matches if any element of right array is undefined (NON-RECURSIVELY)...
            for my $r (@{$right}) {
                return true if !defined $r;
            }
            return false;
        }

        # 3e. Anything else on the LHS...
        else {
            # Matches if left arg smartmatches any element of right array...
            for my $r (@{$right}) {
                if (!defined $r) {
                    carp 'Use of uninitialized value in smartmatch'
                        if warnings::enabled('uninitialized');
                }
                return true if smartmatch($left, $r);
            }
            return false;
        }
    }

    # 4. Hash on the RHS...
    if ($right_type eq 'HASH') {

        # 4a. Hash on the LHS...
        if ($left_type eq 'HASH') {
            # Match if they're the same hashref...
            return true  if $left == $right;

            # Fail to match if they have different numbers of keys...
            return false if %{$left} != %{$right};

            # Otherwise, match if all their keys match...
            for my $lkey (keys %{$left}) {
                return false if !exists $right->{$lkey};
            }
            return true;
        }

        # 4b. Array on the LHS...
        elsif ($left_type eq 'ARRAY') {

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

            # Match if any top-level array element is (NON-RECURSIVELY) a key in the hash...
            for my $l (@{$left}) {
                if (!defined $l) {
                    carp 'Use of uninitialized value in smartmatch'
                        if warnings::enabled('uninitialized');
                }
                return true if exists $right->{ $l // q{} };
            }
            return false;
        }

        # 4c. Regex on the LHS...
        elsif ($left_type eq 'Regexp') {
            # Match if any hash key is matched by the regex...
            for my $rkey (keys %{$right}) {
                return true if $rkey =~ $left;
            }
            return false;
        }

        # 4d. undef on the LHS...
        elsif (!defined $left) {
            # Hash keys can never be undef...
            return false;
        }

        # 4e. Anything else on the LHS...
        else {
            # Match if the stringified left arg is a key of right hash...
            if (!defined $left) {
                carp 'Use of uninitialized value in smartmatch'
                    if warnings::enabled('uninitialized');
            }
            return exists $right->{ $left // q{} };
        }
    }

    # 5. Subroutine reference on the RHS...
    if ($right_type eq 'CODE') {

        # 5a. Array on the LHS...
        if ($left_type eq 'ARRAY') {

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

            # Sub must always return true when called on every element of array...
            for my $l (@{$left}) {
                return false if !$right->($l);
            }
            return true;
        }

        # 5b. Hash on the LHS...
        elsif ($left_type eq 'HASH') {
            # Sub must always return true when called on every key of hash...
            for my $lkey (keys %{$left}) {
                return false if !$right->($lkey);
            }
            return true;
        }

        # 5c. Anything else on the LHS...
        else {
            # Otherwise, sub must return true when passed left arg...
            return !!$right->($left);
        }
    }

    # 6. Regexp on the RHS...
    if ($right_type eq 'Regexp') {

        # 6a. Array on the LHS...
        if ($left_type eq 'ARRAY') {

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

            # Match if any left array element pattern-matches the right regex...
            for my $l (@{$left}) {
                if (!defined $l) {
                    carp 'Use of uninitialized value in smartmatch'
                        if warnings::enabled('uninitialized');
                }
                no warnings;
                return true if $l =~ $right;
            }
            return false;
        }

        # 6b. Hash on the LHS...
        elsif ($left_type eq 'HASH') {
            # Match if any left key of the hash pattern-matches the right regex...
            for my $lkey (keys %{$left}) {
                return true if $lkey =~ $right;
            }
            return false;
        }

        # 6c. Anything else on the LHS...
        else {
            # Otherwise, the stringified left arg must pattern-match right regex...
            if (!defined $left) {
                carp 'Use of uninitialized value in pattern match (m//)'
                    if warnings::enabled('uninitialized');
            }
            no warnings;
            return $left =~ $right;
        }
    }

    # 7. Primordial numbers on the RHS attempt numeric matching against LHS values...
    if (created_as_number($right)) {
        no warnings;
        if ($Switch::Back::_use_integer) {
            use integer;
            return defined $left && $left == $right;
        }
        else {
            return defined $left && $left == $right;
        }
    }

    # 8. Primordial numbers on the LHS attempt numeric matching against LHS number-ish values...
    if (created_as_number($left) && looks_like_number($right)) {
        if ($Switch::Back::_use_integer) {
            use integer;
            return $left == $right;
        }
        else {
            return $left == $right;
        }
    }

    # 9. If LHS is undef, RHS must be too,
    #    but we know it isn't at this point, because test 1. would have caught that...
    if (!defined $left) {
        return false;
    }

    # 10. Otherwise, we just string match...
    else {
        no warnings;
        return $left eq $right;
    }
}


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