2007-05-21 03:34:53 +04:00
|
|
|
|
#!/usr/bin/perl
|
|
|
|
|
|
2007-06-02 02:30:09 +04:00
|
|
|
|
=head1 Простой шаблонный движок.
|
2008-08-15 21:31:24 +04:00
|
|
|
|
Когда-то inspired by phpBB templates, которые в свою очередь inspired by
|
|
|
|
|
phplib templates. Однако уже далеко ушедши от них обоих.
|
2007-05-21 03:34:53 +04:00
|
|
|
|
=cut
|
|
|
|
|
|
|
|
|
|
package VMX::Template;
|
|
|
|
|
|
|
|
|
|
use strict;
|
|
|
|
|
use VMX::Common qw(:all);
|
|
|
|
|
use Digest::MD5 qw(md5_hex);
|
2008-08-15 21:31:24 +04:00
|
|
|
|
use Hash::Merge;
|
2007-05-21 03:34:53 +04:00
|
|
|
|
|
2007-10-28 19:16:50 +03:00
|
|
|
|
# ускорение быстродействия постоянными stat-ами
|
|
|
|
|
my $mtimes = {};
|
|
|
|
|
my $uncompiled_code = {};
|
2007-11-07 03:12:06 +03:00
|
|
|
|
my $langhashes = {};
|
2007-10-28 19:16:50 +03:00
|
|
|
|
|
2007-05-21 03:34:53 +04:00
|
|
|
|
##
|
|
|
|
|
# Конструктор
|
|
|
|
|
# $obj = new VMX::Template, %init
|
|
|
|
|
##
|
2008-08-15 21:31:24 +04:00
|
|
|
|
sub new
|
|
|
|
|
{
|
2007-05-21 03:34:53 +04:00
|
|
|
|
my $class = shift;
|
|
|
|
|
$class = ref ($class) || $class;
|
2008-08-15 21:31:24 +04:00
|
|
|
|
my $self =
|
|
|
|
|
{
|
|
|
|
|
conv =>
|
|
|
|
|
{
|
|
|
|
|
# char => func_name | \&sub_ref
|
|
|
|
|
'<' => 'strip_tags',
|
|
|
|
|
'i' => 'int',
|
|
|
|
|
's' => 'htmlspecialchars',
|
|
|
|
|
'l' => 'lc',
|
|
|
|
|
'u' => 'uc',
|
|
|
|
|
'q' => 'quotequote',
|
|
|
|
|
'L' => \&language_ref,
|
|
|
|
|
},
|
2007-10-27 23:44:31 +04:00
|
|
|
|
root => '.', # каталог с шаблонами
|
|
|
|
|
cachedir => undef, # расположение кэша на диске
|
2007-10-28 19:16:50 +03:00
|
|
|
|
wrapper => undef, # фильтр, вызываемый перед выдачей результата parse
|
2007-10-27 23:44:31 +04:00
|
|
|
|
_tpldata => {}, # сюда будут сохранены: данные
|
|
|
|
|
lang => {}, # ~ : языковые данные
|
|
|
|
|
files => {}, # ~ : имена файлов
|
2007-10-28 19:16:50 +03:00
|
|
|
|
package_names => {}, # ~ : последние названия пакетов шаблонов
|
2007-10-27 23:44:31 +04:00
|
|
|
|
_tpldata_stack => [], # стек tpldata-ы для datapush и datapop
|
|
|
|
|
@_
|
|
|
|
|
};
|
|
|
|
|
bless $self, $class;
|
2007-05-21 03:34:53 +04:00
|
|
|
|
}
|
|
|
|
|
|
|
|
|
|
##
|
|
|
|
|
# Функция задаёт имена файлов для хэндлов
|
|
|
|
|
# $obj->set_filenames (handle1 => 'template1.tpl', handle2 => 'template2.tpl', ...)
|
|
|
|
|
##
|
2008-08-15 21:31:24 +04:00
|
|
|
|
sub set_filenames
|
|
|
|
|
{
|
2007-05-21 03:34:53 +04:00
|
|
|
|
my $self = shift;
|
|
|
|
|
my %fns = @_;
|
2008-08-15 21:31:24 +04:00
|
|
|
|
while (my ($k,$v) = each(%fns))
|
|
|
|
|
{
|
|
|
|
|
$self->{fnames}->{$k} = $v;
|
|
|
|
|
$self->{files}->{$k} = $self->make_filename($v);
|
2007-05-21 03:34:53 +04:00
|
|
|
|
}
|
|
|
|
|
return 1;
|
|
|
|
|
}
|
|
|
|
|
|
2007-09-11 02:46:55 +04:00
|
|
|
|
##
|
|
|
|
|
# Функция загружает файлы переводов (внутри хеши)
|
|
|
|
|
# $obj->load_lang ($filename, $filename, ...);
|
|
|
|
|
##
|
2008-08-15 21:31:24 +04:00
|
|
|
|
sub load_lang
|
|
|
|
|
{
|
2007-09-11 02:46:55 +04:00
|
|
|
|
my $self = shift;
|
2007-11-07 03:12:06 +03:00
|
|
|
|
return $self->load_lang_hashes(map {
|
|
|
|
|
my $mtime = [stat($_)]->[9];
|
2008-08-15 21:31:24 +04:00
|
|
|
|
if (!defined($mtimes->{$_}) || $mtime > $mtimes->{$_})
|
|
|
|
|
{
|
2007-11-07 03:12:06 +03:00
|
|
|
|
$mtimes->{$_} = $mtime;
|
2008-08-15 21:31:24 +04:00
|
|
|
|
$langhashes->{$_} = do($_);
|
2007-11-07 03:12:06 +03:00
|
|
|
|
}
|
2008-08-15 21:31:24 +04:00
|
|
|
|
$langhashes->{$_};
|
2007-11-07 03:12:06 +03:00
|
|
|
|
} @_);
|
2007-09-12 00:56:37 +04:00
|
|
|
|
}
|
|
|
|
|
|
|
|
|
|
##
|
|
|
|
|
# Функция загружает хеши переводов
|
|
|
|
|
# $obj->load_lang_hashes ($hash, $hash, ...);
|
|
|
|
|
##
|
2008-08-15 21:31:24 +04:00
|
|
|
|
sub load_lang_hashes
|
|
|
|
|
{
|
2007-09-12 00:56:37 +04:00
|
|
|
|
my $self = shift;
|
2007-09-11 02:46:55 +04:00
|
|
|
|
my $i = 0;
|
2008-08-15 21:31:24 +04:00
|
|
|
|
Hash::Merge::set_behavior('RIGHT_PRECEDENT');
|
|
|
|
|
$self->{lang} = Hash::Merge::merge ($self->{lang}, $_) foreach @_;
|
2007-09-11 02:46:55 +04:00
|
|
|
|
return $i;
|
|
|
|
|
}
|
|
|
|
|
|
2007-05-21 03:34:53 +04:00
|
|
|
|
##
|
|
|
|
|
# Функция преобразовывает относительные имена файлов в абсолютные
|
|
|
|
|
# $obj->make_filename ($filename)
|
|
|
|
|
##
|
2008-08-15 21:31:24 +04:00
|
|
|
|
sub make_filename
|
|
|
|
|
{
|
2007-05-21 03:34:53 +04:00
|
|
|
|
my $self = shift;
|
2007-06-02 02:30:09 +04:00
|
|
|
|
my ($fn) = @_;
|
2008-08-15 21:31:24 +04:00
|
|
|
|
$fn = $self->{root}.'/'.$fn if $fn !~ /^\//iso;
|
|
|
|
|
die("Template->make_filename(): file $fn does not exist") unless -f $fn;
|
2007-05-21 03:34:53 +04:00
|
|
|
|
return $fn;
|
|
|
|
|
}
|
|
|
|
|
|
|
|
|
|
##
|
|
|
|
|
# Функция уничтожает данные шаблона
|
|
|
|
|
# $obj->destroy ()
|
|
|
|
|
##
|
2008-08-15 21:31:24 +04:00
|
|
|
|
sub destroy
|
|
|
|
|
{
|
2007-05-21 03:34:53 +04:00
|
|
|
|
shift->{_tpldata} = {};
|
|
|
|
|
return 1;
|
|
|
|
|
}
|
|
|
|
|
|
|
|
|
|
##
|
|
|
|
|
# Функция сохраняет текущие данные шаблона в стек и уничтожает их
|
|
|
|
|
# $obj->datapush ()
|
|
|
|
|
##
|
2008-08-15 21:31:24 +04:00
|
|
|
|
sub datapush
|
|
|
|
|
{
|
2007-05-21 03:34:53 +04:00
|
|
|
|
my $self = shift;
|
|
|
|
|
push (@{$self->{_tpldata_stack}}, \$self->{_tpldata});
|
|
|
|
|
destroy $self;
|
|
|
|
|
return 1;
|
|
|
|
|
}
|
|
|
|
|
|
|
|
|
|
##
|
|
|
|
|
# Функция восстанавливает данные шаблона из стека
|
|
|
|
|
# $obj->datapop ()
|
|
|
|
|
##
|
2008-08-15 21:31:24 +04:00
|
|
|
|
sub datapop
|
|
|
|
|
{
|
2007-05-21 03:34:53 +04:00
|
|
|
|
my $self = shift;
|
|
|
|
|
return 0 if (@{$self->{_tpldata_stack}} <= 0);
|
|
|
|
|
$self->{_tpldata} = pop @{$self->{_tpldata_stack}};
|
|
|
|
|
return 1;
|
|
|
|
|
}
|
|
|
|
|
|
|
|
|
|
##
|
|
|
|
|
# Функция загружает, компилирует и возвращает результат для хэндла
|
|
|
|
|
# $obj->parse ('handle')
|
|
|
|
|
##
|
2008-08-15 21:31:24 +04:00
|
|
|
|
sub parse
|
|
|
|
|
{
|
2007-06-02 02:30:09 +04:00
|
|
|
|
my $self = shift;
|
2007-05-21 03:34:53 +04:00
|
|
|
|
my $handle = shift;
|
2007-10-28 19:16:50 +03:00
|
|
|
|
die("[Template] couldn't load template file for handle $handle")
|
|
|
|
|
unless $self->loadfile($handle);
|
|
|
|
|
$self->compile($handle);
|
|
|
|
|
my $str = eval($self->{package_names}->{$handle} . '::parse($self)');
|
|
|
|
|
die("[Template] error parsing $handle: $@") if $@;
|
2007-06-02 02:30:09 +04:00
|
|
|
|
$str = &$self->{wrapper} ($str) if $self->{wrapper};
|
|
|
|
|
return $str;
|
2007-05-21 03:34:53 +04:00
|
|
|
|
}
|
|
|
|
|
|
|
|
|
|
##
|
|
|
|
|
# Функция присваивает переменные блока в новую итерацию
|
|
|
|
|
# $obj->assign_block_vars ($block, varname1 => value1, varname2 => value2, ...)
|
|
|
|
|
##
|
2008-08-15 21:31:24 +04:00
|
|
|
|
sub assign_block_vars
|
|
|
|
|
{
|
2007-05-21 03:34:53 +04:00
|
|
|
|
my $self = shift;
|
|
|
|
|
my $block = shift;
|
|
|
|
|
my $vararray = { @_ };
|
2008-03-03 14:29:35 +03:00
|
|
|
|
|
|
|
|
|
$block =~ s/^\.+//so;
|
|
|
|
|
$block =~ s/\.+$//so;
|
2007-05-21 03:34:53 +04:00
|
|
|
|
|
2008-08-15 21:31:24 +04:00
|
|
|
|
if (!$block)
|
|
|
|
|
{
|
|
|
|
|
# если не блок, а корневой уровень
|
2007-05-21 03:34:53 +04:00
|
|
|
|
$self->assign_vars (@_);
|
2008-08-15 21:31:24 +04:00
|
|
|
|
}
|
|
|
|
|
elsif ($block !~ /\.[^\.]/)
|
|
|
|
|
{
|
|
|
|
|
# если блок, но не вложенный
|
2007-05-21 03:34:53 +04:00
|
|
|
|
$block =~ s/\.*$/./; # добавляем . в конец, если надо
|
|
|
|
|
$self->{_tpldata}{$block} = [] unless $self->{_tpldata}{$block};
|
|
|
|
|
push @{$self->{_tpldata}{$block}}, $vararray;
|
2008-08-15 21:31:24 +04:00
|
|
|
|
}
|
|
|
|
|
else
|
|
|
|
|
{
|
|
|
|
|
# если вложенный блок
|
2007-05-21 03:34:53 +04:00
|
|
|
|
my $ev = '$self->{_tpldata}';
|
|
|
|
|
$block =~ s/\.+$//; # обрезаем точки в конце (хоть их 10 там)
|
|
|
|
|
my @blocks = split /\./, $block;
|
|
|
|
|
my $lastblock = pop @blocks;
|
2008-08-15 21:31:24 +04:00
|
|
|
|
foreach (@blocks)
|
|
|
|
|
{
|
2007-05-21 03:34:53 +04:00
|
|
|
|
$ev .= "{'$_.'}";
|
2007-05-30 20:02:10 +04:00
|
|
|
|
$ev .= "[-1+\@\{$ev\}]";
|
2007-05-21 03:34:53 +04:00
|
|
|
|
}
|
|
|
|
|
$ev .= "{'$lastblock.'}";
|
|
|
|
|
$ev = "$ev = [] unless $ev; push \@\{$ev\}, \$vararray;";
|
|
|
|
|
eval ($ev);
|
|
|
|
|
}
|
|
|
|
|
|
|
|
|
|
return 1;
|
|
|
|
|
}
|
|
|
|
|
|
|
|
|
|
##
|
|
|
|
|
# Функция добавляет переменные к текущей итерации блока
|
|
|
|
|
# $obj->append_block_vars ($block, varname1 => value1, varname2 => value2, ...)
|
|
|
|
|
##
|
2008-08-15 21:31:24 +04:00
|
|
|
|
sub append_block_vars
|
|
|
|
|
{
|
2007-05-21 03:34:53 +04:00
|
|
|
|
my $self = shift;
|
|
|
|
|
my $block = shift;
|
|
|
|
|
my %vararray = @_;
|
|
|
|
|
my $lastit;
|
|
|
|
|
|
2008-08-15 21:31:24 +04:00
|
|
|
|
if (!$block || $block eq '.')
|
|
|
|
|
{
|
|
|
|
|
# если не блок, а корневой уровень
|
2007-05-21 03:34:53 +04:00
|
|
|
|
$self->assign_vars (@_);
|
2008-08-15 21:31:24 +04:00
|
|
|
|
}
|
|
|
|
|
elsif ($block !~ /\../)
|
|
|
|
|
{
|
|
|
|
|
# если блок, но не вложенный
|
2007-05-21 03:34:53 +04:00
|
|
|
|
$block =~ s/\.*$/./; # добавляем . в конец, если надо
|
2007-06-02 02:30:09 +04:00
|
|
|
|
$lastit = @{$self->{_tpldata}{$block}} - 1;
|
2008-08-15 21:31:24 +04:00
|
|
|
|
$self->{_tpldata}{$block}[$lastit]{$_} = $vararray{$_}
|
|
|
|
|
foreach keys %vararray;
|
|
|
|
|
}
|
|
|
|
|
else
|
|
|
|
|
{
|
|
|
|
|
# если вложенный блок
|
2007-05-21 03:34:53 +04:00
|
|
|
|
my $ev = '$self->{_tpldata}';
|
|
|
|
|
$block =~ s/\.+$//; # обрезаем точки в конце (хоть их 10 там)
|
|
|
|
|
my @blocks = split /\.+/, $block;
|
2008-08-15 21:31:24 +04:00
|
|
|
|
foreach (@blocks)
|
|
|
|
|
{
|
2007-05-21 03:34:53 +04:00
|
|
|
|
$ev .= "{'$_.'}";
|
2007-05-30 20:02:10 +04:00
|
|
|
|
$ev .= "[-1+\@\{$ev\}]";
|
2007-05-21 03:34:53 +04:00
|
|
|
|
}
|
|
|
|
|
$ev = "\$ev{\$k} = \$vararray{\$k} foreach \$k (keys \%vararray);";
|
|
|
|
|
eval ($ev);
|
|
|
|
|
}
|
|
|
|
|
|
|
|
|
|
return 1;
|
|
|
|
|
}
|
|
|
|
|
|
|
|
|
|
##
|
|
|
|
|
# Функция присваивает переменные корневого уровня
|
|
|
|
|
# $obj->assign_vars (varname1 => value1, varname2 => value2, ...)
|
|
|
|
|
##
|
2008-08-15 21:31:24 +04:00
|
|
|
|
sub assign_vars
|
|
|
|
|
{
|
2007-05-21 03:34:53 +04:00
|
|
|
|
my $self = shift;
|
|
|
|
|
$self->{_tpldata}{'.'}[0] = {} unless $self->{_tpldata}{'.'}[0];
|
|
|
|
|
%{$self->{_tpldata}{'.'}[0]} = (%{$self->{_tpldata}{'.'}[0]}, @_);
|
|
|
|
|
return 1;
|
|
|
|
|
}
|
|
|
|
|
|
|
|
|
|
##
|
|
|
|
|
# Функция загружает файл для хэндла HANDLE
|
|
|
|
|
# $obj->loadfile ($handle)
|
|
|
|
|
##
|
2008-08-15 21:31:24 +04:00
|
|
|
|
sub loadfile
|
|
|
|
|
{
|
2007-06-02 02:30:09 +04:00
|
|
|
|
my $self = shift;
|
|
|
|
|
my ($handle) = @_;
|
2007-10-28 19:16:50 +03:00
|
|
|
|
die("[Template] no file specified for handle $handle")
|
|
|
|
|
unless defined $self->{files}->{$handle};
|
2007-05-21 03:34:53 +04:00
|
|
|
|
|
|
|
|
|
# если оно false, но задано, значит, код задан, минуя файлы
|
2007-10-28 19:16:50 +03:00
|
|
|
|
my $fn;
|
|
|
|
|
if ($fn = $self->{files}{$handle})
|
2007-05-21 03:34:53 +04:00
|
|
|
|
{
|
2007-10-28 19:16:50 +03:00
|
|
|
|
my $mtime = [stat($fn)] -> [9];
|
|
|
|
|
return 1 if
|
|
|
|
|
$uncompiled_code->{$fn} &&
|
|
|
|
|
$mtimes->{$fn} >= $mtime;
|
2007-05-21 03:34:53 +04:00
|
|
|
|
my $filepath;
|
|
|
|
|
|
2007-10-28 19:16:50 +03:00
|
|
|
|
$filepath = $` if $fn =~ m%(?<=/)[^/]*$%;
|
|
|
|
|
my $cnt = file_get_contents ($fn);
|
|
|
|
|
die("[Template] file for handle $handle is empty") unless $cnt;
|
2007-05-21 03:34:53 +04:00
|
|
|
|
|
2007-10-28 19:16:50 +03:00
|
|
|
|
$uncompiled_code->{$fn} = $cnt;
|
|
|
|
|
$mtimes->{$fn} = $mtime;
|
2007-05-21 03:34:53 +04:00
|
|
|
|
}
|
|
|
|
|
|
|
|
|
|
return 1;
|
|
|
|
|
}
|
|
|
|
|
|
|
|
|
|
##
|
|
|
|
|
# Функция компилирует код
|
2007-10-28 19:16:50 +03:00
|
|
|
|
# # ref($self) == 'VMX::Template'
|
|
|
|
|
# $pkg_name = $self->compile ($handle)
|
|
|
|
|
# print eval($pkg_name.'::parse($self)');
|
2007-05-21 03:34:53 +04:00
|
|
|
|
##
|
2008-08-15 21:31:24 +04:00
|
|
|
|
sub compile
|
|
|
|
|
{
|
2007-10-28 19:16:50 +03:00
|
|
|
|
my $self = shift;
|
|
|
|
|
my ($handle) = @_;
|
|
|
|
|
my $code = $uncompiled_code->{$self->{files}->{$handle}};
|
2007-05-21 03:34:53 +04:00
|
|
|
|
|
2008-08-15 21:31:24 +04:00
|
|
|
|
$self->{cur_template_path} = $self->{cur_template} = '';
|
|
|
|
|
if ($self->{fnames}->{$handle})
|
|
|
|
|
{
|
|
|
|
|
$self->{cur_template} = $self->{fnames}->{$handle};
|
|
|
|
|
$self->{cur_template} =~ s/\.[^\.]+$//iso;
|
|
|
|
|
$self->{cur_template} =~ s/:+//gso;
|
|
|
|
|
$self->{cur_template} =~ s!/+!:!gso;
|
|
|
|
|
$self->{cur_template} =~ s/[^\w_:]+//gso;
|
|
|
|
|
$self->{cur_template_path} = "->{\"" . join("\"}->{\"",
|
|
|
|
|
map { lc } split /:/, $self->{cur_template}) . "\"}";
|
|
|
|
|
}
|
|
|
|
|
|
2007-10-28 19:16:50 +03:00
|
|
|
|
my $nesting = 0;
|
|
|
|
|
my $included = {};
|
2007-05-21 03:34:53 +04:00
|
|
|
|
my @code_lines = ();
|
|
|
|
|
my @block_names = ('.');
|
|
|
|
|
my ($cbstart, $cbcount, $cbplus, $mm);
|
|
|
|
|
|
2007-10-28 19:16:50 +03:00
|
|
|
|
my ($PN, $sfile);
|
|
|
|
|
$sfile = $PN = 'Tpl' . uc(md5_hex($code));
|
|
|
|
|
$PN = __PACKAGE__.'::'.$PN;
|
|
|
|
|
# а может быть, кэшировано в памяти? (т.е модуль уже загружен)
|
2008-08-15 21:31:24 +04:00
|
|
|
|
if (eval('return $'.$PN.'::{parse}'))
|
|
|
|
|
{
|
2007-10-28 19:16:50 +03:00
|
|
|
|
goto _end;
|
|
|
|
|
}
|
2008-02-13 18:10:23 +03:00
|
|
|
|
|
2007-10-28 19:16:50 +03:00
|
|
|
|
# а может быть, кэшировано на диске?
|
2008-08-15 21:31:24 +04:00
|
|
|
|
if ($self->{cachedir})
|
|
|
|
|
{
|
2007-05-21 03:34:53 +04:00
|
|
|
|
$self->{cachedir} .= '/' if (substr($self->{cachedir},-1,1) ne '/');
|
2007-10-28 19:16:50 +03:00
|
|
|
|
$sfile = $self->{cachedir} . $sfile . '.pm';
|
2008-08-15 21:31:24 +04:00
|
|
|
|
if (-e $sfile)
|
|
|
|
|
{
|
2007-10-28 19:16:50 +03:00
|
|
|
|
do $sfile;
|
2008-08-15 21:31:24 +04:00
|
|
|
|
if ($@)
|
|
|
|
|
{
|
2007-10-28 19:16:50 +03:00
|
|
|
|
warn $@;
|
2008-08-15 21:31:24 +04:00
|
|
|
|
}
|
|
|
|
|
else
|
|
|
|
|
{
|
2007-10-28 19:16:50 +03:00
|
|
|
|
goto _end;
|
|
|
|
|
}
|
|
|
|
|
}
|
2007-05-21 03:34:53 +04:00
|
|
|
|
}
|
|
|
|
|
|
|
|
|
|
# комментарии <!--# ... #-->
|
|
|
|
|
$code =~ s/\s*<!--#.*?#-->//gos;
|
|
|
|
|
|
2008-03-03 14:29:35 +03:00
|
|
|
|
$code =~ s/(?:^|\n)\s*(<!--\s*(?:BEGIN|END|IF!?|ELSE|INCLUDE|SET|ENDSET)\s+.*?-->)\s*(?:$|\n)/\x01$1\x01\n/gos;
|
2008-09-02 00:19:55 +04:00
|
|
|
|
# форматирование кода для красоты
|
2008-03-03 14:29:35 +03:00
|
|
|
|
1 while $code =~ s/(?<!\x01)<!--\s*(?:BEGIN|END|IF!?|ELSE|INCLUDE|SET|ENDSET)\s+.*?-->/\x01$&/gom;
|
|
|
|
|
1 while $code =~ s/<!--\s*(?:BEGIN|END|IF!?|ELSE|INCLUDE|SET|ENDSET)\s+.*?-->(?!\x01)/$&\x01/gom;
|
2008-02-13 18:10:23 +03:00
|
|
|
|
|
2007-05-21 03:34:53 +04:00
|
|
|
|
# ' и \ -> \' и \\
|
|
|
|
|
$code =~ s/\'|\\/\\$&/gos;
|
|
|
|
|
|
2008-02-13 18:10:23 +03:00
|
|
|
|
# "первая замена"
|
|
|
|
|
$code =~
|
|
|
|
|
s%
|
|
|
|
|
(?>\%+) |
|
|
|
|
|
(?>\%+)\s*\S+.*?(?>\%+) |
|
2008-03-03 03:33:05 +03:00
|
|
|
|
\{[a-z0-9\-_]+\.\#\} |
|
2008-09-02 00:19:55 +04:00
|
|
|
|
\{((?:[a-z0-9\-_]+\.)*)([a-z0-9\-_]+)((?:->[a-z0-9\-_]+)*)(?:\/([a-z0-9\-_]+))?\}
|
|
|
|
|
% $self->generate_xx_ref($&,$1,$2,$3,$4)
|
2008-02-13 18:10:23 +03:00
|
|
|
|
%goisex;
|
2007-09-11 02:46:55 +04:00
|
|
|
|
|
2007-05-21 03:34:53 +04:00
|
|
|
|
# \n -> \n\x01
|
|
|
|
|
$code =~ s/\n/\n\x01/gos;
|
|
|
|
|
|
|
|
|
|
# разбиваем код на строки
|
|
|
|
|
@code_lines = split /\x01/, $code;
|
2008-08-15 21:31:24 +04:00
|
|
|
|
foreach (@code_lines)
|
|
|
|
|
{
|
2007-05-21 03:34:53 +04:00
|
|
|
|
next unless $_;
|
2008-09-02 00:19:55 +04:00
|
|
|
|
if (/^\s*<!--\s*BEGIN\s+([a-z0-9\-_]+?)\s+([a-z \t\-_0-9]*)-->\s*$/iso)
|
2008-08-15 21:31:24 +04:00
|
|
|
|
{
|
|
|
|
|
# начало блока
|
2007-05-21 03:34:53 +04:00
|
|
|
|
$nesting++;
|
|
|
|
|
$block_names[$nesting] = $1;
|
2008-08-15 21:31:24 +04:00
|
|
|
|
$self->{current_namespace} = join '.', @block_names;
|
2007-05-21 03:34:53 +04:00
|
|
|
|
$cbstart = 0; $cbcount = ''; $cbplus = '++';
|
|
|
|
|
|
|
|
|
|
{
|
|
|
|
|
my $o2 = $2;
|
2008-08-15 21:31:24 +04:00
|
|
|
|
if ($o2 =~ /^[ \t]*AT ([0-9]+)[ \t]*(?:([0-9]+)[ \t]*)?$/)
|
|
|
|
|
{
|
2007-05-21 03:34:53 +04:00
|
|
|
|
$cbstart = $1;
|
|
|
|
|
$cbcount = $2 ? $1+$2 : 0;
|
2008-08-15 21:31:24 +04:00
|
|
|
|
}
|
|
|
|
|
elsif ($o2 =~ /^[ \t]*MOD ([1-9][0-9]*) ([0-9]+)[ \t]*$/)
|
|
|
|
|
{
|
2007-05-21 03:34:53 +04:00
|
|
|
|
$cbstart = $2;
|
|
|
|
|
$cbplus = '+='.$1;
|
|
|
|
|
}
|
|
|
|
|
}
|
|
|
|
|
|
|
|
|
|
# либо min (N, $cbcount) если $cbcount задано
|
|
|
|
|
# либо просто N если нет
|
2008-02-13 18:10:23 +03:00
|
|
|
|
if ($nesting < 2)
|
2008-08-15 21:31:24 +04:00
|
|
|
|
{
|
|
|
|
|
# блок не вложенный
|
2007-06-02 03:58:22 +04:00
|
|
|
|
if ($cbcount) { $_ = "\$_${1}_count = min (scalar(\@\{\$self->{_tpldata}{'$1.'}\}), " . $cbcount . ');'; }
|
2007-05-21 03:34:53 +04:00
|
|
|
|
else { $_ = "\$_${1}_count = scalar(\@{\$self->{_tpldata}{'$1.'}});"; }
|
|
|
|
|
# начало цикла for
|
|
|
|
|
$_ .= "\nfor (\$_${1}_i = $cbstart; \$_${1}_i < \$_${1}_count; \$_${1}_i$cbplus)\n{";
|
|
|
|
|
}
|
2008-02-13 18:10:23 +03:00
|
|
|
|
else
|
2008-08-15 21:31:24 +04:00
|
|
|
|
{
|
|
|
|
|
# блок вложенный
|
2007-05-21 03:34:53 +04:00
|
|
|
|
my $namespace = substr (join ('.', @block_names), 2);
|
|
|
|
|
my $varref = $self->generate_block_data_ref ($namespace);
|
|
|
|
|
if ($cbcount) { $_ = "\$_${1}_count = min (scalar(\@\{$varref\}), $cbcount);"; }
|
|
|
|
|
else { $_ = "\$_${1}_count = (\@\{$varref\}) ? scalar(\@\{$varref\}) : 0;"; }
|
|
|
|
|
$_ .= "\nfor (\$_${1}_i = $cbstart; \$_${1}_i < \$_${1}_count; \$_${1}_i$cbplus)\n{";
|
|
|
|
|
}
|
2008-08-15 21:31:24 +04:00
|
|
|
|
}
|
|
|
|
|
elsif (/^\s*<!--\s*END\s+(.*?)-->\s*$/so)
|
|
|
|
|
{
|
2007-05-21 03:34:53 +04:00
|
|
|
|
# чётко проверяем: блок нельзя завершать чем попало
|
|
|
|
|
delete $block_names[$nesting--] if ($nesting > 0 && trim ($1) eq $block_names[$nesting]);
|
2008-08-15 21:31:24 +04:00
|
|
|
|
$self->{current_namespace} = join '.', @block_names;
|
2007-05-21 03:34:53 +04:00
|
|
|
|
$_ = "} # END $1";
|
2008-08-15 21:31:24 +04:00
|
|
|
|
}
|
2008-09-02 00:19:55 +04:00
|
|
|
|
elsif (/^\s*<!--\s*IF(!?)\s+((?:[a-z0-9\-_]+\.)*)([a-z0-9\-_]+)((?:->[a-z0-9\-_]+)*)\s*-->\s*$/iso)
|
2008-08-15 21:31:24 +04:00
|
|
|
|
{
|
2008-09-02 00:19:55 +04:00
|
|
|
|
$_ = "if ($1(".$self->generate_block_varref($2, $3, $4, undef, 1).")) {";
|
2008-08-15 21:31:24 +04:00
|
|
|
|
}
|
|
|
|
|
elsif (/^\s*<!--\s*ELSE\s*-->\s*$/so)
|
|
|
|
|
{
|
2008-03-03 14:29:35 +03:00
|
|
|
|
$_ = "} else {";
|
2008-08-15 21:31:24 +04:00
|
|
|
|
}
|
|
|
|
|
elsif (/^\s*<!--\s*INCLUDE\s*([^'\s]+)\s*-->\s*$/so)
|
|
|
|
|
{
|
2007-10-28 19:16:50 +03:00
|
|
|
|
$_ = ($included->{$1} ? "\$self->set_filenames('_INCLUDE$1' => $1);\n " : '')."\$t .= \$self->parse('_INCLUDE$1');";
|
|
|
|
|
$included->{$1} = 1;
|
2008-08-15 21:31:24 +04:00
|
|
|
|
}
|
2008-09-02 00:19:55 +04:00
|
|
|
|
elsif (/^\s*<!--\s*SET\s+((?:[a-z0-9\-_]+\.)*)([a-z0-9\-_\/]+)\s*-->\s*$/iso)
|
2008-08-15 21:31:24 +04:00
|
|
|
|
{
|
2008-02-13 18:10:23 +03:00
|
|
|
|
my $varref = $self->generate_block_data_ref($1, 1)."{'$2'}";
|
|
|
|
|
$_ = "$varref = eval {\nmy \$t = '';";
|
2008-08-15 21:31:24 +04:00
|
|
|
|
}
|
|
|
|
|
elsif (/^\s*<!--\s*ENDSET\s*-->\s*$/so)
|
|
|
|
|
{
|
2007-10-28 19:16:50 +03:00
|
|
|
|
$_ = "return \$t;\n};";
|
2008-08-15 21:31:24 +04:00
|
|
|
|
}
|
|
|
|
|
else
|
|
|
|
|
{
|
2007-05-21 03:34:53 +04:00
|
|
|
|
$_ = "\$t .= '$_';";
|
|
|
|
|
}
|
|
|
|
|
}
|
2008-08-15 21:31:24 +04:00
|
|
|
|
|
2007-05-21 03:34:53 +04:00
|
|
|
|
# собираем код в строку
|
2007-10-28 19:16:50 +03:00
|
|
|
|
$code = "package $PN;
|
|
|
|
|
use VMX::Common qw(:all);
|
|
|
|
|
no strict;
|
|
|
|
|
|
|
|
|
|
sub parse {
|
|
|
|
|
my \$self = shift;
|
|
|
|
|
my \$t = '';
|
2008-08-15 21:31:24 +04:00
|
|
|
|
my \$_current_template = [ split /:/, '$self->{cur_template}' ];
|
2007-10-28 19:16:50 +03:00
|
|
|
|
" . join("\n ", @code_lines) . "
|
|
|
|
|
return \$t;
|
|
|
|
|
}
|
|
|
|
|
|
|
|
|
|
1;
|
|
|
|
|
";
|
2007-05-21 03:34:53 +04:00
|
|
|
|
|
|
|
|
|
# кэшируем код
|
2008-08-15 21:31:24 +04:00
|
|
|
|
if ($self->{cachedir} && open (my $fd, '>'.$sfile))
|
|
|
|
|
{
|
2007-05-21 03:34:53 +04:00
|
|
|
|
print $fd $code;
|
|
|
|
|
close $fd;
|
|
|
|
|
}
|
2007-10-28 19:16:50 +03:00
|
|
|
|
|
|
|
|
|
eval $code;
|
|
|
|
|
warn $@ if $@;
|
2007-05-21 03:34:53 +04:00
|
|
|
|
|
2007-10-28 19:16:50 +03:00
|
|
|
|
_end:
|
|
|
|
|
return $self->{package_names}->{$handle} = $PN;
|
2007-05-21 03:34:53 +04:00
|
|
|
|
}
|
|
|
|
|
|
2007-09-11 02:46:55 +04:00
|
|
|
|
##
|
2008-02-13 18:10:23 +03:00
|
|
|
|
# Функция для первой замены
|
|
|
|
|
##
|
2008-08-15 21:31:24 +04:00
|
|
|
|
sub generate_xx_ref
|
|
|
|
|
{
|
2008-02-13 18:10:23 +03:00
|
|
|
|
my $self = shift;
|
2008-03-03 03:33:05 +03:00
|
|
|
|
my @a = @_;
|
2008-09-02 00:19:55 +04:00
|
|
|
|
my $a = shift @a;
|
|
|
|
|
if ($a =~ /^%%|%%$/so)
|
2008-08-15 21:31:24 +04:00
|
|
|
|
{
|
2008-09-02 00:19:55 +04:00
|
|
|
|
my $r = $a;
|
2008-02-13 18:10:23 +03:00
|
|
|
|
$r =~ s/^%%/%/so;
|
|
|
|
|
$r =~ s/%%$/%/so;
|
|
|
|
|
return $r;
|
2008-08-15 21:31:24 +04:00
|
|
|
|
}
|
2008-09-02 00:19:55 +04:00
|
|
|
|
elsif ($a =~ /^%(.+)%$/so)
|
2008-08-15 21:31:24 +04:00
|
|
|
|
{
|
|
|
|
|
return $self->language_xform($self->{current_namespace}, $1);
|
|
|
|
|
}
|
2008-09-02 00:19:55 +04:00
|
|
|
|
elsif ($a =~ /^%%+$/so)
|
2008-08-15 21:31:24 +04:00
|
|
|
|
{
|
2008-09-02 00:19:55 +04:00
|
|
|
|
return substr($a, 1);
|
2008-08-15 21:31:24 +04:00
|
|
|
|
}
|
2008-09-02 00:19:55 +04:00
|
|
|
|
elsif ($a =~ /^\{([a-z0-9\-_]+)\.\#\}$/iso)
|
2008-08-15 21:31:24 +04:00
|
|
|
|
{
|
2008-02-13 18:10:23 +03:00
|
|
|
|
return '\'.(1+($_'.$1.'_i)?$_'.$1.'_i:0)).\'';
|
2008-08-15 21:31:24 +04:00
|
|
|
|
}
|
2008-09-02 00:19:55 +04:00
|
|
|
|
elsif ($a =~ /^\{.*\}$/so)
|
2008-08-15 21:31:24 +04:00
|
|
|
|
{
|
2008-09-02 00:19:55 +04:00
|
|
|
|
return "' . " . $self->generate_block_varref(@a) . " . '";
|
2008-02-13 18:10:23 +03:00
|
|
|
|
}
|
2008-09-02 00:19:55 +04:00
|
|
|
|
return $a;
|
2008-02-13 18:10:23 +03:00
|
|
|
|
}
|
|
|
|
|
|
2007-05-21 03:34:53 +04:00
|
|
|
|
##
|
|
|
|
|
# Функция генерирует подстановку переменной шаблона
|
2008-09-02 00:19:55 +04:00
|
|
|
|
# $varref = $obj->generate_block_varref ($namespace, $varname, $varhash)
|
2007-05-21 03:34:53 +04:00
|
|
|
|
##
|
2008-08-15 21:31:24 +04:00
|
|
|
|
sub generate_block_varref
|
|
|
|
|
{
|
2007-05-21 03:34:53 +04:00
|
|
|
|
my $self = shift;
|
2008-09-02 00:19:55 +04:00
|
|
|
|
my ($namespace, $varname, $varhash, $varconv) = @_;
|
|
|
|
|
my $varref;
|
|
|
|
|
|
2008-08-15 21:31:24 +04:00
|
|
|
|
$varconv = undef unless $self->{conv}->{$varconv};
|
2007-05-21 03:34:53 +04:00
|
|
|
|
# обрезаем точки в конце
|
2007-09-11 02:46:55 +04:00
|
|
|
|
$namespace =~ s/\.*$//o;
|
2007-05-21 03:34:53 +04:00
|
|
|
|
|
|
|
|
|
$varref = $self->generate_block_data_ref ($namespace, 1);
|
|
|
|
|
# добавляем имя переменной
|
|
|
|
|
$varref .= "{'$varname'}";
|
2008-09-02 00:19:55 +04:00
|
|
|
|
# добавляем путь по вложенным хешам/массивам
|
|
|
|
|
if ($varhash)
|
|
|
|
|
{
|
|
|
|
|
$varhash = [ split /->/, $varhash ];
|
|
|
|
|
foreach (@$varhash)
|
|
|
|
|
{
|
|
|
|
|
if (/^\d+$/so)
|
|
|
|
|
{
|
|
|
|
|
$varref .= "[$_]";
|
|
|
|
|
}
|
|
|
|
|
elsif ($_)
|
|
|
|
|
{
|
|
|
|
|
$varref .= "{'$_'}";
|
|
|
|
|
}
|
|
|
|
|
}
|
|
|
|
|
}
|
2007-05-21 03:34:53 +04:00
|
|
|
|
|
2008-08-15 21:31:24 +04:00
|
|
|
|
# генерируем преобразование
|
|
|
|
|
if ($varconv)
|
|
|
|
|
{
|
|
|
|
|
unless (ref $self->{conv}->{$varconv})
|
|
|
|
|
{
|
|
|
|
|
$varref = "(" . $self->{conv}->{$varconv} . "($varref))";
|
|
|
|
|
}
|
|
|
|
|
else
|
|
|
|
|
{
|
|
|
|
|
my $f = $self->{conv}->{$varconv};
|
|
|
|
|
unless ($namespace)
|
|
|
|
|
{
|
|
|
|
|
$f = &$f($self, $varname, $varref);
|
|
|
|
|
}
|
|
|
|
|
else
|
|
|
|
|
{
|
|
|
|
|
$f = &$f($self, "$namespace.$varname", $varref);
|
|
|
|
|
}
|
|
|
|
|
$varref = "($f)";
|
|
|
|
|
}
|
|
|
|
|
}
|
|
|
|
|
|
2007-05-21 03:34:53 +04:00
|
|
|
|
return $varref;
|
|
|
|
|
}
|
|
|
|
|
|
|
|
|
|
##
|
|
|
|
|
# Функция генерирует обращение к массиву переменных блока
|
|
|
|
|
# $blockref = $obj->generate_block_data_ref ($block, $include_last_iterator)
|
|
|
|
|
##
|
2008-08-15 21:31:24 +04:00
|
|
|
|
sub generate_block_data_ref
|
|
|
|
|
{
|
2007-05-21 03:34:53 +04:00
|
|
|
|
my $self = shift;
|
|
|
|
|
my $blockref = '$self->{_tpldata}';
|
|
|
|
|
my ($block, $withlastit) = @_;
|
|
|
|
|
|
|
|
|
|
# для корневого блока
|
2008-08-15 21:31:24 +04:00
|
|
|
|
return '$self->{_tpldata}{\'.\'}' . ($withlastit ? '[0]' : '')
|
|
|
|
|
if $block =~ /^\.*$/so;
|
2007-05-21 03:34:53 +04:00
|
|
|
|
|
|
|
|
|
# строим цепочку блоков
|
2008-08-15 21:31:24 +04:00
|
|
|
|
$block =~ s/\.+$//so;
|
2007-05-21 03:34:53 +04:00
|
|
|
|
my @blocks = split (/\.+/, $block);
|
|
|
|
|
my $lastblock = pop (@blocks);
|
|
|
|
|
$blockref .= "{'$_.'}[\$_${_}_i]" foreach @blocks;
|
|
|
|
|
$blockref .= "{'$lastblock.'}";
|
|
|
|
|
|
|
|
|
|
# добавляем последний итератор, если надо
|
|
|
|
|
$blockref .= "[\$_${lastblock}_i]" if ($withlastit);
|
|
|
|
|
return $blockref;
|
|
|
|
|
}
|
|
|
|
|
|
2008-08-15 21:31:24 +04:00
|
|
|
|
##
|
|
|
|
|
# Функция компилирует ссылку на данные ленгпака
|
|
|
|
|
##
|
|
|
|
|
sub language_ref
|
|
|
|
|
{
|
|
|
|
|
my $self = shift;
|
|
|
|
|
my ($var, $varref, $value) = @_;
|
|
|
|
|
my $code = '';
|
|
|
|
|
$code .= '->{' . lc($_) . '}' foreach split /\.+/, $var;
|
|
|
|
|
$code .= '->{' . $varref . '}';
|
|
|
|
|
$code =
|
|
|
|
|
($self->{cur_template_path} ?
|
|
|
|
|
'(($self->{lang}' . $self->{cur_template_path} . $code . ') || ' : '') .
|
|
|
|
|
'($self->{lang}' . $code . ') || (' .
|
|
|
|
|
$varref . '))';
|
|
|
|
|
return $code;
|
|
|
|
|
}
|
|
|
|
|
|
|
|
|
|
##
|
|
|
|
|
# Compile-time вычисление language_ref
|
|
|
|
|
##
|
|
|
|
|
sub language_xform
|
|
|
|
|
{
|
|
|
|
|
my $self = shift;
|
|
|
|
|
my ($ns, $value) = @_;
|
|
|
|
|
my ($ca, $cb) = ($self->{lang}, $self->{lang});
|
|
|
|
|
foreach (split /:/, $self->{cur_template})
|
|
|
|
|
{
|
|
|
|
|
$cb = $cb->{lc $_} if $cb;
|
|
|
|
|
}
|
|
|
|
|
if ($ns)
|
|
|
|
|
{
|
|
|
|
|
foreach (split /\./, $ns)
|
|
|
|
|
{
|
|
|
|
|
$ca = $ca->{lc $_} if $ca;
|
|
|
|
|
$cb = $cb->{lc $_} if $cb;
|
|
|
|
|
}
|
|
|
|
|
}
|
|
|
|
|
$ca = $ca->{$value} if $ca;
|
|
|
|
|
$cb = $cb->{$value} if $cb;
|
|
|
|
|
return $ca || $cb;
|
|
|
|
|
}
|
|
|
|
|
|
2007-05-21 03:34:53 +04:00
|
|
|
|
1;
|
2008-08-15 21:31:24 +04:00
|
|
|
|
__END__
|