view release on metacpan or  search on metacpan

lib/Switch/Right.pm  view on Meta::CPAN

                    |   (?&PerlFieldDeclaration)
                    |   (?&PerlControlBlock)
                    |   (?&PerlFormat)
                    |
                        # POSTFIX when HAS TO BE REWRITTEN BEFORE OTHER POSTFIX MODIFIERS ARE MATCHED...
                        (?<MATCH>
                            (?<EXPR> (?>(?&PerlExpression))    (?>(?&PerlOWS))      )
                                     (?= when \b )
                            (?<MOD>  (?&PerlStatementModifier) (?>(?&PerlOWSOrEND)) )
                            (?<END>  (?> ; | (?= \} | \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  (?>(?<JUNC> (?: any | all | none ) $OWS => $OWS | ))  (?<EXPR> .* )
            $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<true false>;
    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) {