File Coverage

blib/lib/Plosurin/SoyTree.pm

Criterion	Covered	Total	%
statement	370	393	94.1
branch	28	44	63.6
condition	15	28	53.5
subroutine	111	115	96.5
pod	3	5	60.0
total	527	585	90.0

#===============================================================================
#
#  DESCRIPTION: util for tree
#
#       AUTHOR:  Aliaksandr P. Zahatski, <[e-mail]>
#===============================================================================

=head1 NAME

Plosurin::SoyTree - syntax tree

=head1 SYNOPSIS

    my $plo = new Plosurin::SoyTree( src => $self->body );

=head1 DESCRIPTION

Plosurin::SoyTree - syntax tree

=cut

package Soy::Actions;
use strict;
use warnings;
use v5.10;
use Data::Dumper;
our $VERSION = '0.01';

sub new {
    my $class = shift;
    bless( ( $#_ == 0 ) ? shift : {@_}, ref($class) || $class );
}

1;

package Soy::base;
use Data::Dumper;
our $VERSION = '0.01';

sub new {
    my $class = shift;
    bless( ( $#_ == 0 ) ? shift : {@_}, ref($class) || $class );
}

# return undef if ok
# else string with [error] Bad value
# or [warn] not inited variable

sub check {
    my $self = shift;
    return undef;    #ok
}

sub attrs {
    my $self = shift;
    my $attr = $self->{attribute} || [];
    my %attr = ();
    foreach my $rec (@$attr) {
        $attr{ $rec->{name} } = $rec->{value};
    }
    return \%attr;
}

sub childs {
    my $self = shift;
    if (@_) {
        $self->{content} = shift;
    }
    return [] unless exists $self->{content};
    [ @{ $self->{content} } ];
}

sub dump {
    my $self   = shift;
    my $childs = $self->childs;
    my $res    = {};
    if ( scalar(@$childs) ) {
        $res->{childs} = [
            map {
                { ref( $_->{obj} ) => $_->{obj}->dump }
              } @$childs
        ];
    }
    if ( scalar( keys %{ $self->attrs } ) ) {
        $res->{attrs} = $self->attrs;
    }

    $res;

}
1;

package Soy::command_print;
use base 'Soy::base';
our $VERSION = '0.01';
1;

package Soy::raw_text;
use base 'Soy::base';
our $VERSION = '0.01';
1;

package Soy::command_elseif;
use base 'Soy::base';
use Data::Dumper;
use strict;
use warnings;
our $VERSION = '0.01';

sub dump {
    my $self = shift;
    return { %{ $self->SUPER::dump() },
        expression => $self->{expression}->dump };
}
1;

package Soy::command_call_self;
use base 'Soy::base';
use strict;
use warnings;
use Data::Dumper;
our $VERSION = '0.01';

sub dump {
    my $self = shift;
    my $res  = $self->SUPER::dump;
    $res->{template} = $self->{tmpl_name};
    $res;
}
1;

package Soy::command_call;
use Plosurin::SoyTree;
use base 'Soy::command_call_self';
use strict;
use warnings;
our $VERSION = '0.01';
1;

package Soy::command_else;
use base 'Soy::base';
use strict;
use warnings;
our $VERSION = '0.01';
1;

package Soy::command_if;
use base 'Soy::base';
use strict;
use warnings;
use v5.10;
use Data::Dumper;
our $VERSION = '0.01';

sub dump {
    my $self = shift;
    my %ifs  = ();
    $ifs{'if'} =
      { %{ $self->SUPER::dump }, expression => $self->{expression}->dump, };
    if ( exists $self->{commands_elseif} ) {
        my $elseifs = $self->{commands_elseif};
        $ifs{elseif} = [
            map {
                { ref($_) => $_->dump }
              } @$elseifs
        ];

    }
    if ( my $elseif = $self->{command_else} ) {

        $ifs{else} = { ref($elseif) => $elseif->dump() };
    }

    \%ifs;
}
1;

package Soy::command_param;
use base 'Soy::base';
use warnings;
use strict;
use Data::Dumper;
our $VERSION = '0.01';

sub as_perl5 {
    my $self = shift;

    #    my $ctx = shift;
    #die Dumper($self);
    #die $self->childs
    my $str = join ' . ', map { $_->as_perl5(@_) } @{ $self->childs };
    return qq!'$self->{name}' => $str!;
}

sub dump {
    my $self = shift;
    my %res = ( %{ $self->SUPER::dump() }, name => $self->{name}, );
    $res{value} = $self->{value} if exists $self->{value};
    \%res;
}

package Soy::command_param_self;
use base 'Soy::command_param';
our $VERSION = '0.01';
1;

package Soy::Node;
our $VERSION = '0.01';
use base 'Soy::base';

sub childs {
    [ $_[0]->{obj} ];
}

sub as_perl5 {
    my $self = shift;
    return $self->{obj}->as_perl5(@_);
}

package Soy::command_import;
use strict;
use warnings;
our $VERSION = '0.01';
use base 'Soy::base';
1;

# $VAR1 = bless( {
#                  'matchline' => 1,
#                  '' => '{foreach $i in [1..10]}ok{ifempty} oo{/foreach}',
#                  'command_foreach_ifempty' => bless( {
#                                                        'matchline' => 1,
#                                                        '' => '{ifempty} oo',
#                                                        'content' => [
#                                                                       bless( {
#                                                                                'matchline' => 1,
#                                                                                'obj' => bless( {
#                                                                                                  '' => ' oo'
#                                                                                                }, 'Soy::raw_text' ),
#                                                                                '' => ' oo',
#                                                                                'matchpos' => 34
#                                                                              }, 'Soy::Node' )
#                                                                     ],
#                                                        'matchpos' => 25
#                                                      }, 'Soy::command_foreach_ifempty' ),
#                  'expression' => bless( {
#                                           '' => '[1..10]'
#                                         }, 'Soy::expressiong' ),
#                  'content' => [
#                                 bless( {
#                                          'matchline' => 1,
#                                          'obj' => bless( {
#                                                            '' => 'ok'
#                                                          }, 'Soy::raw_text' ),
#                                          '' => 'ok',
#                                          'matchpos' => 23
#                                        }, 'Soy::Node' )
#                               ],
#                  'local_var' => bless( {
#                                          '' => '$i'
#                                        }, 'Soy::expressiong' ),
#                  'srcfile' => 'test'
#                }, 'Soy::command_foreach' );

package Soy::command_foreach;
use strict;
use warnings;
use base 'Soy::base';
our $VERSION = '0.01';

sub get_var_name {
    my $self = shift;
    my $name = $self->{local_var}->{''};
    $name =~ /\$(\w+)/ ? $1 : undef;
}

sub get_ifempty {
    my $self = shift;
    $self->{command_foreach_ifempty};
}

sub dump {
    my $self = shift;
    my %res  = (
        %{ $self->SUPER::dump() },

        #    expression => $self->{expression}
    );
    if ( exists $self->{command_foreach_ifempty} ) {
        my $ife = $self->{command_foreach_ifempty};
        $res{ifempty} = $ife->dump;

    }
    \%res;
}

package Soy::command_foreach_ifempty;
use strict;
use warnings;
use base 'Soy::base';
our $VERSION = '0.01';
1;

package Soy::expressiong;
use strict;
use warnings;
use Regexp::Grammars;
use Plosurin::Grammar;
use Plosurin::Utl::ExpMapVariables;
use Data::Dumper;
use base 'Soy::base';
our $VERSION = '0.02';


=head2 parse {map_of_variables}

    my $e = new Soy::Expresion('1+2');
    $e->parse({w=>"local_variable"});


=cut

sub parse {
    my $self            = shift;
    my $var_map         = shift;
    my $template_params = shift;
    my $txt             = $self->{''};
    my $q               = qr{
          <extends: Plosurin::Exp::Grammar>
        <nocontext:>
        <expr>
        }xms;
    if ( $txt =~ $q ) {
        my $tree = $/{expr};
        my $p    = new Plosurin::Utl::ExpMapVariables(
            vars   => $var_map,
            params => $template_params
        );
        $p->visit($tree);
        return $tree;
    }
    else { return "BAD" }
}


package Exp::base;
use Data::Dumper;
use base 'Soy::base';
our $VERSION = '0.01';

sub new {
    my $class = shift;
    bless( ( $#_ == 0 ) ? shift : {@_}, ref($class) || $class );
}

sub childs {
    my $self = shift;
    return [];
}

sub as_perl5 {
    my $self = shift;
    die "Method as_perl5 not implemented for " . ref($self);
}

package Exp::Var;
use strict;
use warnings;
use Data::Dumper;
use base 'Exp::base';
our $VERSION = '0.01';

sub as_perl5 {
    my $self = shift;
    return "\$$self->{Ident}";
}

package Exp::Digit;
use strict;
use warnings;
use Data::Dumper;
use base 'Exp::base';
our $VERSION = '0.01';

sub as_perl5 {
    my $self = shift;
    return $self->{''};
}

package Exp::add;
use strict;
use warnings;
use Data::Dumper;
use base 'Exp::base';
our $VERSION = '0.01';

sub as_perl5 {
    my $self = shift;
    return $self->{a}->as_perl5() . $self->{op} . $self->{b}->as_perl5();
}

sub childs {
    my $self = shift;
    return [ $self->{a}, $self->{b} ];
}

package Exp::mult;
use strict;
use warnings;
use Data::Dumper;
use base 'Exp::add';
our $VERSION = '0.01';
1;

package Exp::String;
use strict;
use warnings;
use Data::Dumper;
use base 'Exp::base';
our $VERSION = '0.01';

sub as_perl5 {
    my $self = shift;
    return "'$self->{value}'";
}

package Exp::list;
use strict;
use warnings;
use Data::Dumper;
use base 'Exp::base';
our $VERSION = '0.01';


sub childs {
    my $self = shift;
    if (@_) {
        $self->{expr} = \@_;
    }
    return $self->{expr};
}

sub as_perl5 {
    my $self = shift;
    return '[' . join( ",", map { $_->as_perl5() } @{ $self->childs } ) . "]";
}

package Plosurin::SoyTree;
use strict;
use warnings;
use v5.10;
use Data::Dumper;
use Plosurin::Grammar;
use Regexp::Grammars;
use version; our $VERSION = qv('0.0.1');

=head2 new

    my $st = new Plosurin::SoyTree(
            src => "txt",
            srcfile=>"filesrc",
            offset=>0
            );

=cut

sub new {
    my $class = shift;
    my $self = bless( ( $#_ == 0 ) ? shift : {@_}, ref($class) || $class );
    $self->{srcfile} //= "UNKNOWN";
    $self->{offset}  //= 0;
    if ( my $src = $self->{src} ) {
        unless ( $self->{_tree} = $self->parse($src) ) { return $self->{_tree} }
    }
    $self;
}

=head2  parse

return [node1, node2]

=cut

sub parse {
    my $self = shift;
    my $str  = shift || return [];
    my $q    = shift || qr{
          <extends: Plosurin::Grammar>
#    <debug:step>
        \A  <[content]>* \Z
        }xms;
    if ( $str =~ $q->with_actions( new Soy::Actions:: ) ) {
        my $raw_tree = {%/};

        #setup filename and offsets
        use Plosurin::Utl::SetLinePos;
        my $line_num_visiter = new Plosurin::Utl::SetLinePos::
          srcfile => $self->{srcfile},
          offset  => $self->{offset};
        $line_num_visiter->visit( $raw_tree->{content} );

        #check errors
        return $raw_tree;
    }
    else {
        "bad template";
    }
}

=head2 raw

return syntax tree

=cut

sub raw_tree {
    $_[0]->{_tree} || {};
}

=head2 reduce_tree

Union raw_text nodes

=cut

sub reduced_tree {
    my $self = shift;
    my $tree = shift || $self->raw_tree->{content} || return [];
    my @res  = ();
    my @tmp = @$tree;    #copy for protect from modify orig tree
    while ( my $node = shift @tmp ) {

        #skip first node
        #skip all non text nodes
        if ( ref( $node->{obj} ) ne 'Soy::raw_text' || scalar(@res) == 0 ) {
##            if ( my $sub_tree = $node->{obj}->childs ) {
##                $node->{obj}->childs( $self->reduced_tree($sub_tree) );
######                 $self->reduced_tree($sub_tree);
            #           }
            push @res, $node;
            next;
        }
        my $prev = pop @res;
        unless ( ref( $prev->{obj} ) eq 'Soy::raw_text' ) {
            push @res, $prev;
        }
        else {

            #now union !
            $node->{obj} = Soy::raw_text->new(
                { '' => $prev->{obj}->{''} . $node->{obj}->{''} } );
            $node->{matchline} = $prev->{matchline};
            $node->{matchpos}  = $node->{matchpos};
        }
        push @res, $node;
    }
    \@res;
}

=head2 dump_tree($obj1 [, $objn])

Minimalistic tree
return [ "clasname", {key1=>key2} ]

=cut

sub dump_tree {
    my $self = shift;
    my @res  = ();
    foreach my $rec ( @{ shift || [] } ) {
        my $obj = $rec->{obj};
        push @res, { ref($obj) => $obj->dump() };
    }
    \@res;
}
1;
__END__

=head1 SEE ALSO

Closure Templates Documentation L<http://code.google.com/closure/templates/docs/overview.html>

Perl 6 implementation L<https://github.com/zag/plosurin>


=head1 AUTHOR

Zahatski Aliaksandr, <[e-mail]>

=head1 COPYRIGHT AND LICENSE

Copyright (C) 2011 by Zahatski Aliaksandr

This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.

=cut