File Coverage

blib/lib/Text/Xslate/Syntax/TTerse.pm

Criterion	Covered	Total	%
statement	296	301	98.3
branch	48	54	88.8
condition	11	14	78.5
subroutine	32	32	100.0
pod	0	24	0.0
total	387	425	91.0

package Text::Xslate::Syntax::TTerse;
use Mouse;
use Text::Xslate::Util qw(p any_in);
use Scalar::Util ();

extends qw(Text::Xslate::Parser);

sub _build_identity_pattern {
    return qr/(?: [A-Za-z_] [A-Za-z0-9_]* )/xms;
}

# [% ... %] and %% ...
sub _build_line_start { '%%' }
sub _build_tag_start  { '[%' }
sub _build_tag_end    { '%]' }

around trim_code => sub {
    my($super, $self, $code) = @_;

    if($code =~ /^\#/) { # multiline comments
        return '';
    }

    return $super->($self, $code);
};

sub init_symbols {
    my($parser) = @_;
    my $s;

    $parser->init_basic_operators();

    $parser->symbol('$')->set_nud(\&nud_dollar);
    $parser->make_alias('~' => '_');
    $parser->make_alias('|' => 'FILTER');
    $parser->symbol('.')->set_led(\&led_dot); # redefine

    $parser->symbol('END')  ->is_block_end(1);
    $parser->symbol('ELSE') ->is_block_end(1);
    $parser->symbol('ELSIF')->is_block_end(1);
    $parser->symbol('CASE') ->is_block_end(1);

    $parser->symbol('IN');

    $s = $parser->symbol('IF');
    $s->set_std(\&std_if);
    $s->can_be_modifier(1);
    $s = $parser->symbol('UNLESS');
    $s->set_std(\&std_if);
    $s->can_be_modifier(1);

    $parser->symbol('FOREACH') ->set_std(\&std_for);
    $parser->symbol('FOR')     ->set_std(\&std_for);
    $parser->symbol('WHILE')   ->set_std(\&std_while);
    $parser->symbol('SWITCH')  ->set_std(\&std_switch);
    $parser->symbol('CASE')    ->set_std(\&std_case);

    $parser->symbol('INCLUDE') ->set_std(\&std_include);
    $parser->symbol('WITH');

    $parser->symbol('GET')     ->set_std(\&std_get);
    $parser->symbol('SET')     ->set_std(\&std_set);
    $parser->symbol('DEFAULT') ->set_std(\&std_set);
    $parser->symbol('CALL')    ->set_std(\&std_call);

    $parser->symbol('NEXT')    ->set_std( $parser->can('std_next') );
    $parser->symbol('LAST')    ->set_std( $parser->can('std_last') );

    $parser->symbol('MACRO') ->set_std(\&std_macro);
    $parser->symbol('BLOCK');
    $parser->symbol('WRAPPER')->set_std(\&std_wrapper);
    $parser->symbol('INTO');

    $parser->symbol('FILTER')->set_std(\&std_filter);

    # unsupported directives
    my $nos = $parser->can('not_supported');
    foreach my $keyword (qw(
            INSERT PROCESS PERL RAWPERL TRY THROW RETURN
            STOP CLEAR META TAGS DEBUG VIEW)) {
        $parser->symbol($keyword)->set_std($nos);
    }

    # not supported, but ignored (synonym to CALL)
    $parser->symbol('USE')->set_std(\&std_call);

    foreach my $id(keys %{$parser->symbol_table}) {
        if($id =~ /\A [A-Z]+ \z/xms) { # upper-cased keywords
            $parser->make_alias($id => lc $id)->set_nud(\&aliased_nud);
        }
    }

    $parser->make_alias('not' => 'NOT');
    $parser->make_alias('and' => 'AND');
    $parser->make_alias('or'  => 'OR');

    return;
}

around _build_iterator_element => sub {
    my($super, $parser) = @_;

    my $table = $super->($parser);

    # make aliases
    $table->{first} = $table->{is_first};
    $table->{last}  = $table->{is_last};
    $table->{next}  = $table->{peek_next};
    $table->{prev}  = $table->{peek_prev};
    $table->{max}   = $table->{max_index};

    return $table;
};

sub default_nud {
    my($parser, $symbol) = @_;
    return $symbol->clone(
        arity => 'variable',
    );
}

# same as default_nud, except for aliased symbols
sub aliased_nud {
    my($parser, $symbol) = @_;
    return $symbol->clone(
        arity => 'name',
        id    => lc( $symbol->id ),
        value => $symbol->id,
    );
}

sub nud_dollar {
    my($parser, $symbol) = @_;
    my $expr;
    my $t = $parser->token;
    if($t->id eq "{") {
        $parser->advance("{");
        $expr = $parser->expression(0);
        $parser->advance("}");
    }
    else {
        if(!any_in($t->arity, qw(name variable))) {
            $parser->_unexpected("a name", $t);
        }
        $parser->advance();
        $expr = $t->clone( arity => 'variable' );
    }
    return $expr;
}

sub undefined_name {
    my($parser, $name) = @_;
    # undefined names are always variables
    return $parser->symbol_table->{'(variable)'}->clone(
        id => $name,
    );
}

sub is_valid_field {
    my($parser, $token) = @_;
    return $parser->SUPER::is_valid_field($token)
        || $token->arity eq "variable";
}

sub led_dot {
    my($parser, $symbol, $left) = @_;

    # special case: foo.$field, foo.${expr}
    if($parser->token->id eq '$') {
        return $symbol->clone(
            arity  => "field",
            first  => $left,
            second => $parser->expression( $symbol->lbp ),
        );
    }

    return $parser->SUPER::led_dot($symbol, $left);
}

sub led_assignment {
    my($parser, $symbol, $left) = @_;

    my $assign = $parser->led_infixr($symbol, $left);
    $assign->arity('assign');
    $assign->is_statement(1);

    my $name = $assign->first;
    if(not $parser->find_or_create($name->id)->is_defined) {
        $parser->define($name);
        $assign->third('declare');
    }

    return $assign;
}

sub assignment {
    my($parser, $id, $bp) = @_;

    $parser->symbol($id, $bp)->set_led(\&led_assignment);
    return;
}

sub std_if {
    my($parser, $symbol, $expr) = @_;
    my $if = $symbol->clone(arity => "if");

    my $is_modifier = defined $expr;

    $parser->new_scope() unless $is_modifier; # whole if block

    my $cond = $parser->expression(0);

    if($symbol->id eq 'UNLESS') {
        $cond = $parser->symbol('!')->clone(
            arity  => 'unary',
            first  => $cond,
        );
    }
    $if->first($cond);

    if($is_modifier) {
        $if->second([ $expr ]);
        return $if;
    }

    # then block
    {
        $parser->new_scope();
        $if->second( $parser->statements() );
        $parser->pop_scope();
    }

    my $t = $parser->token;

    my $top_if = $if;

    while($t->id eq "ELSIF") {
        $parser->reserve($t);
        $parser->advance(); # "ELSIF"

        my $elsif = $t->clone(arity => "if");
        $elsif->first(  $parser->expression(0) );

        {
            $parser->new_scope();
            $elsif->second( $parser->statements() );
            $parser->pop_scope();
        }

        $if->third([$elsif]);
        $if = $elsif;
        $t  = $parser->token;
    }

    if($t->id eq "ELSE") {
        my $else_line = $t->line;
        $parser->reserve($t);
        $t = $parser->advance(); # "ELSE"

        if($t->id eq "IF" and $t->line != $else_line) {
            Carp::carp(sprintf "%s: Parsing ELSE-IF sequense as ELSIF, but it is likely to be a misuse of ELSE-IF. Please insert semicolon as ELSE; IF, or write it in the same line (around input line %d)", ref $parser, $t->line);
        }

        {
            $parser->new_scope();
            $if->third( $t->id eq "IF"
                ? [$parser->statement()]
                :  $parser->statements());
            $parser->pop_scope();
        }
    }

    $parser->advance("END");
    $parser->pop_scope();
    return $top_if;
}

sub std_switch {
    my($parser, $symbol) = @_;

    $parser->new_scope();

    my $topic  = $parser->symbol('$_')->clone(arity => 'variable' );
    my $switch = $symbol->clone(
        arity  => 'given',
        first  => $parser->expression(0),
        second => [ $topic ],
    );

    local $parser->{in_given} = 1;

    my @cases;
    while(!($parser->token->id eq "END" or $parser->token->id eq '(end)')) {
        push @cases, $parser->statement();
    }
    $switch->third( \@cases );

    $parser->build_given_body($switch, "case");

    $parser->advance("END");
    $parser->pop_scope();
    return $switch;
}

sub std_case {
    my($parser, $symbol) = @_;
    if(!$parser->in_given) {
        $parser->_error("You cannot use $symbol statements outside switch statements");
    }
    my $case = $symbol->clone(arity => "case");

    if($parser->token->id ne "DEFAULT") {
        $case->first( $parser->expression(0) );
    }
    else {
        $parser->advance();
    }
    $case->second( $parser->statements() );
    return $case;
}

sub iterator_name {
    return 'loop'; # always 'loop'
}

# FOR ... IN ...; ...; END
sub std_for {
    my($parser, $symbol) = @_;

    my $proc = $symbol->clone(arity => "for");

    my $var = $parser->token;
    if(!any_in($var->arity, qw(variable name))) {
        $parser->_unexpected("a variable name", $var);
    }
    $parser->advance();
    $parser->advance("IN");
    $proc->first( $parser->expression(0) );
    $proc->second([$var]);

    $parser->new_scope();
    $parser->define_iterator($var);

    $proc->third( $parser->statements() );

    # for-else
    if($parser->token->id eq 'ELSE') {
        $parser->reserve($parser->token);
        $parser->advance();
        my $else = $parser->statements();
        $proc = $symbol->clone( arity => 'for_else',
            first  => $proc,
            second => $else,
        );
    }
    $parser->advance("END");
    $parser->pop_scope();
    return $proc;
}

sub std_while {
    my($parser, $symbol) = @_;

    my $while = $symbol->clone(arity => "while");

    $while->first( $parser->expression(0) );
    $while->second([]); # no vars
    $parser->new_scope();
    $while->third( $parser->statements() );
    $parser->advance("END");
    $parser->pop_scope();
    return $while;
}

around std_include => sub {
    my($super, $self, $symbol) = @_;
    $symbol->id( lc $symbol->id );
    return $self->$super( $symbol );
};

sub localize_vars {
    my($parser, $symbol) = @_;

# should make 'WITH' optional?
#    my $t = $parser->token;
#    if($t->id eq "WITH" or $t->arity eq "variable") {
#        $parser->advance() if $t->id eq "WITH";
    if($parser->token->id eq "WITH") {
        $parser->advance();
        $parser->new_scope();
        my $vars = $parser->set_list();
        $parser->pop_scope();
        return $vars;
    }
    return undef;
}

sub set_list {
    my($parser) = @_;
    my @args;
    while(1) {
        my $key = $parser->token;

        if(!(any_in($key->arity, qw(variable name))
                && $parser->next_token_is("="))) {
            last;
        }
        $parser->advance();
        $parser->advance("=");

        my $value = $parser->expression(0);

        push @args, $key => $value;

        if($parser->token->id eq ",") { # , is optional
            $parser->advance();
        }
    }

    return \@args;
}

sub std_get {
    my($parser, $symbol) = @_;

    my $stmt = $parser->print( $parser->expression(0) );
    return $parser->finish_statement($stmt);
}

sub std_set {
    my($parser, $symbol) = @_;

    my $is_default = ($symbol->id eq 'DEFAULT');

    my $set_list = $parser->set_list();
    my @assigns;
    for(my $i = 0; $i < @{$set_list}; $i += 2) {
        my($name, $value) = @{$set_list}[$i, $i+1];

        if($is_default) { # DEFAULT a = b -> a = a || b
            my $var = $parser->symbol('(variable)')->clone(
                id => $name->id,
            );

            $value = $parser->binary('||', $var, $value);
        }
        my $assign = $symbol->clone(
            id     => '=',
            arity  => 'assign',
            first  => $name,
            second => $value,
        );

        if(not $parser->find_or_create($name->id)->is_defined) {
            $parser->define($name);
            $assign->third('declare');
        }
        push @assigns, $assign;
    }
    return @assigns;
}

sub std_call {
    my($parser, $symbol) = @_;
    my $stmt = $parser->expression(0);
    return $parser->finish_statement($stmt);
}

sub std_macro {
    my($parser, $symbol) = @_;
    my $proc = $symbol->clone(
        arity => 'proc',
        id    => 'macro',
    );

    my $name = $parser->token;
    if($name->arity ne "variable") {
        $parser->_error("a name", $name);
    }

    $parser->define_function($name->id);

    $proc->first($name);
    $parser->advance();

    $parser->new_scope();

    my $paren = ($parser->token->id eq "(");

    $parser->advance("(") if $paren;

    my $t = $parser->token;
    my @vars;
    while($t->arity eq "variable") {
        push @vars, $t;
        $parser->define($t);

        $t = $parser->advance();

        if($t->id eq ",") {
            $t = $parser->advance(); # ","
        }
        else {
            last;
        }
    }
    $parser->advance(")") if $paren;

    $proc->second(\@vars);

    $parser->advance("BLOCK");
    $proc->third( $parser->statements() );
    $parser->advance("END");
    $parser->pop_scope();
    return $proc;
}


# WRAPPER "foo.tt" ...  END
# is
# cascade "foo.tt" { content => lambda@xxx() }
# macro content@xxx -> { ... }
sub std_wrapper {
    my($parser, $symbol) = @_;

    my $base  = $parser->barename();
    my $into;
    if($parser->token->id eq "INTO") {
        my $t = $parser->advance();
        if(!any_in($t->arity, qw(name variable))) {
            $parser->_unexpected("a variable name", $t);
        }
        $parser->advance();
        $into = $t->id;
    }
    else {
        $into = 'content';
    }
    my $vars  = $parser->localize_vars() || [];
    my $body  = $parser->statements();
    $parser->advance("END");

    return $parser->wrap(
        $symbol,
        $base,
        $into,
        $vars,
        $body,
    );
}

sub wrap {
    my($parser, $proto, $base, $into, $vars, $body) = @_;
    my $cascade = $proto->clone(
        arity => 'cascade',
        first => $base,
    );

    my $content = $parser->lambda($proto);
    $content->second([]); # args
    $content->third($body);

    my $call_content = $parser->call($content->first);

    my $into_name = $proto->clone(
        arity => 'literal',
        id    => $into,
    );

    push @{$vars}, $into_name => $call_content;
    $cascade->third($vars);
    return( $cascade, $content );
}

# [% FILTER html %]
# ...
# [% END %]
# is
# : block filter_xxx | html -> {
#   ...
# : }
# in Kolon

sub std_filter {
    my($parser, $symbol) = @_;

    my $filter = $parser->expression(0);

    my $proc = $parser->lambda($symbol);

    $proc->second([]);
    $proc->third( $parser->statements() );
    $parser->advance("END");

    my $callmacro  = $parser->call($proc->first);

    if($filter->id eq 'html') {
        # for compatibility with TT2
        $filter = 'unmark_raw';
    }
    my $callfilter = $parser->call($filter, $callmacro);
    return( $proc, $parser->print($callfilter) );
}

no Mouse;
__PACKAGE__->meta->make_immutable();
__END__