File Coverage

blib/lib/Devel/Declare/Lexer/Factory.pm

Criterion	Covered	Total	%
statement	100	127	78.7
branch	10	16	62.5
condition	2	2	100.0
subroutine	18	20	90.0
pod			n/a
total	130	165	78.7

package Devel::Declare::Lexer::Factory;

use Devel::Declare::Lexer::Stream;
use Devel::Declare::Lexer::Tokens;

use v5;

our (@ISA, @EXPORT_OK, %EXPORT_TAGS);
BEGIN {
    use Exporter;
    @ISA = qw(Exporter);
    @EXPORT_OK = qw( _stream _statement _reference _variable _string _var_assign _list _keypair _if _return _bareword _block _sub _whitespace _operator );
    %EXPORT_TAGS = (
        'all'  => \@EXPORT_OK
    );
}

sub _stream
{
    my ($old_stream, $new_stream) = @_;
    my @stream = ();
    tie @stream, 'Devel::Declare::Lexer::Stream';

    if($old_stream) {
        push @stream, shift @$old_stream; # declarator
        push @stream, shift @$old_stream; # whitespace
    }
    if($new_stream) {
        push @stream, @$new_stream;
    }

    return @stream;
}

sub _statement
{
    my ($tokens) = @_;
    my @t = ();
    push @t, @$tokens;
    push @t, new Devel::Declare::Lexer::Token::EndOfStatement;
    return @t;
}

sub _reference
{
    my ($refto) = @_;
    my @tokens = ();
    push @tokens, new Devel::Declare::Lexer::Token::Operator( value => '\\' );
    push @tokens, @$refto;
    return @tokens;
}

sub _operator
{
    my ($operator) = @_;
    return ( new Devel::Declare::Lexer::Token::Operator( value => $operator ) );
}

sub _variable
{
    my ($sigil, $name) = @_;
    my @tokens = ();
    while($sigil) {
        push @tokens, new Devel::Declare::Lexer::Token::Variable( value => substr($sigil, 0, 1) );
        $sigil = substr($sigil, 1);
    }
    push @tokens, new Devel::Declare::Lexer::Token::Bareword( value => $name );
    return @tokens;
}

sub _bareword
{
    my ($word) = @_;
    return ( new Devel::Declare::Lexer::Token::Bareword( value => $word ) );
}

sub _string
{
    my ($type, $value) = @_;
    return ( new Devel::Declare::Lexer::Token::String( start => $type, end => $type, value => $value ) );
}

sub _var_assign
{
    my ($var, $value) = @_;
    my @tokens = ();
    push @tokens, @$var;
    push @tokens, new Devel::Declare::Lexer::Token::Whitespace( value => ' ' );
    push @tokens, new Devel::Declare::Lexer::Token::Operator( value => '=' );
    push @tokens, new Devel::Declare::Lexer::Token::Whitespace( value => ' ' );
    if(ref($value) =~ /ARRAY/) {
        push @tokens, @$value;
    } else {
        push @tokens, $value;
    }
    return @tokens;
}

sub _list
{
    my @items = @_;
    my @tokens = ();
    for my $item (@items) {
        if(ref($item) =~ /ARRAY/) {
            push @tokens, @$item;
        } else {
            push @tokens, $item;
        }
        push @tokens, new Devel::Declare::Lexer::Token::Operator( value => ',' );
        push @tokens, new Devel::Declare::Lexer::Token::Whitespace( value => ' ' );
    }
    # Remove additional ,\s
    pop @tokens;
    pop @tokens;

    return @tokens;
}

sub _keypair
{
    my ($var1, $var2) = @_;
    my @tokens = ();
    push @tokens, @$var1;
    push @tokens, @$var2;
    return @tokens;
}

sub _return
{
    my ($value) = @_;
    my @tokens = ();
    push @tokens, new Devel::Declare::Lexer::Token::Bareword( value => 'return' );
    push @tokens, new Devel::Declare::Lexer::Token::Whitespace( value => ' ' );
    push @tokens, @$value;
    return @tokens;
}

sub _block
{
    my ($inner, $type, $args) = @_;
    $type = $type || '{';
    my $etype = $type;
    $etype =~ tr/{([/})]/;
    my @tokens = ();
    push @tokens, new Devel::Declare::Lexer::Token::LeftBracket( value => $type );
    push @tokens, @$inner;
    if(!$args->{no_close}) {
       push @tokens, new Devel::Declare::Lexer::Token::RightBracket( value => $etype );
    }
    return @tokens;
}

sub _whitespace
{
    my ($ws) = @_;
    return ( new Devel::Declare::Lexer::Token::Whitespace( value => $ws ) );
}

sub _sub
{
    my ($name, $block) = @_;
    my @tokens = ();
    push @tokens, new Devel::Declare::Lexer::Token::Bareword( value => 'sub' );
    push @tokens, new Devel::Declare::Lexer::Token::Whitespace( value => ' ' );
    push @tokens, new Devel::Declare::Lexer::Token::Bareword( value => $name );
    push @tokens, new Devel::Declare::Lexer::Token::Whitespace( value => ' ' );
    push @tokens, @$block;
    return @tokens;
}

sub _if
{
    my ($condition, $then, $elsifs, $else) = @_;

    my @tokens = ();

    push @tokens, new Devel::Declare::Lexer::Token::Bareword( value => 'if' );
    push @tokens, new Devel::Declare::Lexer::Token::LeftBracket( value => '(' );
    push @tokens, @$condition;
    push @tokens, new Devel::Declare::Lexer::Token::RightBracket( value => ')' );
    push @tokens, new Devel::Declare::Lexer::Token::LeftBracket( value => '{' );
    push @tokens, @$then;
    push @tokens, new Devel::Declare::Lexer::Token::RightBracket( value => '}' );

    if($elsifs) {
        my @elsif = @$elsifs;
        if(scalar @elsif > 0) {
            for my $eif (@elsif) {
                push @tokens, new Devel::Declare::Lexer::Token::Bareword( value => 'elsif' );
                push @tokens, new Devel::Declare::Lexer::Token::LeftBracket( value => '(' );
                push @tokens, @{$eif->{condition}};
                push @tokens, new Devel::Declare::Lexer::Token::RightBracket( value => ')' );
                push @tokens, new Devel::Declare::Lexer::Token::LeftBracket( value => '{' );
                push @tokens, @{$eif->{then}};
                push @tokens, new Devel::Declare::Lexer::Token::RightBracket( value => '}' );
            }
        }
    }

    if($else) {
        push @tokens, new Devel::Declare::Lexer::Token::Bareword( value => 'else' );
        push @tokens, new Devel::Declare::Lexer::Token::LeftBracket( value => '{' );
        push @tokens, @$else;
        push @tokens, new Devel::Declare::Lexer::Token::RightBracket( value => '}' );
    }

    return @tokens;
}

1;