2014-09-25 15:58:18 +04:00
|
|
|
|
# Контекстно-свободная Parse::Yapp-грамматика шаблонизатора
|
|
|
|
|
#
|
|
|
|
|
# {{ двойные скобки }} нужно исключительно чтобы маркеры начала и конца подстановки
|
|
|
|
|
# были уникальны в грамматике. Вместо них обычно используются { одинарные }, а
|
|
|
|
|
# выбор корректной лексемы - скобки или маркера - делает лексический анализатор.
|
|
|
|
|
# Но зато вместо { фигурных скобок } можно выбрать себе любые другие маркеры!
|
|
|
|
|
#
|
|
|
|
|
# Все выражения представляются массивом из двух значений: [ код выражения, флаг экранирования ]
|
|
|
|
|
# Флаг экранирования == true, если это выражение HTML-безопасно. При включённом auto_escape
|
|
|
|
|
# небезопасные выражения прогоняются через экранирование.
|
|
|
|
|
#
|
|
|
|
|
# Кстати:
|
|
|
|
|
# * Олдстайл BEGIN .. END ликвидирован
|
|
|
|
|
# * Возможно, нужно добавить в каком-то виде foreach ... as key => value
|
2014-10-04 22:52:01 +04:00
|
|
|
|
#
|
|
|
|
|
# P.S: Комментарии типа "#{" и "#}" служат, чтобы тупой Parse::Yapp понимал парные скобки
|
2014-09-25 15:58:18 +04:00
|
|
|
|
|
2014-10-05 00:02:29 +04:00
|
|
|
|
%{
|
|
|
|
|
VMXTemplate::Utils::import();
|
|
|
|
|
%}
|
|
|
|
|
|
2014-09-25 15:58:18 +04:00
|
|
|
|
%start template
|
|
|
|
|
|
|
|
|
|
%token literal
|
|
|
|
|
%token name
|
|
|
|
|
|
|
|
|
|
%token '..'
|
|
|
|
|
%token '||'
|
|
|
|
|
%token 'OR'
|
|
|
|
|
%token 'XOR'
|
|
|
|
|
%token 'AND'
|
|
|
|
|
%token '&&'
|
|
|
|
|
%token '&'
|
|
|
|
|
%token '=='
|
|
|
|
|
%token '!='
|
|
|
|
|
%token '<'
|
|
|
|
|
%token '>'
|
|
|
|
|
%token '<='
|
|
|
|
|
%token '>='
|
|
|
|
|
%token '+'
|
|
|
|
|
%token '-'
|
|
|
|
|
%token '*'
|
|
|
|
|
%token '/'
|
|
|
|
|
%token '%'
|
|
|
|
|
%token '('
|
|
|
|
|
%token ')'
|
|
|
|
|
%token '!'
|
|
|
|
|
%token 'NOT'
|
|
|
|
|
%token '{'
|
|
|
|
|
%token '}'
|
|
|
|
|
%token ','
|
|
|
|
|
%token '=>'
|
|
|
|
|
%token '['
|
|
|
|
|
%token ']'
|
|
|
|
|
%token '<!--'
|
|
|
|
|
%token '-->'
|
|
|
|
|
%token '{{'
|
|
|
|
|
%token '}}'
|
|
|
|
|
|
|
|
|
|
%left '..'
|
|
|
|
|
%left '||' 'OR' 'XOR'
|
|
|
|
|
%left '&&' 'AND'
|
|
|
|
|
%nonassoc '==' '!=' '<' '>' '<=' '>='
|
|
|
|
|
%left '+' '-'
|
|
|
|
|
%left '&'
|
|
|
|
|
%left '*' '/' '%'
|
|
|
|
|
|
|
|
|
|
# Директивы
|
|
|
|
|
|
|
|
|
|
%%
|
|
|
|
|
|
|
|
|
|
template: chunks {
|
|
|
|
|
$_[0]->{template}->{st}->{functions}->{main}->{body} = "sub fn_main() {\nmy \$stack = [];\nmy \$t = '';\n".$_[1]."\nreturn \$t;\n}\n";
|
|
|
|
|
'';
|
|
|
|
|
}
|
|
|
|
|
;
|
|
|
|
|
chunks: {
|
|
|
|
|
'';
|
|
|
|
|
}
|
|
|
|
|
| chunks chunk {
|
|
|
|
|
$_[1] . $_[2];
|
|
|
|
|
}
|
|
|
|
|
;
|
|
|
|
|
chunk: literal {
|
|
|
|
|
'$t .= ' . $_[1] . ";\n";
|
|
|
|
|
}
|
|
|
|
|
| '<!--' code_chunk '-->' {
|
|
|
|
|
$_[2];
|
|
|
|
|
}
|
|
|
|
|
| '{{' exp '}}' {
|
2014-10-04 22:52:01 +04:00
|
|
|
|
'$t .= ' . ($_[2][1] || !$_[0]->{template}->{options}->{auto_escape} ? $_[2][0] : $_[0]->{template}->compile_function($_[0]->{template}->{options}->{auto_escape}, [ $_[2] ])->[0]) . ";\n";
|
2014-09-25 15:58:18 +04:00
|
|
|
|
}
|
|
|
|
|
| error {
|
|
|
|
|
'';
|
|
|
|
|
}
|
|
|
|
|
;
|
|
|
|
|
code_chunk: c_if | c_set | c_fn | c_for | exp {
|
2014-10-04 22:52:01 +04:00
|
|
|
|
'$t .= ' . ($_[1][1] || !$_[0]->{template}->{options}->{auto_escape} ? $_[1][0] : $_[0]->{template}->compile_function($_[0]->{template}->{options}->{auto_escape}, [ $_[1] ])->[0]) . ";\n";
|
2014-09-25 15:58:18 +04:00
|
|
|
|
}
|
|
|
|
|
;
|
|
|
|
|
c_if: 'IF' exp '-->' chunks '<!--' 'END' {
|
|
|
|
|
"if (" . $_[2][0] . ") {\n" . $_[4] . "}\n";
|
|
|
|
|
}
|
|
|
|
|
| 'IF' exp '-->' chunks '<!--' 'ELSE' '-->' chunks '<!--' 'END' {
|
|
|
|
|
"if (" . $_[2][0] . ") {\n" . $_[4] . "} else {\n" . $_[8] . "}\n";
|
|
|
|
|
}
|
|
|
|
|
| 'IF' exp '-->' chunks c_elseifs chunks '<!--' 'END' {
|
|
|
|
|
"if (" . $_[2][0] . ") {\n" . $_[4] . $_[5] . $_[6] . "}\n";
|
|
|
|
|
}
|
|
|
|
|
| 'IF' exp '-->' chunks c_elseifs chunks '<!--' 'ELSE' '-->' chunks '<!--' 'END' {
|
|
|
|
|
"if (" . $_[2][0] . ") {\n" . $_[4] . $_[5] . $_[6] . "} else {\n" . $_[10] . "}\n";
|
|
|
|
|
}
|
|
|
|
|
;
|
|
|
|
|
c_elseifs: '<!--' elseif exp '-->' {
|
|
|
|
|
#{
|
|
|
|
|
"} elsif (" . $_[3][0] . ") {\n";
|
|
|
|
|
#}
|
|
|
|
|
}
|
|
|
|
|
| c_elseifs chunks '<!--' elseif exp '-->' {
|
|
|
|
|
#{
|
|
|
|
|
$_[1] . $_[2] . "} elsif (" . $_[5][0] . ") {\n";
|
|
|
|
|
#}
|
|
|
|
|
}
|
|
|
|
|
;
|
|
|
|
|
c_set: 'SET' varref '=' exp {
|
|
|
|
|
$_[2][0] . ' = ' . $_[4][0] . ";\n";
|
|
|
|
|
}
|
|
|
|
|
| 'SET' varref '-->' chunks '<!--' 'END' {
|
|
|
|
|
"push \@\$stack, \$t;\n\$t = '';\n" . $_[4] . $_[2][0] . " = \$t;\n\$t = pop(\@\$stack);\n";
|
|
|
|
|
}
|
|
|
|
|
;
|
|
|
|
|
c_fn: fn name '(' arglist ')' '=' exp {
|
|
|
|
|
$_[0]->{template}->{st}->{functions}->{$_[2]} = {
|
|
|
|
|
'name' => $_[2],
|
|
|
|
|
'args' => $_[4],
|
|
|
|
|
'body' => 'sub fn_'.$_[2]." () {\nreturn ".$_[7].";\n}\n",
|
2014-10-04 22:52:01 +04:00
|
|
|
|
#'line' => $line, Ой, я чо - аргументы не юзаю?
|
|
|
|
|
#'pos' => $pos,
|
2014-09-25 15:58:18 +04:00
|
|
|
|
};
|
|
|
|
|
'';
|
|
|
|
|
}
|
|
|
|
|
| fn name '(' arglist ')' '-->' chunks '<!--' 'END' {
|
|
|
|
|
$_[0]->{template}->{st}->{functions}->{$_[2]} = {
|
|
|
|
|
'name' => $_[2],
|
|
|
|
|
'args' => $_[4],
|
|
|
|
|
'body' => 'sub fn_'.$_[2]." () {\nmy \$stack = [];\nmy \$t = '';\n".$_[7]."\nreturn \$t;\n}\n",
|
2014-10-04 22:52:01 +04:00
|
|
|
|
#'line' => $line,
|
|
|
|
|
#'pos' => $pos,
|
2014-09-25 15:58:18 +04:00
|
|
|
|
};
|
|
|
|
|
'';
|
|
|
|
|
}
|
|
|
|
|
;
|
|
|
|
|
c_for: for varref '=' exp '-->' chunks '<!--' 'END' {
|
|
|
|
|
my @varref = @{$_[2]};
|
|
|
|
|
my @exp = @_{$_[4]};
|
|
|
|
|
my $cs = $_[6];
|
|
|
|
|
#{
|
|
|
|
|
my $varref_index = substr($varref[0], 0, -1) . ".'_index'}";
|
|
|
|
|
"push \@\$stack, ".$varref[0].", ".$varref_index.", 0;
|
|
|
|
|
foreach my \$item (array1($exp[0])) {
|
|
|
|
|
".$varref[0]." = \$item;
|
|
|
|
|
".$varref_index." = \$stack[count(\$stack)-1]++;
|
|
|
|
|
".$cs."}
|
|
|
|
|
pop \@\$stack;
|
|
|
|
|
".$varref_index." = pop(\@\$stack);
|
|
|
|
|
".$varref[0]." = pop(\@\$stack);
|
|
|
|
|
";
|
|
|
|
|
}
|
|
|
|
|
;
|
|
|
|
|
fn: 'FUNCTION' | 'BLOCK' | 'MACRO' ;
|
|
|
|
|
for: 'FOR' | 'FOREACH' ;
|
|
|
|
|
elseif: 'ELSE' 'IF' | 'ELSIF' | 'ELSEIF' ;
|
|
|
|
|
|
|
|
|
|
# Выражения
|
|
|
|
|
|
|
|
|
|
exp: exp '..' exp {
|
|
|
|
|
[ '(' . $_[1][0] . ' . ' . $_[3][0] . ')', $_[1][1] && $_[3][1] ];
|
|
|
|
|
}
|
|
|
|
|
| exp '||' exp {
|
|
|
|
|
[ '(' . $_[1][0] . ' || ' . $_[3][0] . ')', $_[1][1] && $_[3][1] ];
|
|
|
|
|
}
|
|
|
|
|
| exp 'OR' exp {
|
|
|
|
|
[ '(' . $_[1][0] . ' || ' . $_[3][0] . ')', $_[1][1] && $_[3][1] ];
|
|
|
|
|
}
|
|
|
|
|
| exp 'XOR' exp {
|
|
|
|
|
[ '(' . $_[1][0] . ' XOR ' . $_[3][0] . ')', 1 ];
|
|
|
|
|
}
|
|
|
|
|
| exp '&&' exp {
|
|
|
|
|
[ '(' . $_[1][0] . ' && ' . $_[3][0] . ')', 1 ];
|
|
|
|
|
}
|
|
|
|
|
| exp 'AND' exp {
|
|
|
|
|
[ '(' . $_[1][0] . ' && ' . $_[3][0] . ')', 1 ];
|
|
|
|
|
}
|
|
|
|
|
| exp '==' exp {
|
|
|
|
|
[ '$self->eq(' . $_[1][0] . ', ' . $_[3][0] . ')', 1 ];
|
|
|
|
|
}
|
|
|
|
|
| exp '!=' exp {
|
|
|
|
|
[ '!$self->eq(' . $_[1][0] . ', ' . $_[3][0] . ')', 1 ];
|
|
|
|
|
}
|
|
|
|
|
| exp '<' exp {
|
|
|
|
|
[ '$self->lt(' . $_[1][0] . ', ' . $_[3][0] . ')', 1 ];
|
|
|
|
|
}
|
|
|
|
|
| exp '>' exp {
|
|
|
|
|
[ '$self->gt(' . $_[1][0] . ', ' . $_[3][0] . ')', 1 ];
|
|
|
|
|
}
|
|
|
|
|
| exp '<=' exp {
|
|
|
|
|
[ '!$self->gt(' . $_[1][0] . ', ' . $_[3][0] . ')', 1 ];
|
|
|
|
|
}
|
|
|
|
|
| exp '>=' exp {
|
|
|
|
|
[ '!$self->lt(' . $_[1][0] . ', ' . $_[3][0] . ')', 1 ];
|
|
|
|
|
}
|
|
|
|
|
| exp '+' exp {
|
|
|
|
|
[ '(' . $_[1][0] . ' + ' . $_[3][0] . ')', 1 ];
|
|
|
|
|
}
|
|
|
|
|
| exp '-' exp {
|
|
|
|
|
[ '(' . $_[1][0] . ' - ' . $_[3][0] . ')', 1 ];
|
|
|
|
|
}
|
|
|
|
|
| exp '&' exp {
|
|
|
|
|
[ '(' . $_[1][0] . ' & ' . $_[3][0] . ')', 1 ];
|
|
|
|
|
}
|
|
|
|
|
| exp '*' exp {
|
|
|
|
|
[ '(' . $_[1][0] . ' * ' . $_[3][0] . ')', 1 ];
|
|
|
|
|
}
|
|
|
|
|
| exp '/' exp {
|
|
|
|
|
[ '(' . $_[1][0] . ' / ' . $_[3][0] . ')', 1 ];
|
|
|
|
|
}
|
|
|
|
|
| exp '%' exp {
|
|
|
|
|
[ '(' . $_[1][0] . ' % ' . $_[3][0] . ')', 1 ];
|
|
|
|
|
}
|
|
|
|
|
| p10
|
|
|
|
|
;
|
|
|
|
|
p10: p11
|
|
|
|
|
| '-' p11 {
|
|
|
|
|
[ '(-'.$_[2][0].')', 1 ];
|
|
|
|
|
}
|
|
|
|
|
;
|
|
|
|
|
p11: nonbrace
|
|
|
|
|
| '(' exp ')' varpath {
|
|
|
|
|
[ '('.$_[2][0].')'.$_[4], 0 ];
|
|
|
|
|
}
|
|
|
|
|
| '!' p11 {
|
|
|
|
|
[ '(!'.$_[2][0].')', 1 ];
|
|
|
|
|
}
|
|
|
|
|
| 'NOT' p11 {
|
|
|
|
|
[ '(!'.$_[2][0].')', 1 ];
|
|
|
|
|
}
|
|
|
|
|
;
|
|
|
|
|
nonbrace: '{' hash '}' {
|
|
|
|
|
[ "{ " . $_[2] . " }", 1 ];
|
|
|
|
|
}
|
|
|
|
|
| literal {
|
|
|
|
|
[ $1, 1 ];
|
|
|
|
|
}
|
|
|
|
|
| varref
|
|
|
|
|
| name '(' ')' {
|
|
|
|
|
$_[0]->{template}->compile_function($_[1], []);
|
|
|
|
|
}
|
|
|
|
|
| name '(' list ')' {
|
|
|
|
|
$_[0]->{template}->compile_function($_[1], $_[3]);
|
|
|
|
|
}
|
|
|
|
|
| name '(' gthash ')' {
|
2014-10-05 00:02:29 +04:00
|
|
|
|
[ "\$self->{parent}->call_block('".addcslashes($_[1], "'\\")."', { ".$_[3]." }, '".addcslashes($_[0]->{__lexer}->errorinfo(), "'\\")."')", 1 ];
|
2014-09-25 15:58:18 +04:00
|
|
|
|
}
|
|
|
|
|
| name nonbrace {
|
|
|
|
|
$_[0]->{template}->compile_function($_[1], [ $_[3] ]);
|
|
|
|
|
}
|
|
|
|
|
| method '(' ')' {
|
|
|
|
|
[ $_[1].'()', 1 ];
|
|
|
|
|
}
|
|
|
|
|
| method '(' list ')' {
|
|
|
|
|
my $argv = [];
|
|
|
|
|
foreach my $a (@{$_[3]}) {
|
|
|
|
|
push @$argv, $a->[0];
|
|
|
|
|
}
|
|
|
|
|
[ $_[1].'('.join(', ', @$argv).')', 1 ];
|
|
|
|
|
}
|
|
|
|
|
;
|
|
|
|
|
method: varref '.' name {
|
|
|
|
|
$_[1][0].'->'.$_[3];
|
|
|
|
|
}
|
|
|
|
|
;
|
|
|
|
|
list: exp {
|
|
|
|
|
[ $_[1] ];
|
|
|
|
|
}
|
|
|
|
|
| exp ',' list {
|
|
|
|
|
[ $_[1], @{$_[3]} ];
|
|
|
|
|
}
|
|
|
|
|
;
|
|
|
|
|
arglist: name {
|
|
|
|
|
[ $_[1] ];
|
|
|
|
|
}
|
|
|
|
|
| name ',' arglist {
|
|
|
|
|
[ $_[1], @{$_[3]} ];
|
|
|
|
|
}
|
|
|
|
|
| {
|
|
|
|
|
[];
|
|
|
|
|
}
|
|
|
|
|
;
|
|
|
|
|
hash: pair
|
|
|
|
|
| pair ',' hash {
|
|
|
|
|
$_[1] . ', ' . $_[3];
|
|
|
|
|
}
|
|
|
|
|
| {
|
|
|
|
|
'';
|
|
|
|
|
}
|
|
|
|
|
;
|
|
|
|
|
gthash: gtpair
|
|
|
|
|
| gtpair ',' gthash {
|
|
|
|
|
$_[1] . ', ' . $_[3];
|
|
|
|
|
}
|
|
|
|
|
;
|
|
|
|
|
pair: exp ',' exp {
|
|
|
|
|
$_[1][0] . ' => ' . $_[3][0];
|
|
|
|
|
}
|
|
|
|
|
| gtpair
|
|
|
|
|
;
|
|
|
|
|
gtpair: exp '=>' exp {
|
|
|
|
|
$_[1][0] . ' => ' . $_[3][0];
|
|
|
|
|
}
|
|
|
|
|
;
|
|
|
|
|
varref: name {
|
|
|
|
|
[ "\$self->{tpldata}{'".addcslashes($_[1], "\\\'")."'}", 0 ];
|
|
|
|
|
}
|
|
|
|
|
| varref varpart {
|
|
|
|
|
[ $_[1][0] . $_[2], 0 ];
|
|
|
|
|
}
|
|
|
|
|
;
|
|
|
|
|
varpart: '.' name {
|
|
|
|
|
"{'".addcslashes($_[1], "\\\'")."'}";
|
|
|
|
|
}
|
|
|
|
|
| '[' exp ']' {
|
|
|
|
|
($_[2][1] eq 'i' ? '['.$_[2][0].']' : "{".$_[2][0]."}");
|
|
|
|
|
}
|
|
|
|
|
;
|
|
|
|
|
varpath: {
|
|
|
|
|
'';
|
|
|
|
|
}
|
|
|
|
|
| varpath varpart {
|
|
|
|
|
$_[1] . $_[2];
|
|
|
|
|
}
|
|
|
|
|
;
|
|
|
|
|
|
|
|
|
|
%%
|
|
|
|
|
|
|
|
|
|
# Possible tokens consisting of special characters
|
|
|
|
|
my $chartokens = '+ - = * / % ! , . < > ( ) { } [ ] & .. || && == != <= >= =>';
|
|
|
|
|
|
|
|
|
|
# Reserved keywords
|
|
|
|
|
my $keywords_str = 'OR XOR AND NOT IF ELSE ELSIF ELSEIF END SET FOR FOREACH FUNCTION BLOCK MACRO';
|
|
|
|
|
|
|
|
|
|
sub _Lexer
|
|
|
|
|
{
|
|
|
|
|
my ($parser) = shift;
|
2014-10-04 22:52:01 +04:00
|
|
|
|
return $parser->{__lexer}->read_token;
|
|
|
|
|
}
|
|
|
|
|
|
|
|
|
|
sub _error
|
|
|
|
|
{
|
2014-10-05 00:02:29 +04:00
|
|
|
|
my ($self) = @_;
|
|
|
|
|
$self->{__lexer}->warn('Unexpected ' . $self->YYCurtok . ($self->YYCurval ? ' ' . $self->YYCurval : ''));
|
|
|
|
|
$self->{__lexer}->skip_error;
|
2014-09-25 15:58:18 +04:00
|
|
|
|
}
|
|
|
|
|
|
2014-10-05 00:02:29 +04:00
|
|
|
|
sub compile
|
|
|
|
|
{
|
|
|
|
|
my ($self, $text) = @_;
|
|
|
|
|
$self->{__lexer} ||= new VMXTemplate::Lexer($self, $self->{__options});
|
|
|
|
|
$self->{__lexer}->set_code($text);
|
|
|
|
|
$self->YYParse(yylex => \&_Lexer, yyerror => \&_error);
|
|
|
|
|
}
|
2014-09-25 15:58:18 +04:00
|
|
|
|
|
2014-10-04 22:52:01 +04:00
|
|
|
|
package VMXTemplate::Lexer;
|
|
|
|
|
|
|
|
|
|
sub new
|
2014-09-25 15:58:18 +04:00
|
|
|
|
{
|
2014-10-04 22:52:01 +04:00
|
|
|
|
my $class = shift;
|
|
|
|
|
$class = ref($class) || $class;
|
|
|
|
|
my ($options) = @_;
|
2014-09-25 15:58:18 +04:00
|
|
|
|
|
2014-10-04 22:52:01 +04:00
|
|
|
|
my $self = bless {
|
|
|
|
|
options => $options,
|
|
|
|
|
|
|
|
|
|
# Input
|
|
|
|
|
code => '',
|
|
|
|
|
eaten => '',
|
|
|
|
|
lineno => 0,
|
2014-09-25 15:58:18 +04:00
|
|
|
|
|
2014-10-04 22:52:01 +04:00
|
|
|
|
# Preprocessed keyword tokens
|
|
|
|
|
nchar => {},
|
|
|
|
|
lens => [],
|
|
|
|
|
keywords => { map { $_ => 1 } split / /, $keywords_str },
|
|
|
|
|
|
|
|
|
|
# Last directive start position, directive and substitution start/end counters
|
|
|
|
|
last_start => 0,
|
|
|
|
|
last_start_line => 0,
|
|
|
|
|
in_code => 0,
|
|
|
|
|
in_subst => 0,
|
|
|
|
|
}, $class;
|
|
|
|
|
|
|
|
|
|
foreach (split(/ /, $chartokens))
|
2014-09-25 15:58:18 +04:00
|
|
|
|
{
|
2014-10-04 22:52:01 +04:00
|
|
|
|
$self->{nchar}{length($_)}{$_} = 1;
|
2014-09-25 15:58:18 +04:00
|
|
|
|
}
|
2014-10-04 22:52:01 +04:00
|
|
|
|
# Add code fragment finishing tokens
|
|
|
|
|
$self->{nchar}{length($self->{options}->{end_code})}{$self->{options}->{end_code}} = 1;
|
|
|
|
|
if ($self->{options}->{end_subst})
|
2014-09-25 15:58:18 +04:00
|
|
|
|
{
|
2014-10-04 22:52:01 +04:00
|
|
|
|
$self->{nchar}{length($self->{options}->{end_subst})}{$self->{options}->{end_subst}} = 1;
|
2014-09-25 15:58:18 +04:00
|
|
|
|
}
|
2014-10-04 22:52:01 +04:00
|
|
|
|
# Reverse-sort lengths
|
|
|
|
|
$self->{lens} = [ sort { $b <=> $a } keys %{$self->{nchar}} ];
|
2014-09-25 15:58:18 +04:00
|
|
|
|
|
2014-10-04 22:52:01 +04:00
|
|
|
|
return $self;
|
|
|
|
|
}
|
|
|
|
|
|
2014-10-05 00:02:29 +04:00
|
|
|
|
sub set_code
|
|
|
|
|
{
|
|
|
|
|
my $self = shift;
|
|
|
|
|
my ($code) = @_;
|
|
|
|
|
$self->{code} = $code;
|
|
|
|
|
$self->{eaten} = '';
|
|
|
|
|
$self->{lineno} = $self->{in_code} = $self->{in_subst} = 0;
|
|
|
|
|
$self->{last_start} = $self->{last_start_line} = 0;
|
|
|
|
|
}
|
|
|
|
|
|
2014-10-04 22:52:01 +04:00
|
|
|
|
sub eat
|
|
|
|
|
{
|
|
|
|
|
my $self = shift;
|
|
|
|
|
my ($len) = @_;
|
|
|
|
|
my $str = substr($self->{code}, 0, $len, '');
|
2014-10-05 00:02:29 +04:00
|
|
|
|
$self->{eaten} .= $str;
|
2014-10-04 22:52:01 +04:00
|
|
|
|
$self->{lineno} += ($str =~ tr/\n/\n/);
|
|
|
|
|
return $str;
|
|
|
|
|
}
|
|
|
|
|
|
|
|
|
|
sub skip_error
|
|
|
|
|
{
|
|
|
|
|
my ($self) = @_;
|
|
|
|
|
$self->{code} = substr($self->{eaten}, $self->{last_start}+1, length($self->{eaten}), '') . $self->{code};
|
|
|
|
|
$self->{lineno} = $self->{last_start_line};
|
|
|
|
|
$self->{in_code} = $self->{in_subst} = 0;
|
|
|
|
|
}
|
|
|
|
|
|
|
|
|
|
sub read_token
|
|
|
|
|
{
|
|
|
|
|
my $self = shift;
|
|
|
|
|
if (!length $self->{code})
|
2014-09-25 15:58:18 +04:00
|
|
|
|
{
|
2014-10-04 22:52:01 +04:00
|
|
|
|
# End of code
|
|
|
|
|
return;
|
2014-09-25 15:58:18 +04:00
|
|
|
|
}
|
2014-10-04 22:52:01 +04:00
|
|
|
|
if ($self->{in_code} <= 0 && $self->{in_subst} <= 0)
|
2014-09-25 15:58:18 +04:00
|
|
|
|
{
|
2014-10-04 22:52:01 +04:00
|
|
|
|
my $r;
|
|
|
|
|
my $code_pos = index($self->{code}, $self->{options}->{begin_code});
|
|
|
|
|
my $subst_pos = index($self->{code}, $self->{options}->{begin_subst});
|
|
|
|
|
if ($code_pos == -1 && $subst_pos == -1)
|
2014-09-25 15:58:18 +04:00
|
|
|
|
{
|
2014-10-04 22:52:01 +04:00
|
|
|
|
# No more directives
|
|
|
|
|
$r = [ 'literal', "'".addcslashes($self->eat(length $self->{code}), "'\\")."'" ];
|
2014-09-25 15:58:18 +04:00
|
|
|
|
}
|
2014-10-04 22:52:01 +04:00
|
|
|
|
elsif ($subst_pos == -1 || $code_pos >= 0 && $subst_pos > $code_pos)
|
2014-09-25 15:58:18 +04:00
|
|
|
|
{
|
2014-10-04 22:52:01 +04:00
|
|
|
|
# Code starts closer
|
|
|
|
|
if ($code_pos > 0)
|
2014-09-25 15:58:18 +04:00
|
|
|
|
{
|
2014-10-04 22:52:01 +04:00
|
|
|
|
# We didn't yet reach the code beginning
|
|
|
|
|
my $str = $self->eat($code_pos);
|
|
|
|
|
if ($self->{options}->{eat_code_line})
|
2014-09-25 15:58:18 +04:00
|
|
|
|
{
|
2014-10-04 22:52:01 +04:00
|
|
|
|
$str =~ s/\n[ \t]*$/\n/s;
|
2014-09-25 15:58:18 +04:00
|
|
|
|
}
|
2014-10-04 22:52:01 +04:00
|
|
|
|
$r = [ 'literal', "'".addcslashes($str, "'\\")."'" ];
|
2014-09-25 15:58:18 +04:00
|
|
|
|
}
|
|
|
|
|
else
|
|
|
|
|
{
|
2014-10-04 22:52:01 +04:00
|
|
|
|
# We are at the code beginning
|
|
|
|
|
my $i = length $self->{options}->{begin_code};
|
|
|
|
|
if ($self->{code} =~ /^.{$i}([ \t]+)/s)
|
2014-09-25 15:58:18 +04:00
|
|
|
|
{
|
2014-10-04 22:52:01 +04:00
|
|
|
|
$i += length $1;
|
2014-09-25 15:58:18 +04:00
|
|
|
|
}
|
2014-10-04 22:52:01 +04:00
|
|
|
|
if ($i < length($self->{code}) && substr($self->{code}, $i, 1) eq '#')
|
2014-09-25 15:58:18 +04:00
|
|
|
|
{
|
2014-10-04 22:52:01 +04:00
|
|
|
|
# Strip comment and retry
|
|
|
|
|
$i = index($self->{code}, $self->{options}->{end_code}, $i);
|
|
|
|
|
$i = $i >= 0 ? $i+length($self->{options}->{end_code}) : length $self->{code};
|
|
|
|
|
$self->eat($i);
|
|
|
|
|
return $self->read_token();
|
2014-09-25 15:58:18 +04:00
|
|
|
|
}
|
2014-10-04 22:52:01 +04:00
|
|
|
|
$r = [ '<!--', $self->{options}->{begin_code} ];
|
|
|
|
|
$self->{last_start} = length $self->{eaten};
|
|
|
|
|
$self->{last_start_line} = $self->{lineno};
|
|
|
|
|
$self->eat(length $self->{options}->{begin_code});
|
|
|
|
|
$self->{in_code} = 1;
|
2014-09-25 15:58:18 +04:00
|
|
|
|
}
|
|
|
|
|
}
|
2014-10-04 22:52:01 +04:00
|
|
|
|
else
|
2014-09-25 15:58:18 +04:00
|
|
|
|
{
|
2014-10-04 22:52:01 +04:00
|
|
|
|
# Substitution is closer
|
|
|
|
|
if ($subst_pos > 0)
|
2014-09-25 15:58:18 +04:00
|
|
|
|
{
|
2014-10-04 22:52:01 +04:00
|
|
|
|
$r = [ 'literal', "'".addcslashes($self->eat($subst_pos), "'\\")."'" ];
|
2014-09-25 15:58:18 +04:00
|
|
|
|
}
|
2014-10-04 22:52:01 +04:00
|
|
|
|
else
|
2014-09-25 15:58:18 +04:00
|
|
|
|
{
|
2014-10-04 22:52:01 +04:00
|
|
|
|
$r = [ '{{', $self->{options}->{begin_subst} ];
|
|
|
|
|
$self->{last_start} = length $self->{eaten};
|
|
|
|
|
$self->{last_start_line} = $self->{lineno};
|
|
|
|
|
$self->eat(length $self->{options}->{begin_subst});
|
|
|
|
|
$self->{in_subst} = 1;
|
2014-09-25 15:58:18 +04:00
|
|
|
|
}
|
|
|
|
|
}
|
2014-10-04 22:52:01 +04:00
|
|
|
|
return @$r;
|
|
|
|
|
}
|
|
|
|
|
# Skip whitespace
|
|
|
|
|
if ($self->{code} =~ /^(\s+)/)
|
|
|
|
|
{
|
|
|
|
|
$self->eat(length $1);
|
|
|
|
|
}
|
|
|
|
|
if (!length $self->{code})
|
|
|
|
|
{
|
|
|
|
|
# End of code
|
|
|
|
|
return;
|
|
|
|
|
}
|
|
|
|
|
if ($self->{code} =~ /^([a-z_][a-z0-9_]*)/is)
|
|
|
|
|
{
|
|
|
|
|
my $l = $1;
|
|
|
|
|
$self->eat(length $l);
|
|
|
|
|
if (exists $self->{keywords}->{uc $l})
|
|
|
|
|
{
|
|
|
|
|
# Keyword
|
|
|
|
|
return (uc $l, $l);
|
|
|
|
|
}
|
|
|
|
|
# Identifier
|
|
|
|
|
return ('name', $l);
|
|
|
|
|
}
|
|
|
|
|
elsif ($self->{code} =~ /^(
|
|
|
|
|
(\")(?:[^\"\\\\]+|\\\\.)*\" |
|
|
|
|
|
\'(?:[^\'\\\\]+|\\\\.)*\' |
|
|
|
|
|
0\d+ | \d+(\.\d+)? | 0x\d+)/xis)
|
|
|
|
|
{
|
|
|
|
|
# String or numeric non-negative literal
|
|
|
|
|
my $t = $1;
|
|
|
|
|
$self->eat(length $t);
|
|
|
|
|
if ($2)
|
2014-09-25 15:58:18 +04:00
|
|
|
|
{
|
2014-10-04 22:52:01 +04:00
|
|
|
|
$t =~ s/\$/\\\$/gso;
|
|
|
|
|
}
|
|
|
|
|
return ('literal', $t);
|
|
|
|
|
}
|
|
|
|
|
else
|
|
|
|
|
{
|
|
|
|
|
# Special characters
|
|
|
|
|
foreach my $l (@{$self->{lens}})
|
|
|
|
|
{
|
|
|
|
|
my $a = $self->{nchar}->{$l};
|
|
|
|
|
my $t = substr($self->{code}, 0, $l);
|
|
|
|
|
if (exists $a->{$t})
|
2014-09-25 15:58:18 +04:00
|
|
|
|
{
|
2014-10-04 22:52:01 +04:00
|
|
|
|
$self->eat($l);
|
|
|
|
|
if ($self->{in_code})
|
2014-09-25 15:58:18 +04:00
|
|
|
|
{
|
2014-10-04 22:52:01 +04:00
|
|
|
|
$self->{in_code}++ if $t eq $self->{options}->{begin_code};
|
|
|
|
|
$self->{in_code}-- if $t eq $self->{options}->{end_code};
|
|
|
|
|
if (!$self->{in_code})
|
2014-09-25 15:58:18 +04:00
|
|
|
|
{
|
2014-10-04 22:52:01 +04:00
|
|
|
|
if ($self->{options}->{eat_code_line} &&
|
|
|
|
|
$self->{code} =~ /^([ \t\r]+\n\r?)/so)
|
2014-09-25 15:58:18 +04:00
|
|
|
|
{
|
2014-10-04 22:52:01 +04:00
|
|
|
|
$self->eat(length $1);
|
2014-09-25 15:58:18 +04:00
|
|
|
|
}
|
2014-10-04 22:52:01 +04:00
|
|
|
|
return ('-->', $t);
|
2014-09-25 15:58:18 +04:00
|
|
|
|
}
|
2014-10-04 22:52:01 +04:00
|
|
|
|
}
|
|
|
|
|
elsif ($self->{in_subst})
|
|
|
|
|
{
|
|
|
|
|
$self->{in_subst}++ if $t eq $self->{options}->{begin_subst};
|
|
|
|
|
$self->{in_subst}-- if $t eq $self->{options}->{end_subst};
|
|
|
|
|
if (!$self->{in_subst})
|
2014-09-25 15:58:18 +04:00
|
|
|
|
{
|
2014-10-04 22:52:01 +04:00
|
|
|
|
return ('}}', $t);
|
2014-09-25 15:58:18 +04:00
|
|
|
|
}
|
|
|
|
|
}
|
2014-10-04 22:52:01 +04:00
|
|
|
|
return ($t, undef);
|
2014-09-25 15:58:18 +04:00
|
|
|
|
}
|
|
|
|
|
}
|
2014-10-04 22:52:01 +04:00
|
|
|
|
# Unknown character
|
|
|
|
|
$self->warn("Unexpected character '".substr($self->{code}, 0, 1)."'");
|
|
|
|
|
return ('error', undef);
|
2014-09-25 15:58:18 +04:00
|
|
|
|
}
|
|
|
|
|
}
|
2014-10-04 22:52:01 +04:00
|
|
|
|
|
|
|
|
|
sub errorinfo
|
|
|
|
|
{
|
|
|
|
|
my $self = shift;
|
|
|
|
|
my $linestart = rindex($self->{eaten}, "\n");
|
|
|
|
|
my $lineend = index($self->{code}, "\n");
|
|
|
|
|
$lineend = length($self->{code}) if $lineend < 0;
|
|
|
|
|
my $line = substr($self->{eaten}, $linestart+1) . '^^^' . substr($self->{code}, 0, $lineend);
|
|
|
|
|
my $charpos;
|
|
|
|
|
{
|
|
|
|
|
use bytes;
|
|
|
|
|
$charpos = length $self->{eaten};
|
|
|
|
|
}
|
|
|
|
|
return ' in '.$self->{options}->{input_filename}.', line '.($self->{lineno}+1).
|
|
|
|
|
', character '.$charpos.', marked by ^^^ in '.$line;
|
|
|
|
|
}
|
|
|
|
|
|
|
|
|
|
sub warn
|
|
|
|
|
{
|
|
|
|
|
my $self = shift;
|
|
|
|
|
my ($text) = @_;
|
|
|
|
|
$self->{options}->error($text.$self->errorinfo());
|
|
|
|
|
}
|
2014-10-05 00:02:29 +04:00
|
|
|
|
|
|
|
|
|
package VMXTemplate::Utils;
|
|
|
|
|
|
|
|
|
|
use base qw(Exporter);
|
|
|
|
|
our @EXPORT = qw(
|
|
|
|
|
TS_UNIX TS_DB TS_DB_DATE TS_MW TS_EXIF TS_ORACLE TS_ISO_8601 TS_RFC822
|
|
|
|
|
timestamp plural_ru strlimit strip_tags addcslashes
|
|
|
|
|
);
|
|
|
|
|
|
|
|
|
|
use constant {
|
|
|
|
|
TS_UNIX => 0,
|
|
|
|
|
TS_DB => 1,
|
|
|
|
|
TS_DB_DATE => 2,
|
|
|
|
|
TS_MW => 3,
|
|
|
|
|
TS_EXIF => 4,
|
|
|
|
|
TS_ORACLE => 5,
|
|
|
|
|
TS_ISO_8601 => 6,
|
|
|
|
|
TS_RFC822 => 7,
|
|
|
|
|
};
|
|
|
|
|
|
|
|
|
|
my @Mon = qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec);
|
|
|
|
|
my %mon = qw(jan 0 feb 1 mar 2 apr 3 may 4 jun 5 jul 6 aug 7 sep 8 oct 9 nov 10 dec 11);
|
|
|
|
|
my @Wday = qw(Sun Mon Tue Wed Thu Fri Sat);
|
|
|
|
|
|
|
|
|
|
our $safe_tags = 'div|blockquote|span|a|b|i|u|p|h1|h2|h3|h4|h5|h6|strike|strong|small|big|blink|center|ol|pre|sub|sup|font|br|table|tr|td|th|tbody|tfoot|thead|tt|ul|li|em|img|marquee|cite';
|
|
|
|
|
|
|
|
|
|
# ограниченная распознавалка дат
|
|
|
|
|
sub timestamp
|
|
|
|
|
{
|
|
|
|
|
my ($ts, $format) = @_;
|
|
|
|
|
|
|
|
|
|
require POSIX;
|
|
|
|
|
if (int($ts) eq $ts)
|
|
|
|
|
{
|
|
|
|
|
# TS_UNIX or Epoch
|
|
|
|
|
$ts = time if !$ts;
|
|
|
|
|
}
|
|
|
|
|
|
|
|
|
|
elsif ($ts =~ /^\D*(\d{4,}?)\D*(\d{2})\D*(\d{2})\D*(?:(\d{2})\D*(\d{2})\D*(\d{2})\D*([\+\- ]\d{2}\D*)?)?$/so)
|
|
|
|
|
{
|
|
|
|
|
# TS_DB, TS_DB_DATE, TS_MW, TS_EXIF, TS_ISO_8601
|
|
|
|
|
$ts = POSIX::mktime($6||0, $5||0, $4||0, $3, $2-1, $1-1900);
|
|
|
|
|
}
|
|
|
|
|
elsif ($ts =~ /^\s*(\d\d?)-(...)-(\d\d(?:\d\d)?)\s*(\d\d)\.(\d\d)\.(\d\d)/so)
|
|
|
|
|
{
|
|
|
|
|
# TS_ORACLE
|
|
|
|
|
$ts = POSIX::mktime($6, $5, $4, int($1), $mon{lc $2}, $3 < 100 ? $3 : $3-1900);
|
|
|
|
|
}
|
|
|
|
|
elsif ($ts =~ /^\s*..., (\d\d?) (...) (\d{4,}) (\d\d):(\d\d):(\d\d)\s*([\+\- ]\d\d)\s*$/so)
|
|
|
|
|
{
|
|
|
|
|
# TS_RFC822
|
|
|
|
|
$ts = POSIX::mktime($6, $5, $4, int($1), $mon{lc $2}, $3-1900);
|
|
|
|
|
}
|
|
|
|
|
else
|
|
|
|
|
{
|
|
|
|
|
# Bogus value, return undef
|
|
|
|
|
return undef;
|
|
|
|
|
}
|
|
|
|
|
|
|
|
|
|
if (!$format)
|
|
|
|
|
{
|
|
|
|
|
# TS_UNIX
|
|
|
|
|
return $ts;
|
|
|
|
|
}
|
|
|
|
|
elsif ($format == TS_MW)
|
|
|
|
|
{
|
|
|
|
|
return POSIX::strftime("%Y%m%d%H%M%S", localtime($ts));
|
|
|
|
|
}
|
|
|
|
|
elsif ($format == TS_DB)
|
|
|
|
|
{
|
|
|
|
|
return POSIX::strftime("%Y-%m-%d %H:%M:%S", localtime($ts));
|
|
|
|
|
}
|
|
|
|
|
elsif ($format == TS_DB_DATE)
|
|
|
|
|
{
|
|
|
|
|
return POSIX::strftime("%Y-%m-%d", localtime($ts));
|
|
|
|
|
}
|
|
|
|
|
elsif ($format == TS_ISO_8601)
|
|
|
|
|
{
|
|
|
|
|
return POSIX::strftime("%Y-%m-%dT%H:%M:%SZ", localtime($ts));
|
|
|
|
|
}
|
|
|
|
|
elsif ($format == TS_EXIF)
|
|
|
|
|
{
|
|
|
|
|
return POSIX::strftime("%Y:%m:%d %H:%M:%S", localtime($ts));
|
|
|
|
|
}
|
|
|
|
|
elsif ($format == TS_RFC822)
|
|
|
|
|
{
|
|
|
|
|
my @l = localtime($ts);
|
|
|
|
|
return POSIX::strftime($Wday[$l[6]].", %d ".$Mon[$l[4]]." %Y %H:%M:%S %z", @l);
|
|
|
|
|
}
|
|
|
|
|
elsif ($format == TS_ORACLE)
|
|
|
|
|
{
|
|
|
|
|
my @l = localtime($ts);
|
|
|
|
|
return POSIX::strftime("%d-".$Mon[$l[4]]."-%Y %H.%M.%S %p", @l);
|
|
|
|
|
}
|
|
|
|
|
return $ts;
|
|
|
|
|
}
|
|
|
|
|
|
|
|
|
|
# Select one of 3 plural forms for russian language
|
|
|
|
|
sub plural_ru
|
|
|
|
|
{
|
|
|
|
|
my ($count, $one, $few, $many) = @_;
|
|
|
|
|
my $sto = $count % 100;
|
|
|
|
|
if ($sto >= 10 && $sto <= 20)
|
|
|
|
|
{
|
|
|
|
|
return $many;
|
|
|
|
|
}
|
|
|
|
|
my $r = $count % 10;
|
|
|
|
|
if ($r == 1)
|
|
|
|
|
{
|
|
|
|
|
return $one;
|
|
|
|
|
}
|
|
|
|
|
elsif ($r >= 2 && $r <= 4)
|
|
|
|
|
{
|
|
|
|
|
return $few;
|
|
|
|
|
}
|
|
|
|
|
return $many;
|
|
|
|
|
}
|
|
|
|
|
|
|
|
|
|
# Limit string to $maxlen
|
|
|
|
|
sub strlimit
|
|
|
|
|
{
|
|
|
|
|
my ($str, $maxlen, $dots) = @_;
|
|
|
|
|
if (!$maxlen || $maxlen < 1 || length($str) <= $maxlen)
|
|
|
|
|
{
|
|
|
|
|
return $str;
|
|
|
|
|
}
|
|
|
|
|
$str = substr($str, 0, $maxlen);
|
|
|
|
|
my $p = rindex($str, ' ');
|
|
|
|
|
if ($p < 0 || (my $pt = rindex($str, "\t")) > $p)
|
|
|
|
|
{
|
|
|
|
|
$p = $pt;
|
|
|
|
|
}
|
|
|
|
|
if ($p > 0)
|
|
|
|
|
{
|
|
|
|
|
$str = substr($str, 0, $p);
|
|
|
|
|
}
|
|
|
|
|
return $str . (defined $dots ? $dots : '...');
|
|
|
|
|
}
|
|
|
|
|
|
|
|
|
|
# Replace (some) tags with whitespace
|
|
|
|
|
sub strip_tags
|
|
|
|
|
{
|
|
|
|
|
my ($str, $allowed) = @_;
|
|
|
|
|
my $allowed = $allowed ? '(?!/?('.$allowed.'))' : '';
|
|
|
|
|
$str =~ s/(<$allowed\/?[a-z][a-z0-9-]*(\s+[^<>]*)?>\s*)+/ /gis;
|
|
|
|
|
return $str;
|
|
|
|
|
}
|
|
|
|
|
|
|
|
|
|
# Add '\' before specified chars
|
|
|
|
|
sub addcslashes
|
|
|
|
|
{
|
|
|
|
|
my ($str, $escape) = @_;
|
|
|
|
|
$str =~ s/([$escape])/\\$1/gs;
|
|
|
|
|
return $str;
|
|
|
|
|
}
|