File Coverage

blib/lib/Perl6/Controls.pm

Criterion	Covered	Total	%
statement	220	361	60.9
branch	18	44	40.9
condition	16	32	50.0
subroutine	38	40	95.0
pod			n/a
total	292	477	61.2

package Perl6::Controls;

use 5.012; use warnings;

our $VERSION = '0.000007';


use Keyword::Declare;

sub import {

    # Rewire the 'for' loop (but we need to handle existing usages first)...

    keyword for {{{ foreach }}}

    keytype OptIter is /(?:my|our|state)\s*\$\w+/;

    keyword for (OptIter $iter = '', '(', '^', Int $max, ')') {{{ for <{$iter}> (0..<{$max-1}>) }}}

    keyword for (ParenthesesList $list, '->', CommaList $parameters, Block $code_block)
                :desc(enhanced for loop)
    {{{
        {
            state $__acc__ = [];
            foreach my $__nary__  <{ $list =~ s{\)\Z}{,\\\$__acc__)}; $list }>
            {
                if (!ref($__nary__) || $__nary__ != \$__acc__) {
                    push @{$__acc__}, $__nary__;
                    next if @{$__acc__} <= <{ $parameters =~ tr/,// }>;
                }
                next if !@{$__acc__};
                my ( <{"$parameters"}> ) = @{$__acc__};
                @{$__acc__} = ();

                <{substr $code_block, 1, -1}>
            }
        }
    }}}


    # Perl 6 infinite loop...
    keyword loop (Block $loop_block)  {{{
        foreach (;;) <{$loop_block}>
    }}}


    # Perl 6 while loop...
    keyword while (List $condition, Block $loop_block)  {{{
        foreach (;<{$condition}>;) <{$loop_block}>
    }}}

    keyword while (List $condition, '->', ScalarVar $parameter, Block $loop_block)  {{{
        foreach (;my <{$parameter}> = <{$condition}>;) <{$loop_block}>
    }}}


    # Perl 6 repeat...while and variants...

    keyword repeat ('while', List $while_condition, Block $code_block) :desc(repeat loop)  {{{
        foreach(;;) <{substr($code_block,0,-2)}>; last if !(<{$while_condition}>); }
    }}}

    keyword repeat ('until', List $until_condition, Block $code_block) {{{
        foreach(;;) <{substr($code_block,0,-2)}>; last if <{$until_condition}>; }
    }}}

    keyword repeat (Block $code_block,
                    /while|until/ $while_or_until,
                    Expr $condition) {
        my $not = $while_or_until eq 'while' ? q{!} : q{};
        qq{ foreach (;;) { do $code_block; last if $not ($condition); } };
    }


    # Special Perl 6 phasers within loops...

    keytype Etc is / (?: (?&PerlOWS) (?&PerlStatement) )* (?&PerlOWS) \} /x;

    keyword LEAVE (Block $code_block) :desc(LEAVE block) {
        state $leave_var = '__LEAVE__00000000000000000000000001';
        return qq{use Scope::Upper; Scope::Upper::reap $code_block;};
    }

    keyword FIRST (Block $code_block) :then(Etc $rest_of_block) :desc(FIRST block) {
        state $FIRST_ID = 'FIRST000000'; $FIRST_ID++;
        qq{
            if (!(our \$$FIRST_ID)++) $code_block
            $rest_of_block;
            {our \$$FIRST_ID = 0}
        };
    }

    keyword NEXT (Block $code_block) :then(Etc $rest_of_block) :desc(NEXT block) {
        state $NEXT_ID = 'NEXT000000'; $NEXT_ID++;
        chop $rest_of_block;
        qq{
            my \$$NEXT_ID = sub $code_block;
            $rest_of_block;
            \$$NEXT_ID->();
            \}
        };
    }

    keyword LAST (Block $code_block) :then(Etc $rest_of_block) :desc(LAST block) {
        state $LAST_ID = 'LAST000000'; $LAST_ID++;
        qq{
            our \$$LAST_ID = sub $code_block;
            $rest_of_block;
            {our \$$LAST_ID->();}
        };
    }

    # try and CATCH...

    keytype CatchParam is / \( (?&PerlOWS) (?&PerlVariableScalar) (?&PerlOWS) \) /x;

    keyword CATCH (CatchParam $param = '($P6C____EXCEPTION)', Block $block) :desc(CATCH phaser) {{{
        BEGIN { eval'$P6C____CATCH=$P6C____CATCH;1' // die q{Can't specify CATCH block outside a try};              }
        BEGIN { die q{Can't specify two CATCH blocks inside a single try} if defined $P6C____CATCH;          }
        BEGIN { $P6C____CATCH = sub { use experimentals; my <{$param}> = @_; given (<{$param}>) <{$block}> } }
    }}}

    keyword try (Block $block) {{{
        { my $P6C____CATCH; eval { <{$block}> 1 } // do{ my $error = $@; $P6C____CATCH && $P6C____CATCH->($error) }; }
    }}}


    # Feed statement...

    keytype FeedArg is / (?&PerlExpression) (?&PerlOWS) ==> /xs;

    keyword feed (FeedArg @from, Expr $to) {

        my @list = map {
            m{\A ( (?&PerlVariable) | (?&PerlVariableDeclaration) ) \Z  $PPR::GRAMMAR }xms
                ? "($1) = "
                : $_
        }
        ($to, reverse map { substr($_,0,-4) } @from);

        while (@list > 1) {
            my ($func, $data) = splice(@list, -2);
            push @list, "($func $data)";
        }

        return $list[0];
    }
}

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