#!/usr/bin/perl

package VMXTemplate::Compiler;

use strict;
use VMXTemplate::Utils;
use VMXTemplate::Lexer;

sub _Lexer
{
    my ($parser) = shift;
    return $parser->{lexer}->read_token;
}

sub _error
{
    my ($self) = @_;
    if ($self->YYCurtok ne 'error')
    {
        $self->{lexer}->warn('Unexpected ' . $self->YYCurtok . ($self->YYCurval ? ' ' . $self->YYCurval : ''));
    }
    $self->{lexer}->skip_error;
}

sub compile
{
    my ($self, $text) = @_;
    $self->{lexer} ||= VMXTemplate::Lexer->new($self->{options});
    $self->{lexer}->set_code($text);
    $self->{functions} = {
        ':main' => {
            name => ':main',
            args => [],
            body => '',
            line => 0,
            pos => 0,
        },
    };
    $self->YYParse(yylex => \&_Lexer, yyerror => \&_error);
    if (!$self->{functions}->{':main'}->{body})
    {
        # Parse error?
        delete $self->{functions}->{':main'};
    }
    return ($self->{options}->{use_utf8} ? "use utf8;\n" : "").
        ($self->{options}->{input_filename} ? "# $self->{options}->{input_filename}\n" : '').
        "{\n':version' => ".VMXTemplate->CODE_VERSION.",\n".
        join(",\n", map { "'$_->{name}' => $_->{body}" } values %{$self->{functions}})."};\n";
}

# Function aliases
my $functions = {
    i                   => 'int',
    intval              => 'int',
    lower               => 'lc',
    lowercase           => 'lc',
    upper               => 'uc',
    uppercase           => 'uc',
    addslashes          => 'quote',
    q                   => 'quote',
    re_quote            => 'requote',
    preg_quote          => 'requote',
    uri_escape          => 'urlencode',
    uriquote            => 'urlencode',
    substring           => 'substr',
    htmlspecialchars    => 'html',
    s                   => 'html',
    strip_tags          => 'strip',
    t                   => 'strip',
    h                   => 'strip_unsafe',
    sq                  => 'sql_quote',
    implode             => 'join',
    truncate            => 'strlimit',
    hash_keys           => 'keys',
    array_keys          => 'keys',
    array_slice         => 'subarray',
    hget                => 'get',
    aget                => 'get',
    var_dump            => 'dump',
    process             => 'parse',
    include             => 'parse',
    process_inline      => 'parse_inline',
    include_inline      => 'parse_inline',
    subarray            => 'array_slice',
    subarray_divmod     => 'array_div',
};

# Function result "safeness" constants:
# N > 0 means "safe if Nth argument is safe"
use constant Q_ALWAYS => -1; # always safe
use constant Q_IF_ALL => -2; # safe if all arguments are safe
use constant Q_ALL_BUT_FIRST => -3; # safe if all arguments except first are safe; first may be safe or unsafe
use constant Q_ALWAYS_NUM => -4; # always safe, returns numeric values
use constant Q_PASS => -5; # pass safeness to function

my $functionSafeness = {
    int                 => Q_ALWAYS_NUM,
    raw                 => Q_ALWAYS,
    html                => Q_ALWAYS,
    strip               => Q_ALWAYS,
    strip_unsafe        => Q_ALWAYS,
    parse               => Q_ALWAYS,
    parse_inline        => Q_ALWAYS,
    exec                => Q_ALWAYS,
    exec_from           => Q_ALWAYS,
    exec_from_inline    => Q_ALWAYS,
    quote               => Q_ALWAYS,
    sql_quote           => Q_ALWAYS,
    requote             => Q_ALWAYS,
    urlencode           => Q_ALWAYS,
    and                 => Q_ALWAYS,
    or                  => Q_IF_ALL,
    not                 => Q_ALWAYS_NUM,
    add                 => Q_ALWAYS_NUM,
    sub                 => Q_ALWAYS_NUM,
    mul                 => Q_ALWAYS_NUM,
    div                 => Q_ALWAYS_NUM,
    mod                 => Q_ALWAYS_NUM,
    min                 => Q_IF_ALL_PASS,
    max                 => Q_IF_ALL_PASS,
    round               => Q_ALWAYS_NUM,
    log                 => Q_ALWAYS_NUM,
    even                => Q_ALWAYS_NUM,
    odd                 => Q_ALWAYS_NUM,
    eq                  => Q_ALWAYS_NUM,
    ne                  => Q_ALWAYS_NUM,
    gt                  => Q_ALWAYS_NUM,
    lt                  => Q_ALWAYS_NUM,
    ge                  => Q_ALWAYS_NUM,
    le                  => Q_ALWAYS_NUM,
    seq                 => Q_ALWAYS_NUM,
    sne                 => Q_ALWAYS_NUM,
    sgt                 => Q_ALWAYS_NUM,
    slt                 => Q_ALWAYS_NUM,
    sge                 => Q_ALWAYS_NUM,
    sle                 => Q_ALWAYS_NUM,
    neq                 => Q_ALWAYS_NUM,
    nne                 => Q_ALWAYS_NUM,
    ngt                 => Q_ALWAYS_NUM,
    nlt                 => Q_ALWAYS_NUM,
    nge                 => Q_ALWAYS_NUM,
    nle                 => Q_ALWAYS_NUM,
    strlen              => Q_ALWAYS_NUM,
    strftime            => Q_ALWAYS,
    str_replace         => Q_ALL_BUT_FIRST,
    substr              => 1,   # parameter number to take safeness from
    trim                => 1,
    split               => 1,
    nl2br               => 1,
    concat              => Q_IF_ALL,
    join                => Q_IF_ALL,
    subst               => Q_IF_ALL,
    strlimit            => 1,
    plural_ru           => Q_ALL_BUT_FIRST,
    hash                => Q_IF_ALL,
    keys                => 1,
    values              => 1,
    sort                => 1,
    pairs               => 1,
    array               => Q_IF_ALL,
    range               => Q_ALWAYS,
    is_array            => Q_ALWAYS_NUM,
    count               => Q_ALWAYS_NUM,
    array_slice         => 1,
    array_div           => 1,
    set                 => 2,
    array_merge         => Q_IF_ALL,
    shift               => 1,
    pop                 => 1,
    unshift             => Q_ALWAYS,
    push                => Q_ALWAYS,
    void                => Q_ALWAYS,
    json                => Q_ALWAYS,
    map                 => Q_ALL_BUT_FIRST,
    yesno               => Q_ALL_BUT_FIRST,
};

my $forceSubst = {
    parse               => 1,
    parse_inline        => 1,
    exec                => 1,
    exec_from           => 1,
    exec_from_inline    => 1,
};

# Generate semantic expression for template function call
sub compile_function
{
    my $self = shift;
    my ($fn, $args) = @_;
    $fn = lc $fn;
    if ($functions->{$fn})
    {
        # Function alias
        $fn = $functions->{$fn};
    }
    # Calculate HTML safeness flag
    my $fl = $functionSafeness->{$fn};
    my $q;
    if ($fl > 0)
    {
        $q = exists $args->[$fl-1] ? $args->[$fl-1]->[1] : 1;
    }
    elsif ($fl == Q_ALWAYS)
    {
        $q = 1;
    }
    elsif ($fl == Q_ALWAYS_NUM)
    {
        $q = 'i';
    }
    elsif ($fl != Q_PASS)
    {
        $q = 1;
        my $n = scalar @$args;
        for (my $i = ($fl == Q_ALL_BUT_FIRST ? 1 : 0); $i < $n; $i++)
        {
            $q = $q && $args->[$i]->[1];
        }
    }
    my $argv = $fl == Q_PASS ? [ map { $_->[0] } @$args ] : $argv;
    my $r;
    if ($self->can(my $ffn = "function_$fn"))
    {
        # Builtin function call using name
        $r = $self->$ffn(@$argv);
    }
    elsif (my $ffn = $self->{options}->{compiletime_functions}->{$fn})
    {
        # Custom compile-time function call
        $r = &$ffn($self, @$argv);
    }
    else
    {
        $self->{lexer}->warn("Unknown function: '$fn'");
        $r = $fl == Q_PASS ? [ "''", 1 ] : "''";
    }
    $r = [ $r, $q ] if $fl != Q_PASS;
    push @$r, 1 if $forceSubst->{$fn};
    return $r;
}

# call operator on arguments
sub fmop
{
    my $op = shift;
    my $self = shift;
    return "((" . join(") $op (", @_) . "))";
}

# call function, expanding all passed arrays
sub fearr
{
    my $f = shift;
    my $n = shift;
    my $self = shift;
    my $e = "$f(";
    $e .= join(", ", splice(@_, 0, $n)) if $n;
    $e .= ", " if $n && @_;
    $e .= join(", ", map { "array_items($_)" } @_);
    $e .= ")";
    return $e;
}

### Function implementations

## Numeric/Logical

# logical
sub function_or      { fmop('||', @_) }
sub function_and     { fmop('&&', @_) }
sub function_not     { "!($_[1])" }
# arithmetic
sub function_add     { fmop('+', @_) }
sub function_sub     { fmop('-', @_) }
sub function_mul     { fmop('*', @_) }
sub function_div     { fmop('/', @_) }
sub function_mod     { fmop('%', @_) }
# min, max
sub function_min     { (grep { $_->[1] ne 'i' } @_ ? 'str_' : '')."min(".join(', ', map { $_->[0] } @_).")" }
sub function_max     { (grep { $_->[1] ne 'i' } @_ ? 'str_' : '')."max(".join(', ', map { $_->[0] } @_).")" }
sub function_round   { "round($_[1])" }
# logarithm
sub function_log     { "log($_[1])" }
# is the argument even/odd?
sub function_even    { "!(($_[1]) & 1)" }
sub function_odd     { "(($_[1]) & 1)" }
# cast to integer, throwing away the fractional part
sub function_int     { "int($_[1])" }
# type-dependent comparisons: = != > < >= <=
sub function_eq      { "(exec_cmp($_[1], $_[2]) == 0)" }
sub function_ne      { "(exec_cmp($_[1], $_[2]) != 0)" }
sub function_gt      { "(exec_cmp($_[1], $_[2]) > 0)" }
sub function_lt      { "(exec_cmp($_[1], $_[2]) < 0)" }
sub function_ge      { "(exec_cmp($_[1], $_[2]) >= 0)" }
sub function_le      { "(exec_cmp($_[1], $_[2]) <= 0)" }
# string comparisons: = != > < >= <=
sub function_seq     { "(($_[1]) eq ($_[2]))" }
sub function_sne     { "(($_[1]) ne ($_[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]))" }
# numeric comparisons: = != > < >= <=
sub function_neq     { "(($_[1]) == ($_[2]))" }
sub function_nne     { "(($_[1]) != ($_[2]))" }
sub function_ngt     { "(($_[1]) >  ($_[2]))" }
sub function_nlt     { "(($_[1]) <  ($_[2]))" }
sub function_nge     { "(($_[1]) >= ($_[2]))" }
sub function_nle     { "(($_[1]) <= ($_[2]))" }
# ternary operator $1 ? $2 : $3
sub function_yesno   { "(($_[1]) ? ($_[2]) : ($_[3]))" }

## String

# lowercase, uppercase
sub function_lc             { "lc($_[1])" }
sub function_uc             { "uc($_[1])" }
# lowercase, uppercase the first letter
sub function_lcfirst        { "lcfirst($_[1])" }
sub function_ucfirst        { "ucfirst($_[1])" }
# quote ', ", \, \n and \r in C-style, prepending \
sub function_quote          { "quotequote($_[1])" }
# quote " in SQL/CSV style (by doubling them)
sub function_sql_quote      { "sql_quote($_[1])" }
# escape characters special to regular expressions
sub function_requote        { "requote($_[1])" }
# encode URL parameter
sub function_urlencode      { "urlencode($_[1])" }
# decode URL parameter
sub function_urldecode      { "urldecode($_[1])" }
# replace regexp: replace(<regex>, <replacement>, <subject>)
sub function_replace        { "regex_replace($_[1], $_[2], $_[3])" }
# replace substrings
sub function_str_replace    { "str_replace($_[1], $_[2], $_[3])" }
# character length of string
sub function_strlen         { "strlen($_[1])" }
# substring
sub function_substr         { shift; "substr(".join(",", @_).")" }
# remove starting and ending whitespace
sub function_trim           { shift; "trim($_[0])" }
# splice $2 with regexp $1, optionally maximum to $3 parts
sub function_split          { shift; "split(".join(",", @_).")" }
# replace & < > " ' with HTML entities
sub function_html           { "htmlspecialchars($_[1])" }
# remove HTML tags
sub function_strip          { "strip_tags($_[1])" }
# remove "unsafe" HTML tags
sub function_strip_unsafe   { "strip_unsafe_tags($_[1])" }
# replace \n with <br />
sub function_nl2br          { "regex_replace(qr/\\n/s, '<br />', $_[1])" }
# concatenate strings
sub function_concat         { fmop('.', @_) }
# join strings with delimiter specified as the first argument; expands all passed arrays
sub function_join           { fearr('join', 1, @_) }
# replace $1, $2 etc with passed arguments
sub function_subst          { fearr('exec_subst', 1, @_) }
# sprintf
sub function_sprintf        { fearr('sprintf', 1, @_) }
# strftime
sub function_strftime
{
    my $self = shift;
    my ($fmt, $date, $time) = @_;
    if ($date)
    {
        $date = "($date).' '.($time)" if $time;
        $date = "timestamp($date)";
    }
    else
    {
        $date = '';
    }
    $date = "POSIX::strftime($fmt, localtime($date))";
    $date = "utf8on($date)" if $self->{use_utf8};
    return $date;
}
# limit $1 with $2 chars on whitespace boundary and add $3 (or '...' by default) if it is longer
sub function_strlimit       { shift; "strlimit(".join(",", @_).")" }
# select one of 3 russian plural forms based on first numeric argument: plural_ru($number, $one, $few, $many)
sub function_plural_ru      { shift; "plural_ru(".join(",", @_).")" }

## Arrays and hashes

# create a hash
sub function_hash           { shift; @_ == 1 ? "{ \@{ $_[0] } }" : "{" . join(",", @_) . "}"; }
# hash keys
sub function_keys           { '[ keys(%{'.$_[1].'}) ]'; }
# hash values
sub function_values         { '[ values(%{'.$_[1].'}) ]'; }
# sort array
sub function_sort           { '[ '.fearr('sort', 0, @_).' ]'; }
# extract [ { key => <key>, value => <value> }, ... ] pairs from first hash argument
sub function_pairs          { "exec_pairs($_[1])" }
# create an array
sub function_array          { shift; "[" . join(",", @_) . "]"; }
# create a numeric range array
sub function_range          { "[ $_[1] .. $_[2] ]" }
# check if the argument is an array
sub function_is_array       { "exec_is_array($_[1])" }
# count array (not hash) elements
sub function_count          { "(ref($_[1]) && $_[1] =~ /ARRAY/so ? scalar(\@{ $_[1] }) : 0)" }
# extract a contiguous slice of array
sub function_array_slice    { shift; "array_slice(" . join(",", @_) . ")"; }
# extract a regular slice of array
sub function_array_div      { shift; "array_div(" . join(",", @_) . ")"; }
# get array or hash element using a variable key (i.e. get(iteration.array, rand(5)))
sub function_get            { shift; "exec_get(" . join(",", @_) . ")"; }
# same only for hash
sub function_hget           { "($_[1])->\{$_[2]}" }
# same only for array
sub function_aget           { "($_[1])->\[$_[2]]" }
# set first argument to second (first argument must be an "lvalue")
sub function_set            { "scalar(($_[1] = $_[2]), '')" }
# merge arrays into one
sub function_array_merge    { shift; '[@{'.join('},@{',@_).'}]' }
# extract first argument of an array
sub function_shift          { "shift(\@{$_[1]})"; }
# extract last argument of an array
sub function_pop            { "pop(\@{$_[1]})"; }
# insert into beginning of an array
sub function_unshift        { shift; "unshift(\@{".shift(@_)."}, ".join(",", @_).")"; }
# insert into end of an array
sub function_push           { shift; "push(\@{".shift(@_)."}, ".join(",", @_).")"; }

## Misc

# explicitly ignore expression result (like void() in javascript)
sub function_void           { "scalar(($_[1]), '')" }
# dump variable
sub function_dump           { shift; "var_dump(" . join(",", @_) . ")" }
# encode into JSON
sub function_json           { "encode_json($_[1])" }
# return the value as is, to ignore automatic escaping of "unsafe" HTML
sub function_raw            { $_[1] }
# call object method using variable name and inline arguments
sub function_call
{
    my $self = shift;
    my $obj = shift;
    my $method = shift;
    return "[ map { scalar ($obj)->\$_(".join(",", @_).") } $method ]->[0]";
}
# call object method using variable name and array arguments
sub function_call_array
{
    my ($self, $obj, $method, $args) = @_;
    return "[ map { scalar ($obj)->\$_(\@\{$args}) } $method ]->[0]";
}

# apply the function to each array element
sub function_map
{
    my $self = shift;
    my $fn = shift;
    if ($fn =~ /^[\"\'](\w+)[\"\']$/so)
    {
        return '(map { '.$self->compile_function($1, '$_').' } (@{'.join('}, @{', @_).'}))';
    }
    else
    {
        $self->{lexer}->warn("Non-constant function: unimplemented");
    }
}

## Template inclusion

# Include another template: parse('file.tpl'[, <args>])
# In all inclusion functions <args> may be a hash ref of a list of key+value pairs
# All modifications to <args> (or to current global "template vars") done
# by the included template are preserved after processing it!
sub function_parse
{
    my $self = shift;
    my $file = shift;
    $self->{lexer}->warn("include() requires at least 1 parameter"), return "''" if !$file;
    my $args = @_ > 1 ? "{ ".join(", ", @_)." }" : (@_ ? $_[0] : '');
    return "\$self->parse_real($file, undef, ':main', $args)";
}

# Run block from current template: exec('block'[, <args>])
sub function_exec
{
    my $self = shift;
    my $block = shift;
    $self->{lexer}->warn("exec() requires at least 1 parameters"), return "''" if !$block;
    my $args = @_ > 1 ? "{ ".join(", ", @_)." }" : (@_ ? $_[0] : 'undef');
    return "\$self->_call_block($block, $args, '".addcslashes($self->{lexer}->errorinfo(), "'")."')";
}

# Run block from another template: exec_from('file.tpl', 'block'[, args])
sub function_exec_from
{
    my $self = shift;
    my $file = shift;
    my $block = shift;
    $self->{lexer}->warn("exec_from() requires at least 2 parameters"), return "''" if !$file || !$block;
    my $args = @_ > 1 ? "{ ".join(", ", @_)." }" : (@_ ? $_[0] : '');
    return "\$self->parse_real($file, undef, $block, $args)";
}

# (Not recommended, but possible)
# Parse string as a template: parse_inline('code'[, args])
sub function_parse_inline
{
    my $self = shift;
    my $code = shift;
    $self->{lexer}->warn("parse_inline() requires at least 1 parameter"), return "''" if !$code;
    my $args = @_ > 1 ? "{ ".join(", ", @_)." }" : (@_ ? $_[0] : '');
    return "\$self->parse_real(undef, $code, ':main', $args)";
}

# (Highly not recommended, but still possible)
# Parse string as a template and run a named block from it: exec_from_inline('code', 'block'[, args])
sub function_exec_from_inline
{
    my $self = shift;
    my $code = shift;
    my $block = shift;
    $self->{lexer}->warn("exec_from_inline() requires at least 2 parameters"), return "''" if !$code || !$block;
    my $args = @_ > 1 ? "{ ".join(", ", @_)." }" : (@_ ? $_[0] : '');
    return "\$self->parse_real(undef, $code, $block, $args)";
}

1;