view release on metacpan or  search on metacpan

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

                        $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  (?<GIVEN>
                    $OWS  \(
                    (?<JUNC> (?: $OWS (?> any | all | none )  $OWS  => )?+ )
                                 $OWS (?>(?<EXPR> (?&PerlExpression)))
                    $OWS \)
                    (?>
                        $OWS  (?>(?<BLOCK>  (?&PerlBlock)  ))
                    |
                        (?<INVALID_BLOCK>)
                    )
                )
                (?>(?<TRAILING_CODE>  .*  ))
                $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  (?<WHEN> $OWS
                         (   \(
                             (?:
                                $OWS (?<EXPR> (?<WHENTRUE>  true  )
                                     |        (?<WHENFALSE> false )
                                     ) \b
                             |
                                (?<JUNC> (?: $OWS (?> any | all | none ) $OWS => )?+ )
                                             $OWS (?<EXPR> (?&PerlExpression))
                             )
                             $OWS \)
                             $OWS (?>(?<BLOCK> (?&PerlBlock) )
                                  | (?<INVALID_BLOCK>)
                                  )
                         |
                             (?>(?<MODIFIER> (?&PerlCommaList)))
                             (?>(?&PerlOWSOrEND)) (?> ; | (?= \} | \z ))
                         |
                             (?<INCOMPREHENSIBLE> \N{0,20} )
                         )
                )
                (?<TRAILING_CODE> .* )
            $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{
            (?<DEFAULT> $OWS (?>(?<BLOCK> (?&PerlBlock) )) )
            (?<TRAILING_CODE> .* )
            $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)