view release on metacpan or  search on metacpan

lib/HTML/Template/Compiled/Compiler.pm  view on Meta::CPAN

sub get_escapes    { $_[0]->[ATTR_ESCAPES] }
sub set_tags       { $_[0]->[ATTR_TAGS] = $_[1] }
sub add_tags       {
    for my $key (keys %{ $_[1] }) {
        $_[0]->[ATTR_TAGS]->{$key} = $_[1]->{$key};
    }
}
sub get_tags       { $_[0]->[ATTR_TAGS] }
sub set_name_re    { $_[0]->[ATTR_NAME_RE] = $_[1] }
sub get_name_re    { $_[0]->[ATTR_NAME_RE] }

our %ESCAPES;

sub delete_subs {
    # delete all userdefined subs
    %ESCAPES = ();
}

sub setup_escapes {
    my ($class, $plug_class, $escapes) = @_;
    for my $key (keys %$escapes) {
        my $def = $escapes->{$key};
        my $sub;
        if (ref $def eq 'HASH') {
            $sub = $def->{code};
            if (my $arguments = $def->{arguments} ) {
                $ESCAPES{ $plug_class }->{ $key }->{arguments} = $arguments;
            }
        }
        else {
            $sub = $def;
        }
        if (ref $sub eq 'CODE') {
            $ESCAPES{ $plug_class }->{ $key }->{code} = $sub;
        }
        else {
            $ESCAPES{ $plug_class }->{ $key }->{code} = \&{ $sub };
        }
    }
}

sub add_escapes {
    my ($self, $plug_class, $new_escapes) = @_;
    my $escapes = $self->get_escapes;
    for my $key (keys %$new_escapes) {
        $escapes->{ $key } = $plug_class;
    }
}

sub new {
    my $class = shift;
    my $self = [];
    bless $self, $class;
    $self->set_escapes({});
    return $self;
}

sub _escape_expression {
    my ( $self, $exp, $escape ) = @_;
    return $exp unless $escape;
    my @escapes = split m/\|/, uc $escape;
    my $escapes = $self->get_escapes();
    for (@escapes) {
        if ( $_ eq 'HTML' ) {
            $exp =
                _expr_function( 'HTML::Template::Compiled::Utils::escape_html',
                $exp, );
        }
        elsif ( $_ eq 'HTML_ALL' ) {
            $exp =
                _expr_function( 'HTML::Template::Compiled::Utils::escape_html_all',
                $exp, );
        }
        elsif ( $_ eq 'URL' ) {
            $exp =
                _expr_function( 'HTML::Template::Compiled::Utils::escape_uri',
                $exp, );
        }
        elsif ( $_ eq 'JS' ) {
            $exp =
                _expr_function( 'HTML::Template::Compiled::Utils::escape_js',
                $exp, );
        }
        elsif ( $_ eq 'IJSON' ) {
            $exp =
                _expr_function( 'HTML::Template::Compiled::Utils::escape_ijson',
                $exp, );
        }
        elsif ( $_ eq 'DUMP' ) {
            $exp = _expr_method( 'dump', _expr_literal('$t'), $exp, );
        }
        elsif (my $plug_class = $escapes->{$_}) {
            my $subref = "\$HTML::Template::Compiled::Compiler::ESCAPES\{'$plug_class'\}->\{'$_'\}->\{code\}";
            my @args = $exp;
            if (my $arguments = $ESCAPES{ $plug_class }->{ $_ }->{arguments}) {
                @args = ();
                for my $arg (@$arguments) {
                    if ($arg eq 'var') {
                        push @args, $exp;
                    }
                    elsif ($arg eq 'self') {
                        push @args, "\$t->get_plugin('$plug_class')";
                        #push @args, 23;
                    }
                }
            }
            $exp = HTML::Template::Compiled::Expression::SubrefCall->new( $subref, @args );
        }
    }
    return ref $exp ? $exp->to_string : $exp;
}

sub init_name_re {
    my ($self, %args) = @_;
    my $re = qr#
        \Q$args{deref}\E |
        \Q$args{method_call}\E |
        \Q$args{formatter_path}\E
        #x;
        $self->set_name_re($re);
}

lib/HTML/Template/Compiled/Compiler.pm  view on Meta::CPAN

            },
            $args{var},

        );
    }
    if ( grep { defined $_ && $args{var} eq $_ } @$lexicals ) {
        my $varstr = "\$HTML::Template::Compiled::_lexi_$args{var}";
        return $varstr;
    }
    my $lexi = join '|', grep defined, @$lexicals;
    my $varname = '$var';
    my $re = $self->get_name_re;
#    warn __PACKAGE__.':'.__LINE__.": re: $re\n";
    #warn __PACKAGE__.':'.__LINE__.": ========== ($args{var})\n";
    my $root         = 0;
    my $up_stack = 0;
    my $initial_var = '$$C';
    my $is_object_var = '$C_IS_OBJECT';
    my $root_hash = 0;
    my $OPT_INITIAL_VAR = $t->get_optimize->{initial_var};
    my $OPT_IS_OBJECT = $t->get_optimize->{object_check};
    my $OPT_ROOT_HASH = $t->get_optimize->{root_hash};
    my $use_initial_var = $OPT_INITIAL_VAR ? 1 : 0;
    if ( $t->get_loop_context && $args{var} =~ m/^__(\w+)__$/ ) {
        if (exists $loop_context{ lc $args{var} }) {
            my $lc = $loop_context{ lc $args{var} };
            return $lc;
        }
    }
    # explicitly use aliases with '$' at the beginning
    if (not $DISABLE_NEW_ALIAS and $args{var} =~ s/^\$(\w+)//) {
        $initial_var = "\$HTML::Template::Compiled::_lexi_$1";
        $is_object_var = '';
    }
    elsif ($lexi and $args{var} =~ s/^($lexi)($re)/$2/) {
        $initial_var = "\$HTML::Template::Compiled::_lexi_$1";
        $is_object_var = '';
    }
    elsif ( $args{var} =~ m/^_/ && $args{var} !~ m/^__(\w+)__$/ ) {
        $args{var} =~ s/^_//;
        $root = 0;
        $is_object_var = '';
    }
    elsif ( my @roots = $args{var} =~ m/\G($re)/gc) {
        #print STDERR "ROOTS: (@roots)\n";
        $root = 1 if @roots == 1;
        $args{var} =~ s/^($re)+//;
        if (@roots > 1) {
            croak "Cannot navigate up the stack" if !$t->get_global_vars & 2;
            $up_stack = $#roots;
            $initial_var = "\$t->get_globalstack->[-$up_stack]";
            $use_initial_var = 0;
            $is_object_var = '';
        }
        elsif (@roots == 1) {
            $initial_var = '$P';
            $is_object_var = '$P_IS_OBJECT';
            $root_hash = 1 if $OPT_ROOT_HASH;
        }
    }
    my @split = split m/(?=$re)/, $args{var};
    @split = map {
        my @ret;
        my $count = 0;
        if (s/#\z//) {
            $count = 1;
        }
        if ( m/(.*)\[(-?\d+)\]/ ) {
            my @slice = "[$2]";
            my $var = "$1";
            while ($var =~ s/\[(-?\d+)\]\z//) {
                unshift @slice, "[$1]";
            }
            @ret = ($var, @slice)
        }
        else {
            @ret = $_
        }
        push @ret, '#' if $count;
        @ret;
    } @split;
    my @paths;
    #print STDERR "paths: (@split)\n";
    my $count = 0;
    my $use_objects = $t->get_objects;
    my $strict = $use_objects eq 'strict' ? 1 : 0;
    my $method_args = '';
    my $varstr = '';
    @split = map {
        s#\\#\\\\#g;
        s#'#\\'#g;
        length $_ ? $_ : ()
    } @split;
    if (@split == 1) {
        $varname = $initial_var;
    }
    my $used_initial_var = 0;
    for my $i (0 .. $#split) {
        if ($i == $#split and defined $args{method_args}) {
            $method_args = $args{method_args};
        }
        my $around = ['', ''];
        if ($i == $#split and $ccontext eq 'list') {
            if ($context->get_name eq 'EACH') {
                $around = ['+{', '}'];
            }
            elsif ($context->get_name eq 'LOOP') {
                $around = ['[', ']'];
            }
        }
        my $p = $split[$i];
        #warn __PACKAGE__.':'.__LINE__.": path: $p\n";
        my $copy = $p;
        my $array_index;
        my $get_length;
        my $method_call;
        my $deref;
        my $formatter_call;
        my $guess;
        my $try_global;
        if ( $p =~ s/^\[(-?\d+)\]$/$1/ ) {