File Coverage

lib/Keyword/TreeFold.pm

Criterion	Covered	Total	%
statement	23	23	100.0
branch	2	4	50.0
condition	2	4	50.0
subroutine	8	8	100.0
pod	0	3	0.0
total	35	42	83.3

########################################################################
# housekeeping
########################################################################

package Keyword::TreeFold v0.1.1;
use v5.20;

use Keyword::Declare;

########################################################################
# package variables
########################################################################
########################################################################
# utility subs
########################################################################

sub simple_code
{
    my $list_op = shift;
    my $size    = @_;

    qq|\@_ = \ndo $list_op;\n|
}

sub lexical_code
{
    my ( $list_op, @varz ) = @_;

    my $count   = @varz;
    my $offset  = $count - 1;
    my $lexical = join ',' => @varz;

qq
|
    my \$last
    = \@_ % $count
    ? int( \@_ / $count )
    : int( \@_ / $count ) - 1
    ;

    \@_
    = map
    {
        my ( $lexical ) = \@_[ \$_ .. \$_ + $offset ];

        do
######
$list_op
######
    }
    map
    {
        \$_ * $count
    }
    ( 0 .. \$last );
|

}

sub boilerplate
{
    my ( $name, $guts ) = @_;

    <<"SUBDEF"
sub $name
{
    use Carp qw( croak );

    \@_ > 1 or return \$_[0];

    my \$size = \@_;

    $guts

    croak "Stack not shrinking: \$size elements."
    unless \@_ < \$size;

    goto __SUB__
}
SUBDEF
}

########################################################################
# delcare keywords
########################################################################

sub import
{
    keyword tree_fold( Ident $name, List $argz, Block $list_op )
    {
        my @varz
        = map
        {
            $_->isa( 'PPI::Token::Symbol' )
            ? $_->{ content }
            : ()
        }
        map
        {
            $_->isa( 'PPI::Statement::Expression' )
            ? @{ $_->{ children } }
            : ()
        }
        @{ $argz->{ children } };

        if( @varz > 1 )
        {
            boilerplate $name, lexical_code "$list_op", @varz
        }
        elsif( @varz )
        {
            die
            "Bogus tree_fold: '$name' with single variable '$varz[0]'.";
        }
        else
        {
            boilerplate $name, simple_code  "$list_op"
        }
    }

    keyword tree_fold( Ident $name, Block $list_op )
    {
        boilerplate $name, simple_code  "$list_op";
    }
}

1
__END__