VMXTemplate/VMX/Template.pm

#!/usr/bin/perl
# Новая версия шаблонного движка VMX::Template!
# "Ох уж эти перлисты... что ни пишут - всё Template Toolkit получается!"

package VMX::Template;

use strict;
use VMX::Common qw(:all);
use Digest::MD5 qw(md5_hex);
use Hash::Merge;
use POSIX;

my $mtimes = {};            # время изменения файлов
my $uncompiled_code = {};   # нескомпилированный код
my $compiled_code = {};     # скомпилированный код (sub'ы)

# Конструктор
# $obj = new VMX::Template, %params
sub new
{
    my $class = shift;
    $class = ref ($class) || $class;
    my $self =
    {
        root            => '.',    # каталог с шаблонами
        reload          => 1,      # если 0, шаблоны не будут перечитываться с диска, и вызовов stat() происходить не будет
        wrapper         => undef,  # фильтр, вызываемый перед выдачей результата parse
        tpldata         => {},     # сюда будут сохранены: данные
        cache_dir       => undef,  # необязательный кэш, ускоряющий работу только в случае частых инициализаций интерпретатора
        use_utf8        => undef,  # шаблоны в UTF-8 и с флагом UTF-8
        begin_code      => '<!--', # начало кода
        end_code        => '-->',  # конец кода
        begin_subst     => '{',    # начало подстановки (необязательно)
        end_subst       => '}',    # конец подстановки (необязательно)
        strict_end      => 0,      # жёстко требовать имя блока в его завершающей инструкции (<!-- end block -->)
        @_,
    };
    $self->{cache_dir} =~ s!/*$!/!so if $self->{cache_dir};
    $self->{root} =~ s!/*$!/!so;
    bless $self, $class;
}

# Функция уничтожает данные шаблона
# $obj->clear()
sub clear
{
    %{ shift->{tpldata} } = ();
    return 1;
}

# Функция очищает кэш в памяти
sub clear_memory_cache
{
    my $self = shift;
    %$compiled_code = ();
    %$uncompiled_code = ();
    %$mtimes = ();
    return $self;
}

# Получить хеш для записи данных
sub vars
{
    my $self = shift;
    my ($vars) = @_;
    my $t = $self->{tpldata};
    $self->{tpldata} = $vars if $vars;
    return $t;
}

# Функция загружает, компилирует и возвращает результат для хэндла
# $page = $obj->parse( 'file/name.tpl' );
# Если имя файла - ссылка на скаляр, значит, это ссылка на код шаблона
# $page = $obj->parse( \ 'inlined template {CODE}' );
sub parse
{
    my $self = shift;
    my ($fn) = @_;
    my $textref;
    unless (ref $fn)
    {
        die __PACKAGE__.": empty filename '$fn'" unless length $fn;
        $fn = $self->{root}.$fn if $fn !~ m!^/!so;
        die __PACKAGE__.": couldn't load template file '$fn'"
            unless $textref = $self->loadfile($fn);
    }
    else
    {
        return $$fn unless $$fn;
        $textref = $fn;
        $fn = undef;
    }
    my $sub = $self->compile($textref, $fn);
    my $str = eval { &$sub($self) };
    die __PACKAGE__.": error running '$fn': $@" if $@;
    &{$self->{wrapper}}($str) if $self->{wrapper};
    return $str;
}

# Функция загружает файл с кэшированием
# $textref = $obj->loadfile($file)
sub loadfile
{
    my $self = shift;
    my ($fn) = @_;
    my $load = 0;
    my $mtime;
    if (!$uncompiled_code->{$fn} || $self->{reload})
    {
        $mtime = [ stat($fn) ] -> [ 9 ];
        $load = 1 if !$uncompiled_code->{$fn} || $mtime > $mtimes->{$fn};
    }
    if ($load)
    {
        # если файл изменился - перезасасываем
        my ($fd, $text);
        if (open $fd, "<", $fn)
        {
            local $/ = undef;
            $text = <$fd>;
            close $fd;
        }
        else
        {
            return undef;
        }
        # удаляем старый скомпилированный код
        delete $compiled_code->{$uncompiled_code->{$fn}}
            if $uncompiled_code->{$fn};
        $uncompiled_code->{$fn} = \$text;
        $mtimes->{$fn} = $mtime;
    }
    return $uncompiled_code->{$fn};
}

# Функция компилирует код.
# $sub = $self->compile(\$code, $fn);
# print &$sub($self);
sub compile
{
    my $self = shift;
    my ($coderef, $fn) = @_;
    return $compiled_code->{$coderef} if $compiled_code->{$coderef};

    # кэширование на диске
    my $h;
    if ($self->{cache_dir})
    {
        $h = $self->{cache_dir}.md5_hex($$coderef).'.pl';
        if (-e $h)
        {
            $compiled_code->{$coderef} = do $h;
            if ($@)
            {
                warn __PACKAGE__.": error compiling '$fn': [$@] in FILE: $h";
                unlink $h;
            }
            else
            {
                return $compiled_code->{$coderef};
            }
        }
    }

    my $code = $$coderef;
    Encode::_utf8_on($code) if $self->{use_utf8};

    # начала/концы спецстрок
    my $bc = $self->{begin_code} || '<!--';
    my $ec = $self->{end_code} || '-->';
    my @blk = ([ $bc, $ec, 'compile_code_fragment' ]);
    if ($self->{begin_subst} && $self->{end_subst})
    {
        push @blk, [ $self->{begin_subst}, $self->{end_subst}, 'compile_substitution' ];
    }
    for (@blk)
    {
        $_->[3] = length $_->[0];
        $_->[4] = length $_->[1];
    }

    # удаляем комментарии <!--# ... -->
    $code =~ s/\s*\Q$bc\E[ \t]*#.*?\Q$ec\E//gos;
    $code =~ s/(?:^|\n)[ \t\r]*(\Q$bc\E\s*[a-z]+(\s+.*)?\Q$ec\E)/$1/giso;

    $self->{blocks} = [];
    $self->{in} = [];
    $self->{included} = {};
    $self->{in_set} = 0;

    # ищем фрагменты кода - на регэкспах-то было не очень правильно, да и медленно!
    my ($r, $pp, $b, $i, $e, $f, $frag, @p) = ('', 0);
    while ($code && $pp < length $code)
    {
        @p = map { index $code, $_->[0], $pp } @blk;
        $b = undef;
        for $i (0..$#p)
        {
            # ближайшее найденное
            $b = $i if $p[$i] >= 0 && (!$b || $p[$i] < $p[$b]);
        }
        if (defined $b)
        {
            # это означает, что в случае отсутствия корректной инструкции
            # в найденной позиции надо пропустить ТОЛЬКО её начало и попробовать
            # найти что-нибудь снова!
            $pp = $p[$b]+$blk[$b][3];
            $e = index $code, $blk[$b][1], $pp;
            if ($e >= 0)
            {
                $frag = substr $code, $p[$b]+$blk[$b][3], $e-$p[$b]-$blk[$b][3];
                $f = $blk[$b][2];
                $frag = $self->$f($frag);
                if (defined $frag)
                {
                    # есть инструкция
                    $pp -= $blk[$b][3];
                    if ($pp > 0)
                    {
                        $pp = substr $code, 0, $pp, '';
                        $pp =~ s/([\\\'])/\\$1/gso;
                        $r .= "\$t.='$pp';\n";
                        $pp = 0;
                    }
                    $r .= $frag;
                    substr $code, 0, $e+$blk[$b][4]-$p[$b], '';
                }
            }
        }
        else
        {
            # финиш
            $code =~ s/([\\\'])/\\$1/gso;
            $r .= "\$t.='$code';\n";
            $code = '';
        }
    }

    # дописываем начало и конец кода
    $code = ($self->{use_utf8} ? "\nuse utf8;\n" : "").
'sub {
my $self = shift;
my $t = "";
' . $r . '
return $t;
}';
    undef $r;

    # кэшируем код на диск
    if ($h)
    {
        my $fd;
        if (open $fd, ">$h")
        {
            no warnings 'utf8';
            print $fd $code;
            close $fd;
        }
        else
        {
            warn __PACKAGE__.": error caching '$fn': $! while opening $h";
        }
    }

    # компилируем код
    $compiled_code->{$coderef} = eval $code;
    die __PACKAGE__.": error compiling '$fn': [$@] in CODE:\n$code" if $@;

    # возвращаем ссылку на процедуру
    return $compiled_code->{$coderef};
}

# компиляция фрагмента кода <!-- ... -->. это может быть:
# 1) [ELSE] IF выражение
# 2) BEGIN имя блока
#    FOR имя блока
# 3) END [имя блока]
# 4) SET переменная
# 5) SET переменная = выражение
# 6) INCLUDE имя_файла_шаблона
# 7) выражение
sub compile_code_fragment
{
    my $self = shift;
    my ($e) = @_;
    my $t;
    $e =~ s/^\s+//so;
    $e =~ s/\s+$//so;
    if ($e =~ /^(ELS(?:E\s*)?)?IF(!?)\s*/iso)
    {
        $t = $';
        if ($2)
        {
            warn "Legacy IF! used, consider changing it to IF NOT";
            $t = "NOT $t";
        }
        $t = $self->compile_expression($t);
        unless ($t)
        {
            warn "Invalid expression: ($t)";
            return undef;
        }
        push @{$self->{in}}, [ 'if' ] unless $1;
        return $1 ? "} elsif ($t) {\n" : "if ($t) {\n";
    }
    elsif ($e =~ /^ELSE\s*$/iso)
    {
        return "} else {";
    }
    elsif ($e =~ /^(?:BEGIN|FOR(?:EACH)?)\s+([a-z_][a-z0-9_]*)(?:\s+AT\s+(.+))?(?:\s+BY\s+(.+))?(?:\s+TO\s+(.+))?$/iso)
    {
        my $ref = $self->varref([@{$self->{blocks}}, $1]);
        my $at = 0;
        if ($2)
        {
            $at = $self->compile_expression($2);
            unless ($at)
            {
                warn "Invalid expression: ($2) in AT";
                return undef;
            }
        }
        my $by = '++';
        if ($3)
        {
            $by = $self->compile_expression($3);
            unless ($by)
            {
                warn "Invalid expression: ($3) in BY";
                return undef;
            }
            $by = '+=' . $by;
        }
        my $to = '';
        if ($4)
        {
            $to = $self->compile_expression($4);
            unless ($to)
            {
                warn "Invalid expression: ($4) in TO";
                return undef;
            }
            $to = "\$blk_${1}_count = $to if $to < \$blk_${1}_count;";
        }
        push @{$self->{blocks}}, $1;
        push @{$self->{in}}, [ 'begin', $1 ];
        return <<EOF;
my \$blk_${1}_count = ref($ref) && $ref =~ /ARRAY/so ? scalar \@{$ref} : $ref ? 1 : 0;
${to}
for (my \$blk_${1}_i = $at; \$blk_${1}_i < \$blk_${1}_count; \$blk_${1}_i $by) {
my \$blk_${1}_vars = ref($ref) && $ref =~ /ARRAY/so ? $ref ->[\$blk_${1}_i] : $ref;
EOF
    }
    elsif ($e =~ /^END(?:\s+([a-z_][a-z0-9_]*))?$/iso)
    {
        unless (@{$self->{in}})
        {
            warn "$& without BEGIN, IF or SET";
            return undef;
        }
        my $l = $self->{in}->[$#{$self->{in}}];
        if ($self->{strict_end} &&
            ($1 && ($l->[0] ne 'begin' || !$l->[1] || $l->[1] ne $1) ||
            !$1 && $l->[0] eq 'begin' && $l->[1]))
        {
            warn "$& after ".uc($l->[0])." $l->[1]";
            return undef;
        }
        $self->{in_set}-- if $l->[0] eq 'set';
        pop @{$self->{in}};
        pop @{$self->{blocks}} if $1;
        return $l->[0] eq 'set' ? "return \$t;\n};\n" : "} # $&\n";
    }
    elsif ($e =~ /^SET\s+((?:[a-z0-9_]+\.)*[a-z0-9_]+)(\s*=\s*)?/iso)
    {
        if ($2)
        {
            $t = $self->compile_expression($');
            unless ($t)
            {
                warn "Invalid expression: ($')";
                return undef;
            }
        }
        push @{$self->{in}}, [ 'set', $1 ];
        $self->{in_set}++;
        return $self->varref($1) . ' = ' . ($t || 'eval { my $t = ""') . ";\n";
    }
    elsif ($e =~ /^INCLUDE\s+(\S+)$/iso)
    {
        my $n = $1;
        $n =~ s/\'|\\/\\$&/gso;
        $t = "\$t .= \$self->parse('$n');\n";
        return $t;
    }
    else
    {
        $t = $self->compile_expression($e);
        return "\$t .= $t;\n" if $t;
    }
    return undef;
}

# компиляция подстановки переменной {...} это просто выражение
sub compile_substitution
{
    my $self = shift;
    my ($e) = @_;
    $e = $self->compile_expression($e);
    return undef unless $e;
    return "\$t .= $e;\n";
}

# компиляция выражения. это может быть:
# 1) "строковой литерал"
# 2) 123.123 или 0123 или 0x123
# 3) переменная
# 4) функция(выражение,выражение,...,выражение)
# 5) функция выражение
# 6) для legacy mode: переменная/имя_функции
sub compile_expression
{
    my $self = shift;
    my ($e, $after) = @_;
    $after = undef if $after && ref $after ne 'SCALAR';
    $$after = '' if $after;
    $e =~ s/^\s+//so;
    $e =~ s/\s+$//so unless $after;
    # строковой или числовой литерал
    if ($e =~ /^((\")(?:[^\"\\]+|\\.)*\"|\'(?:[^\'\\]+|\\.)*\'|-?[1-9]\d*(\.\d+)?|-?0\d*|-?0x\d+)\s*/iso)
    {
        if ($')
        {
            return undef unless $after;
            $$after = $';
        }
        $e = $1;
        $e =~ s/[\$\@\%]/\\$&/gso if $2;
        return $e;
    }
    # функция нескольких аргументов
    elsif ($e =~ /^([a-z_][a-z0-9_]*)\s*\(/iso)
    {
        my $f = lc $1;
        unless ($self->can("function_$f"))
        {
            warn "Unknown function: '$f'";
            return undef;
        }
        my $a = $';
        my @a;
        while ($e = $self->compile_expression($a, \$a))
        {
            push @a, $e;
            if ($a =~ /^\s*\)/so)
            {
                last;
            }
            elsif ($a !~ s/^\s*,//so)
            {
                warn "Unexpected token: '$a' in $f() parameter list";
                return undef;
            }
        }
        if ($a !~ s/^\s*\)\s*//so)
        {
            warn "Unexpected token: '$a' in the end of $f() parameter list";
            return undef;
        }
        if ($a)
        {
            return undef unless $after;
            $$after = $a;
        }
        $f = "function_$f";
        return $self->$f(@a);
    }
    # функция одного аргумента
    elsif ($e =~ /^([a-z_][a-z0-9_]*)\s+(?=\S)/iso)
    {
        my $f = lc $1;
        unless ($self->can("function_$f"))
        {
            warn "Unknown function: '$f'";
            return undef;
        }
        my $a = $';
        my $arg = $self->compile_expression($a, \$a);
        unless ($arg)
        {
            warn "Invalid expression: ($e)";
            return undef;
        }
        $a =~ s/^\s*//so;
        if ($a)
        {
            return undef unless $after;
            $$after = $a;
        }
        $f = "function_$f";
        return $self->$f($arg);
    }
    # переменная плюс legacy-mode переменная/функция
    elsif ($e =~ /^((?:[a-z0-9_]+\.)*(?:[a-z0-9_]+|\#))(?:\/([a-z]+))?\s*/iso)
    {
        if ($')
        {
            return undef unless $after;
            $$after = $';
        }
        $e = $self->varref($1);
        if ($2)
        {
            my $f = lc $2;
            unless ($self->can("function_$f"))
            {
                warn "Unknown function: '$f' called in legacy mode ($&)";
                return undef;
            }
            $f = "function_$f";
            $e = $self->$f($e);
        }
        return $e;
    }
    return undef;
}

# генерация ссылки на переменную
sub varref
{
    my $self = shift;
    return "" unless $_[0];
    my @e = ref $_[0] ? @{$_[0]} : split /\.+/, $_[0];
    $self->{last_varref_path} = join '.', @e;
    my $t = '$self->{tpldata}';
    EQBLOCK: {
    if (@{$self->{blocks}})
    {
        for (0..$#{$self->{blocks}})
        {
            last EQBLOCK unless $self->{blocks}->[$_] eq $e[$_];
        }
        splice @e, 0, @{$self->{blocks}};
        if (@e == 1 && $e[0] eq '#')
        {
            # номер итерации блока
            @e = ();
            $t = '$blk_'.$self->{blocks}->[$#{$self->{blocks}}].'_i';
        }
        else
        {
            # локальная переменная
            $t = '$blk_'.$self->{blocks}->[$#{$self->{blocks}}].'_vars';
        }
    }
    }
    for (@e)
    {
        if (/^\d+$/so)
        {
            $t .= "->[$_]";
        }
        else
        {
            s/\'|\\/\\$&/gso;
            $t .= "->{'$_'}";
        }
    }
    return $t;
}

# операция над аргументами
sub fmop
{
    my $op = shift;
    shift; # my $self = shift;
    return "((" . join(") $op (", @_) . "))";
}

# вызов функции с аргументами и раскрытием массивов
sub fearr
{
    my $f = shift;
    my $self = shift;
    my $e = shift;
    $e = "$f($e";
    $e .= ", ref($_) eq 'ARRAY' ? \@{$_} : ($_)" for @_;
    $e .= ")";
    return $e;
}

# функции
sub function_or      { fmop('||', @_) }
sub function_and     { fmop('&&', @_) }
sub function_add     { fmop('+', @_) }
sub function_sub     { fmop('-', @_) }
sub function_mul     { fmop('*', @_) }
sub function_div     { fmop('/', @_) }
sub function_concat  { fmop('.', @_) }
sub function_count   { "ref($_[1]) && $_[1] =~ /ARRAY/so ? scalar(\@{ $_[1] }) : 0" }
sub function_not     { "!($_[1])" }
sub function_even    { "!(($_[1]) & 1)" }
sub function_odd     { "(($_[1]) & 1)" }
sub function_int     { "int($_[1])" }
sub function_eq      { "(($_[1]) == ($_[2]))" }
sub function_gt      { "(($_[1]) > ($_[2]))" }
sub function_lt      { "(($_[1]) < ($_[2]))" }
sub function_ge      { "(($_[1]) >= ($_[2]))" }
sub function_le      { "(($_[1]) <= ($_[2]))" }
sub function_seq     { "(($_[1]) eq ($_[2]))" }
sub function_sgt     { "(($_[1]) gt ($_[2]))" }
sub function_slt     { "(($_[1]) lt ($_[2]))" }
sub function_sge     { "(($_[1]) ge ($_[2]))" }
sub function_sle     { "(($_[1]) le ($_[2]))" }
sub function_lc      { "lc($_[1])" }                    *function_lower = *function_lowercase = \&function_lc;
sub function_uc      { "uc($_[1])" }                    *function_upper = *function_uppercase = \&function_uc;
sub function_requote { "requote($_[1])" }               *function_re_quote = *function_preg_quote = \&function_requote;
sub function_split   { "split($_[1], $_[2], $_[3])" }
sub function_quote   { "quotequote($_[1])" }            *function_q = \&function_quote;
sub function_html    { "htmlspecialchars($_[1])" }      *function_s = \&function_html;
sub function_strip   { "strip_tags($_[1])" }            *function_t = \&function_strip;
sub function_h       { "strip_unsafe_tags($_[1])" }     *function_strip_unsafe = \&function_h;
# объединяет не просто скаляры, а также все элементы массивов
sub function_join    { fearr('join', @_) }              *function_implode = \&function_join;
# подставляет на места $1, $2 и т.п. в строке аргументы
sub function_subst   { fearr('exec_subst', @_) }
# sprintf
sub function_sprintf { fearr('sprintf', @_) }

# strftime
sub function_strftime
{
    my $self = shift;
    my $e = $_[1];
    $e = "($e).' '.($_[2])" if $_[2];
    $e = "POSIX::strftime($_[0], localtime(timestamp($e))";
    $e = "utf8on($e)" if $self->{use_utf8};
    return $e;
}

# выполняет подстановку function_subst
sub exec_subst
{
    my $str = shift;
    $str =~ s/(?<!\\)((?:\\\\)*)\$(?:([1-9]\d*)|\{([1-9]\d*)\})/$_[($2||$3)-1]/gisoe;
    return $str;
}

1;
__END__

=head1 Шаблонизатор VMX::Template

Данный модуль представляет собой новую версию VMX::Template, построенную на
некоторых новых идеях, ликвидировавшую безобразие и legacy-код, накопленный
в старой версии, однако сохранившую высокую производительность и простоту.

=head1 Идеи

Уйти от assign_vars(), assign_block_vars(). Передавать, как и в обычных движках,
просто хеш с данными $vars. Как, например, в Template::Toolkit. При этом
сохранить данные методы для совместимости.

Почистить синтаксис: ликвидировать "преобразования", "вложенный путь по
переменной" (->key->index->key->и т.п.), специальный синтаксис для окончания SET,
неочевидное обращение к счётчику block.#, tr_assign_* и т.п.

Переписать с нуля компилятор.

Добавить в употребление функции, но только самые необходимые.

Добавить обработку ошибок и диагностические сообщения.

=head1 Реализация

Путь к переменной теперь может включать в себя числа.

Вне BEGIN - {block} будет иметь значение ARRAY(0x...) т.е. массив всех
итераций блока block, а {block.0} будет иметь значение HASH(0x...), т.е.
первую итерацию блока block.

 <!-- BEGIN block -->

Внутри BEGIN - {block} будет иметь значение HASH(0x...), т.е. уже значение
текущей итерации блока block, а {block.#} будет иметь значением номер текущей
итерации {block.var}, считаемый с 0, а не с 1, как в старой версии.

 <!-- END block -->

На <!-- END другоеимя --> после <!-- BEGIN block --> ругнётся, ибо нефиг.
Если block в хеше данных - не массив, а хеш - значит, итерация у блока только
одна, и <!-- BEGIN block --> работает как for($long_expression) {} в Perl.

Операторов НЕТ, но есть функции.
Пример:

 <!-- IF OR(function(block.key1),AND(block.key2,block.key3)) -->

Синтаксис вызова функции нескольких аргументов:

 <!-- function(block.key, 0, "abc") -->

Подстановка:

 {function(block.key, 0, "abc")}

Синтаксис вызова функции одного аргумента:

 <!-- function(block.key) -->
 <!-- function block.key -->
 {block.key/L}
 {L block.key}

Условный вывод:

 <!-- IF function(block.key) --><!-- ELSEIF ... --><!-- END -->
 <!-- IF NOT block.key -->...<!-- END -->

Запись значения переменной:

 <!-- SET block.key -->...<!-- END -->

или

 <!-- SET block.key = выражение -->

=head1 Функции

=head2 OR, AND, NOT

Логические ИЛИ, И, НЕ, действующие аналогично Perl операторам || && !.

=head2 EVEN, ODD

Истина в случае, если аргумент чётный или нечётный соответственно.

=head2 INT, ADD, MUL, DIV, MOD

Преобразование к целому числу и арифметические операции.

=head2 EQ, SEQ, GT, LT, GE, LE, SGT, SLT, SGE, SLE

Действуют аналогично Perl операторам == eq > < >= <= gt lt ge le.

=head2 CONCAT, JOIN, SPLIT, COUNT

Конкатенация всех своих аргументов - concat(аргументы).

Конкатенация элементов массива через разделитель - join(строка,аргументы).
Причём если какие-то аргументы - массивы, конкатенирует все их элементы,
а не их самих.

Разделение строки по регулярному выражению и лимиту - split(РЭ,аргумент,лимит).
Лимит необязателен. (см. perldoc -f split)

Количество элементов в массиве или 0 если не массив - count(аргумент).

=head2 LC=LOWER=LOWERCASE, UC=UPPER=UPPERCASE

Нижний и верхний регистр.

=head2 L=TRANSLATE, LZ=TRANSLATE_NULL

Контекстный перевод и он же либо пустое значение.

=head2 S=HTML, T=STRIP, H=STRIP_UNSAFE

Преобразование символов < > & " ' в HTML-сущности,

Удаление всех тегов,

Удаление запрещённых тегов.

=head2 Q=QUOTE, REQUOTE=RE_QUOTE=PREG_QUOTE

Экранирование символов " ' \

А также экранирование символов, являющихся специальными в регулярных выражениях (см. perldoc perlre).

=cut