view release on metacpan or  search on metacpan

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

                    (?>(?&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...
                        (?<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++;

        # 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)
                                    (?<PerlCommaList>
                                                                (?>(?&PerlAssignment))
                                        (?:
                                            (?: (?>(?&PerlOWS)) (?>(?&PerlComma))  )++
                                                (?>(?&PerlOWS)) (?>(?&PerlAssignment))
                                        )*+
                                            (?: (?>(?&PerlOWS)) (?>(?&PerlComma)) )*+
                                    ) # End of rule (?<PerlCommaList>)
                               )

                               $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))