Switch-Back

 view release on metacpan or  search on metacpan

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

            # 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} };

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

        # 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}) {

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

    # 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})} } };
    }

t/smartmatch.t  view on Meta::CPAN

sub does_match {
        my ($a, $b, $name) = @_;
        my ($as, $bs) = map do {
                no if ($] >= 5.010001), 'overloading';
                ref($_) ? qq[$_] : defined($_) ? qq["$_"] : q[undef];
        }, @_;
        $name ||= "$as matches $bs";
        ok(
                smartmatch($a, $b),
                "$name at line " . (caller)[2],
        );
}

sub doesnt_match {
        my ($a, $b, $name) = @_;
        my ($as, $bs) = map do {
                no if ($] >= 5.010001), 'overloading';
                ref($_) ? qq[$_] : defined($_) ? qq["$_"] : q[undef];
        }, @_;
        $name ||= "$as NOT matches $bs";
        ok(
                !(smartmatch($a, $b)),
                "$name at line " . (caller)[2],
        );
}

# If the right hand side is "undef", then there is only a match if
# the left hand side is also "undef".
does_match(undef, undef);
doesnt_match($_, undef)
        for 0, 1, q(), q(XXX), [], {}, sub {};

# If the right hand side is a non-reference, then the match is a