Perl: Object methods, error handling, compile-time functions, line numbers in error text; both: reorder functions

databind
vitalif 2011-01-08 00:09:57 +00:00 committed by Vitaliy Filippov
parent a070aeee68
commit 4b1c853b40
1 changed files with 163 additions and 71 deletions

View File

@ -28,19 +28,25 @@ sub new
$class = ref ($class) || $class;
my $self =
{
root => '.', # каталог с шаблонами
reload => 2, # если 0, шаблоны не будут перечитываться с диска, и вызовов stat() происходить не будет
# если >0, то шаблоны будут перечитываться с диска не чаще чем раз в reload секунд
wrapper => undef, # глобальный фильтр, вызываемый перед выдачей результата parse
tpldata => {}, # сюда будут сохранены данные
cache_dir => undef, # необязательный кэш, ускоряющий работу только в случае частых инициализаций интерпретатора
use_utf8 => undef, # шаблоны в UTF-8 и с флагом UTF-8
begin_code => '<!--', # начало кода
end_code => '-->', # конец кода
eat_code_line => 1, # съедать "лишний" перевод строки, если в строке только инструкция?
begin_subst => '{', # начало подстановки (необязательно)
end_subst => '}', # конец подстановки (необязательно)
strict_end => 0, # жёстко требовать имя блока в его завершающей инструкции (<!-- end block -->)
root => '.', # каталог с шаблонами
cache_dir => undef, # каталог файлового кэша, ускоряющий работу в случае частых инициализаций интерпретатора
reload => 2, # если 0, шаблоны не будут перечитываться с диска, и вызовов stat() происходить не будет
# если >0, то шаблоны будут перечитываться с диска не чаще чем раз в reload секунд
wrapper => undef, # глобальный фильтр, вызываемый перед выдачей результата parse
use_utf8 => undef, # шаблоны в UTF-8 и с флагом UTF-8
begin_code => '<!--', # начало кода
end_code => '-->', # конец кода
eat_code_line => 1, # съедать "лишний" перевод строки, если в строке только инструкция?
begin_subst => '{', # начало подстановки (необязательно)
end_subst => '}', # конец подстановки (необязательно)
strict_end => 0, # жёстко требовать имя блока в его завершающей инструкции (<!-- end block -->)
raise_error => 0, # умирать от фатальных ошибок
print_error => 1, # включать ошибки в вывод шаблонов
compiletime_functions => {}, # дополнительные компилируемые функции
tpldata => {}, # сюда будут сохранены данные
errors => [], # сюда будут сохранены ошибки компиляции
@_,
};
$self->{cache_dir} =~ s!/*$!/!so if $self->{cache_dir};
@ -48,6 +54,42 @@ sub new
bless $self, $class;
}
# Сохранить и/или напечатать потом ошибку, сдохнуть в случае raise_error
sub error
{
my $self = shift;
my ($e) = @_;
if ($self->{input_filename})
{
$e = $e." at ".$self->{input_filename}.":".$self->{input_line};
}
$e = __PACKAGE__ . "::error: $e\n";
push @{$self->{errors}}, $e;
die $e if $self->{raise_error};
return $self->{print_error} ? join('', @{$self->{errors}}) : undef;
}
# Текст ошибок, ещё не включённый в вывод
sub errors
{
my $self = shift;
return @{$self->{errors}} ? join('', @{$self->{errors}}) : undef;
}
# Сохранить и/или напечатать потом предупреждение
sub warning
{
my $self = shift;
my ($w) = @_;
if ($self->{input_filename})
{
$w = $w." at ".$self->{input_filename}.":".$self->{input_line};
}
$w = __PACKAGE__ . "::warning: $w\n";
push @{$self->{errors}}, $w;
return undef;
}
# Функция уничтожает данные шаблона
# $obj->clear()
sub clear
@ -94,14 +136,14 @@ sub parse
if (!$fn)
{
$textref = \( shift );
die __PACKAGE__.": empty filename and no inline code" if !length $$textref;
return $self->error("empty filename and no inline code") if !length $$textref;
}
my $function = shift if $_[0] && !ref $_[0];
my $vars = shift if ref $_[0];
if ($fn)
{
$fn = $self->{root}.$fn if $fn !~ m!^/!so;
die __PACKAGE__.": couldn't load template file '$fn'"
return $self->error("couldn't load template file '$fn'")
unless $textref = $self->loadfile($fn);
}
my $str = $self->compile($textref, $fn);
@ -113,7 +155,15 @@ sub parse
{
local $self->{tpldata} = $vars if $vars;
$str = eval { &$str($self) };
die __PACKAGE__.": error running '$fn".'::'."$function': $@" if $@;
return $self->error("error running '$fn".'::'."$function': $@") if $@;
}
# в Perl'е мы не можем просто выплюнуть ошибку на STDOUT
# (возможно, ещё не отправлены HTTP-заголовки, и сами они не отправятся),
# print_error все ошибки сливает в текст на выход.
if (($self->{print_error} || $self->{raise_error}) && @{$self->{errors}})
{
substr($str, 0, 0, join("\n", @{$self->{errors}}) . "\n");
$self->{errors} = [];
}
&{$self->{wrapper}}($str) if $self->{wrapper};
return $str;
@ -179,7 +229,7 @@ sub compile
$compiled_code->{$coderef} = do $h;
if ($@)
{
warn __PACKAGE__.": error compiling '$fn': [$@] in FILE: $h";
$self->warning("error compiling '$fn': [$@] in FILE: $h");
unlink $h;
}
else
@ -214,9 +264,11 @@ sub compile
$self->{in} = [];
$self->{functions} = [];
$self->{output_position} = 0;
$self->{input_line} = 0;
local $self->{input_filename} = $fn;
# ищем фрагменты кода - на регэкспах-то было не очень правильно, да и медленно!
my ($r, $pp, $line, $b, $i, $e, $f, $frag, $x_pp, $l, $nl, @p) = ('', 0, 0);
my ($r, $pp, $b, $i, $e, $f, $frag, $x_pp, $l, $nl, @p) = ('', 0);
while ($code && $pp < length $code)
{
@p = map { index $code, $_->[0], $pp } @blk;
@ -268,13 +320,13 @@ sub compile
if ($pp > 0)
{
substr $code, 0, $pp, '';
$line += $nl;
$self->{input_line} += $nl;
$r .= "\$t.='$x_pp';\n" if length $x_pp;
$pp = 0;
}
$r .= "#line $line \"$fn\"\n";
$r .= "#line $self->{input_line} \"$fn\"\n";
$r .= $frag;
$line += substr($code, 0, $e+$blk[$b][5]-$p[$b], '') =~ tr/\n/\n/;
$self->{input_line} += substr($code, 0, $e+$blk[$b][5]-$p[$b], '') =~ tr/\n/\n/;
}
}
}
@ -339,13 +391,13 @@ return \$t;
}
else
{
warn __PACKAGE__.": error caching '$fn': $! while opening $h";
$self->warning("error caching '$fn': $! while opening $h");
}
}
# компилируем код
$compiled_code->{$coderef} = eval $code;
die __PACKAGE__.": error compiling '$fn': [$@] in CODE:\n$code" if $@;
return $self->error("error compiling '$fn': [$@] in CODE:\n$code") if $@;
# возвращаем ссылку на процедуру
return $compiled_code->{$coderef};
@ -372,7 +424,7 @@ sub compile_code_fragment_if
my $t = $self->compile_expression($e);
unless (defined $t)
{
warn "Invalid expression in $kw: ($e)";
$self->warning("Invalid expression in $kw: ($e)");
return undef;
}
$kw = $cf_if{$kw};
@ -388,7 +440,7 @@ sub compile_code_fragment_end
my ($self, $kw, $t) = @_;
unless (@{$self->{in}})
{
warn "END $t without BEGIN, IF or SET";
$self->warning("END $t without BEGIN, IF or SET");
return undef;
}
my ($w, $id) = @{$self->{in}->[$#{$self->{in}}]};
@ -396,7 +448,7 @@ sub compile_code_fragment_end
($t && ($w ne 'begin' || !$id || $id ne $t) ||
!$t && $w eq 'begin' && $id))
{
warn uc($kw)." $t after ".uc($w)." $id";
$self->warning(uc($kw)." $t after ".uc($w)." $id");
return undef;
}
my $in = pop @{$self->{in}};
@ -431,7 +483,7 @@ sub compile_code_fragment_set
$e = $self->compile_expression($3);
unless (defined $e)
{
warn "Invalid expression in $kw: ($3)";
$self->warning("Invalid expression in $kw: ($3)");
return undef;
}
}
@ -453,7 +505,7 @@ sub compile_code_fragment_function
my $e = $3;
if ($n !~ /^[^\W\d]\w*$/ || $n eq '_main')
{
$self->error("Template function names:
$self->warning("Template function names:
* must start with a letter
* must consist of alphanumeric characters
* must not be equal to '_main'
@ -462,7 +514,7 @@ I see 'FUNCTION $n' instead.");
}
if ($self->{functions} && @{$self->{functions}->{$#{$self->{functions}}}} == 1)
{
$self->error("Template functions cannot be nested");
$self->warning("Template functions cannot be nested");
return undef;
}
my $s = "$n => sub {\nmy \$self = shift;\n";
@ -471,7 +523,7 @@ I see 'FUNCTION $n' instead.");
my $r = $self->compile_expression($e);
if (!defined $r)
{
$self->error("Invalid expression in $kw: ($e)");
$self->warning("Invalid expression in $kw: ($e)");
return undef;
}
$s .= "return $r;\n},\n";
@ -588,7 +640,7 @@ sub compile_code_fragment
{
# обратная совместимость... нафига она нужна?...
# но пока пусть останется...
warn "Legacy IF! used, consider changing it to IF NOT";
$self->warning("Legacy IF! used, consider changing it to IF NOT");
}
my ($kw, $t) = split /\s+/, $e, 2;
$kw = lc $kw;
@ -643,16 +695,43 @@ sub compile_expression
$e =~ s/[\$\@\%]/\\$&/gso if $2;
return $e;
}
# функция нескольких аргументов или вызов замыкания из tpldata
# функция нескольких аргументов или вызов метода объекта
elsif ($e =~ /^([a-z_][a-z0-9_]*((?:\.[a-z0-9_]+)*))\s*\((.*)$/iso)
{
my $f = lc $1;
# вызов методов по цепочке типа obj.method().key.other_method() не поддерживаем
# (в PHP-версии за просто так не сделаешь, а мы хотим быть совместимыми)
my $f = $1;
my $varref;
if ($2 || !$self->can("function_$f"))
{
$varref = $self->varref($1);
}
my $a = $3;
if ($2)
{
# вызов метода объекта obj.method()
$varref = $f;
$varref =~ s/^(.*)\.([^\.]*)$/$1/so;
$f = $2;
if ($f =~ /^[^a-z_]/is)
{
$self->warning("Object method name cannot start with a number: '$f' of '$varref'");
return undef;
}
$varref = $self->varref($varref) . '->' . $f;
}
else
{
$f = lc $f;
my $s;
unless ($s = $self->{compiletime_functions}->{$f})
{
# встроенная функция
unless ($s = $self->can("function_$f"))
{
$self->warning("Unknown function: $f");
return undef;
}
}
$f = $s;
}
# разбираем аргументы
my @a;
while (defined($e = $self->compile_expression($a, \$a)))
{
@ -663,13 +742,13 @@ sub compile_expression
}
elsif ($a !~ s/^\s*,//so)
{
warn "Unexpected token: '$a' in $f() parameter list";
$self->warning("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";
$self->warning("Unexpected token: '$a' in the end of $f() parameter list");
return undef;
}
if ($a)
@ -679,12 +758,11 @@ sub compile_expression
}
if ($varref)
{
# вызов переменной-замыкания
return '&{'.$varref.'}($self,'.join(',',@a).')';
# вызов метода объекта
return "$varref(".join(',', @a).")";
}
# встроенная функция
$f = "function_$f";
return $self->$f(@a);
return &$f($self, @a);
}
# функция одного аргумента
elsif ($e =~ /^([a-z_][a-z0-9_]*)\s+(?=\S)(.*)$/iso)
@ -692,14 +770,14 @@ sub compile_expression
my $f = lc $1;
unless ($self->can("function_$f"))
{
warn "Unknown function: '$f' in '$e'";
$self->warning("Unknown function: '$f' in '$e'");
return undef;
}
my $a = $2;
my $arg = $self->compile_expression($a, \$a);
unless (defined $arg)
{
warn "Invalid expression: ($e)";
$self->warning("Invalid expression: ($e)");
return undef;
}
$a =~ s/^\s*//so;
@ -713,7 +791,6 @@ sub compile_expression
}
# переменная плюс legacy-mode переменная/функция
elsif ($e =~ /^((?:[a-z0-9_]+\.)*(?:[a-z0-9_]+\#?))(?:\/([a-z]+))?\s*(.*)$/iso)
#/^([a-z_][a-z0-9_]*(?:\.*[a-z0-9_]+)*\#?)(?:\/([a-z]+))?\s*(.*)$/iso)
{
if ($3)
{
@ -726,7 +803,7 @@ sub compile_expression
my $f = lc $2;
unless ($self->can("function_$f"))
{
warn "Unknown function: '$f' called in legacy mode ($&)";
$self->warning("Unknown function: '$f' called in legacy mode ($&)");
return undef;
}
$f = "function_$f";
@ -827,13 +904,17 @@ sub function_yesno { "(($_[1]) ? ($_[2]) : ($_[3]))" }
## Строки
# конкатенация строк
sub function_concat { fmop('.', @_) }
# нижний и верхний регистр
sub function_lc { "lc($_[1])" } *function_lower = *function_lowercase = *function_lc;
sub function_uc { "uc($_[1])" } *function_upper = *function_uppercase = *function_uc;
# экранирование символов, специальных в регулярном выражении
# экранировать двойные и одинарные кавычки в стиле C (добавить \)
sub function_quote { "quotequote($_[1])" } *function_q = *function_quote; *function_addslashes = *function_q;
# экранировать двойные кавычки в стиле SQL/CSV (удвоением)
sub function_sq { "sql_quote($_[1])" } *function_sql_quote = *function_sq;
# экранирование символов, специальных для регулярного выражения
sub function_requote { "requote($_[1])" } *function_re_quote = *function_preg_quote = *function_requote;
# кодировать символы в стиле URL
sub function_uriquote{ shift; "URI::Escape::uri_escape(".join(",",@_).")" } *function_uri_escape = *function_urlencode = *function_uriquote;
# замена регэкспов
sub function_replace { "resub($_[1], $_[2], $_[3])" }
# замена подстрок (а не регэкспов)
@ -846,26 +927,32 @@ sub function_substr { shift; "substr(".join(",", @_).")" } *function_substri
sub function_trim { shift; "trim($_[0])" }
# разделить строку $2 по регулярному выражению $1 опционально с лимитом $3
sub function_split { shift; "split(".join(",", @_).")" }
# экранировать двойные и одинарные кавычки в стиле C (добавить \)
sub function_quote { "quotequote($_[1])" } *function_q = *function_quote; *function_addslashes = *function_q;
# экранировать двойные кавычки в стиле SQL/CSV (удвоением)
sub function_sq { "sql_quote($_[1])" } *function_sql_quote = *function_sq;
# заменить символы & < > " ' на HTML-сущности
sub function_html { "htmlspecialchars($_[1])" } *function_s = *function_html; *function_htmlspecialchars = *function_html;
# заменить \n на <br />
sub function_nl2br { "resub(qr/\\n/so, '<br />', $_[1])" }
# кодировать символы в стиле URL
sub function_uriquote{ shift; "URI::Escape::uri_escape(".join(",",@_).")" } *function_uri_escape = *function_urlencode = *function_uriquote;
# удалить все HTML-теги
sub function_strip { "strip_tags($_[1])" } *function_t = *function_strip; *function_strip_tags = *function_strip;
# оставить только "безопасные" HTML-теги
sub function_h { "strip_unsafe_tags($_[1])" } *function_strip_unsafe = *function_h;
# заменить \n на <br />
sub function_nl2br { "resub(qr/\\n/so, '<br />', $_[1])" }
# конкатенация строк
sub function_concat { fmop('.', @_) }
# объединяет не просто скаляры, а также все элементы массивов
sub function_join { fearr('join', 1, @_) } *function_implode = *function_join;
# подставляет на места $1, $2 и т.п. в строке аргументы
sub function_subst { fearr('exec_subst', 1, @_) }
# sprintf
sub function_sprintf { fearr('sprintf', 1, @_) }
# strftime
sub function_strftime
{
my $self = shift;
my $e = $_[1];
$e = "($e).' '.($_[2])" if $_[2];
$e = "VMX::Common::estrftime($_[0], localtime(timestamp($e)))";
$e = "utf8on($e)" if $self->{use_utf8};
return $e;
}
# ограничение длины строки $maxlen символами на границе пробелов и добавление '...', если что.
sub function_strlimit{ "strlimit($_[1], $_[2])" }
@ -881,12 +968,12 @@ sub function_sort { '[ '.fearr('sort', 0, @_).' ]'; }
sub function_each { "exec_each($_[1])" }
# создание массива
sub function_array { shift; "[" . join(",", @_) . "]"; }
# количество элементов _массива_ (не хеша)
sub function_count { "(ref($_[1]) && $_[1] =~ /ARRAY/so ? scalar(\@{ $_[1] }) : 0)" }
# диапазон значений
sub function_range { "($_[1] .. $_[2])" }
# проверка, аргумент - массив или не массив?
sub function_is_array{ "exec_is_array($_[1])" }
# количество элементов _массива_ (не хеша)
sub function_count { "(ref($_[1]) && $_[1] =~ /ARRAY/so ? scalar(\@{ $_[1] }) : 0)" }
# подмассив по номерам элементов
sub function_subarray { shift; "exec_subarray(" . join(",", @_) . ")"; } *function_array_slice = *function_subarray;
# подмассив по кратности номеров элементов
@ -909,15 +996,19 @@ sub function_unshift { shift; "unshift(\@{".shift(@_)."}, ".join(",", @_).")"; }
# вставить как последний элемент массива
sub function_push { shift; "push(\@{".shift(@_)."}, ".join(",", @_).")"; }
## Прочее
# вычисление выражения и игнорирование результата, как в JS
sub function_void { "scalar(($_[1]), '')" }
# дамп переменной
sub function_dump { shift; "exec_dump(" . join(",", @_) . ")" } *function_var_dump = *function_dump;
# json-кодирование
# JSON-кодирование
sub function_json { "encode_json($_[1])" }
# включение другого файла
sub function_include { shift; "\$self->parse(" . join(",", @_) . ")"; } *function_process = *function_include; *function_parse = *function_include;
# вызов функции объекта по вычисляемому имени
sub function_call { shift; "exec_call(" . join(",", @_) . ")"; }
# map()
sub function_map
@ -930,16 +1021,9 @@ sub function_map
return '[ '.fearr('map { '.$f.' }', 0, $self, @_).' ]';
}
# strftime
sub function_strftime
{
my $self = shift;
my $e = $_[1];
$e = "($e).' '.($_[2])" if $_[2];
$e = "VMX::Common::estrftime($_[0], localtime(timestamp($e)))";
$e = "utf8on($e)" if $self->{use_utf8};
return $e;
}
########################
## Реализации функций ##
########################
# подмассив
# exec_subarray([], 0, 10)
@ -1003,6 +1087,14 @@ sub exec_str_replace
return $v;
}
# вызов функции $2 объекта $1 с параметрами $3 и далее
sub exec_call
{
my $o = shift;
my $m = shift;
return $o->$m(@_);
}
# Data::Dumper
sub exec_dump
{