File Coverage

blib/lib/Template/Sandbox.pm

Criterion	Covered	Total	%
statement	1130	1145	98.6
branch	588	642	91.5
condition	192	225	85.3
subroutine	90	90	100.0
pod	47	47	100.0
total	2047	2149	95.2

#
#  Template::Sandbox: Yet Another Template System.
#
#  Known issues:
#    - ${VALUE} define replacement breaks char-count and potentially
#      line count values (if ${VALUE} has newlines).
#
#  Future ideas:
#

package Template::Sandbox;

use strict;
use warnings;

use Carp;
use Class::Handle;
use Clone;
use Data::Dumper;
use Digest::MD5;
use IO::File;
use File::Spec;
use Log::Any;
use Scalar::Util;
use Storable;
#use Time::HiRes;

#my ( @function_table );

#  Array indices.
sub SELF()   { 0; }
sub OP_LHS() { 1; }
sub OP_RHS() { 2; }

#  Compiled line indices.
#  TODO: currently unused.
sub LINE_INSTR() { 0; }
sub LINE_POS()   { 1; }
sub LINE_ARG()   { 2; }

#  Instruction opcodes.
sub LITERAL()      { 0; }
sub DEBUG()        { 1; }
sub EXPR()         { 2; }
sub JUMP()         { 3; }
sub JUMP_IF()      { 4; }
sub FOR()          { 5; }
sub END_FOR()      { 6; }
sub CONTEXT_PUSH() { 7; }
sub CONTEXT_POP()  { 8; }

#  Starting point for opcodes for locally registered syntaxes.
sub LOCAL_SYNTAX() { 1_000_000; }

#  Expression opcodes.
sub OP_TREE()  { 100; }
sub UNARY_OP() { 101; }
sub FUNC()     { 102; }
sub METHOD()   { 103; }
sub VAR()      { 104; }
sub TEMPLATE() { 105; }

#  Template function array indices.
sub FUNC_FUNC()           { 0; }
sub FUNC_ARG_NUM()        { 1; }
sub FUNC_NEEDS_TEMPLATE() { 2; }
sub FUNC_INCONST()        { 3; }
sub FUNC_UNDEF_OK()       { 4; }

#  Special values in loop vars.
sub LOOP_COUNTER()        { 0; };
sub LOOP_EVEN()           { 1; };
sub LOOP_ODD()            { 2; };
sub LOOP_FIRST()          { 3; };
sub LOOP_INNER()          { 4; };
sub LOOP_LAST()           { 5; };
sub LOOP_PREV()           { 6; };
sub LOOP_NEXT()           { 7; };
sub LOOP_VALUE()          { 8; };

my %special_values_names = (
    __counter__ => LOOP_COUNTER,
    __even__    => LOOP_EVEN,
    __odd__     => LOOP_ODD,
    __first__   => LOOP_FIRST,
    __inner__   => LOOP_INNER,
    __last__    => LOOP_LAST,
    __prev__    => LOOP_PREV,
    __next__    => LOOP_NEXT,
    __value__   => LOOP_VALUE,
    );

sub LOOP_STACK_COUNTER()  { 0; }
sub LOOP_STACK_LAST()     { 1; }
sub LOOP_STACK_SET()      { 2; }
sub LOOP_STACK_HASH()     { 3; }
sub LOOP_STACK_CONTEXT()  { 4; }
sub LOOP_STACK_SPECIALS() { 5; }

#  The lower the weight the tighter it binds.
my %operators = (
    #  Logic operators
    'or'  => [ 100, sub { $_[ SELF ]->_eval_expression( $_[ OP_LHS ], 1 ) or
                          $_[ SELF ]->_eval_expression( $_[ OP_RHS ], 1 ) },
               1 ],
    'and' => [ 99,  sub { $_[ SELF ]->_eval_expression( $_[ OP_LHS ], 1 ) and
                          $_[ SELF ]->_eval_expression( $_[ OP_RHS ], 1 ) },
               1 ],
    '||'  => [ 98,  sub { $_[ SELF ]->_eval_expression( $_[ OP_LHS ], 1 ) ||
                          $_[ SELF ]->_eval_expression( $_[ OP_RHS ], 1 ) },
               1 ],
    '&&'  => [ 96,  sub { $_[ SELF ]->_eval_expression( $_[ OP_LHS ], 1 ) &&
                          $_[ SELF ]->_eval_expression( $_[ OP_RHS ], 1 ) },
               1 ],
    #  Comparison operators
    'cmp' => [ 95,  sub { $_[ OP_LHS ] cmp $_[ OP_RHS ] } ],
    'ne'  => [ 94,  sub { $_[ OP_LHS ] ne  $_[ OP_RHS ] ? 1 : 0 } ],
    'eq'  => [ 93,  sub { $_[ OP_LHS ] eq  $_[ OP_RHS ] ? 1 : 0 } ],
    '<=>' => [ 92,  sub { $_[ OP_LHS ] <=> $_[ OP_RHS ] } ],
    '!='  => [ 91,  sub { $_[ OP_LHS ] !=  $_[ OP_RHS ] ? 1 : 0 } ],
    '=='  => [ 90,  sub { $_[ OP_LHS ] ==  $_[ OP_RHS ] ? 1 : 0 } ],
    'ge'  => [ 89,  sub { $_[ OP_LHS ] ge  $_[ OP_RHS ] ? 1 : 0 } ],
    'le'  => [ 88,  sub { $_[ OP_LHS ] le  $_[ OP_RHS ] ? 1 : 0 } ],
    'gt'  => [ 87,  sub { $_[ OP_LHS ] gt  $_[ OP_RHS ] ? 1 : 0 } ],
    'lt'  => [ 86,  sub { $_[ OP_LHS ] lt  $_[ OP_RHS ] ? 1 : 0 } ],
    '>='  => [ 85,  sub { $_[ OP_LHS ] >=  $_[ OP_RHS ] ? 1 : 0 } ],
    '<='  => [ 84,  sub { $_[ OP_LHS ] <=  $_[ OP_RHS ] ? 1 : 0 } ],
    '>'   => [ 83,  sub { $_[ OP_LHS ] >   $_[ OP_RHS ] ? 1 : 0 } ],
    '<'   => [ 82,  sub { $_[ OP_LHS ] <   $_[ OP_RHS ] ? 1 : 0 } ],

    #  Assignment
    '='   => [ 75,  sub { $_[ SELF ]->_assign_var( $_[ OP_LHS ],
                              $_[ SELF ]->_eval_expression( $_[ OP_RHS ] ) )
                        },
               1 ],

    #  Arithmetic/concat
    '.'   => [ 70,  sub { $_[ OP_LHS ] .  $_[ OP_RHS ] } ],
    '+'   => [ 69,  sub { $_[ OP_LHS ] +  $_[ OP_RHS ] } ],
    '-'   => [ 68,  sub { $_[ OP_LHS ] -  $_[ OP_RHS ] } ],
    '%'   => [ 67,  sub { $_[ OP_LHS ] %  $_[ OP_RHS ] } ],
    '/'   => [ 66,  sub { $_[ OP_LHS ] /  $_[ OP_RHS ] } ],
    '*'   => [ 65,  sub { $_[ OP_LHS ] *  $_[ OP_RHS ] } ],
    );

sub def_func
{
    my ( $ret, $flag, $val ) = @_;
    $ret = [ $ret ] if ref( $ret ) ne 'ARRAY';
    $ret->[ $flag ] = $val;
#warn "def_func: ..." . _tersedump( $ret );
    return( $ret );
}

sub inconstant { return( def_func( @_, FUNC_INCONST, 1 ) ); }
sub needs_template { return( def_func( @_, FUNC_NEEDS_TEMPLATE, 1 ) ); }
sub undef_ok   { return( def_func( @_, FUNC_UNDEF_OK, 1 ) ); }
sub has_args   { return( def_func( $_[ 0 ], FUNC_ARG_NUM, $_[ 1 ] ) ); }
sub no_args    { return( has_args( @_, 0 ) ); }
sub one_arg    { return( has_args( @_, 1 ) ); }
sub two_args   { return( has_args( @_, 2 ) ); }
sub three_args { return( has_args( @_, 3 ) ); }
sub any_args   { return( has_args( @_, -1 ) ); }


#  These void() and size() are required since they get used internally
#  for certain backwards-compat behaviours/syntax sugars.
#  defined() is required by the test suite, so it stays here too.
my %functions = (
    #  Takes any arg and returns '', useful for hiding expression results.
    void    => ( any_args sub { '' } ),

    size    => ( one_arg
        sub
        {
            return( undef ) unless defined( $_[ 0 ] );
            my $type = Scalar::Util::reftype( $_[ 0 ] );
            return( $type eq 'HASH'   ? scalar( keys( %{$_[ 0 ]} ) ) :
                    $type eq 'ARRAY'  ? scalar( @{$_[ 0 ]} ) :
                    $type eq 'SCALAR' ? length( ${$_[ 0 ]} ) :
                                        length( $_[ 0 ] ) );
        } ),

    defined => ( one_arg undef_ok sub { defined( $_[ 0 ] ) ? 1 : 0 } ),
    );

#print "Content-type: text/plain\n\n" . Data::Dumper::Dumper( \%functions );

my %token_aliases = (
    'foreach'     => 'for',
    'end for'     => 'endfor',
    'endforeach'  => 'endfor',
    'end foreach' => 'endfor',
    'end include' => 'endinclude',
    'els if'      => 'elsif',
    'else if'     => 'elsif',
    'elseif'      => 'elsif',
    'end if'      => 'endif',
    'els unless'  => 'elsunless',
    'else unless' => 'elsunless',
    'elseunless'  => 'elsunless',
    'end unless'  => 'endunless',
    );

#  zero_width => boolean,
#    Zero-width tokens gobble one of the surrounding \n if they're
#    on a line by themselves, preventing "blank-line spam" in the
#    template output.
#  TODO: move syntaxes into substructure to avoid .key hackery.
my %syntaxes = (
    #  Faux values to define the auto opcode generation for local syntaxes.
    '.next_instr'      => LOCAL_SYNTAX,
    '.instr_increment' => 1,
    '.instr'           => {},

    #  Actual syntax definitions.
    'var'     => {
        positional_args => [ 'var' ],
        valid_args      => [ 'var' ],
        },
    'debug'   => {
        positional_args => [ 'type', 'state' ],
        valid_args      => [ 'type', 'state' ],
        zero_width => 1,
        },
    '#'       => {
        zero_width => 1,
        },
    'include' => {
        positional_args => [ 'filename' ],
        zero_width => 1,
        },
    'endinclude'      => {
        zero_width => 1,
        },
    'for'     => {
        zero_width => 1,
        },
    'endfor'      => {
        zero_width => 1,
        },
    'if'      => {
        zero_width => 1,
        },
    'unless'  => {
        zero_width => 1,
        },
    'else'      => {
        zero_width => 1,
        },
    'elsif'      => {
        zero_width => 1,
        },
    'elsunless'      => {
        zero_width => 1,
        },
    'endif'      => {
        zero_width => 1,
        },
    'endunless'      => {
        zero_width => 1,
        },
    );

#  Special vars that are symbolic literals.
my %symbolic_literals = (
    'undef' => [ LITERAL, 'undef', undef ],
    'null'  => [ LITERAL, 'null',  undef ],
    'cr'    => [ LITERAL, 'cr', "\n" ],
    );

#  "our" declarations are to work around problem in some perls where
#  "my" scope variables aren't seen by (??{ ... }).
our ( $single_quoted_text_regexp );

$single_quoted_text_regexp = qr/
    \'
    (?:
        #  Quoteless, backslashless text.
        (?> [^\'\\]+ )
        |
        #  Escaped characters.
        (?> (?:\\\\)* \\ . )
    )*
    \'
    /sxo;

our ( $double_quoted_text_regexp );

$double_quoted_text_regexp = qr/
    \"
    (?:
        #  Quoteless, backslashless text.
        (?> [^\"\\]+ )
        |
        #  Escaped characters.
        (?> (?:\\\\)* \\ . )
    )*
    \"
    /sxo;

our ( $matching_square_brackets_regexp );

$matching_square_brackets_regexp = qr/
    \[
    (?:
        #  Bracketless, quoteless subtext.
        (?> [^\[\]\"\']+ )
        |
        #  Quoted text.
        (??{ $double_quoted_text_regexp }) |
        (??{ $single_quoted_text_regexp })
        |
        #  Expression containing sub-brackets.
        (??{ $matching_square_brackets_regexp })
    )*
    \]
    /sxo;

our ( $matching_round_brackets_regexp );

$matching_round_brackets_regexp = qr/
    \(
    (?:
        #  Bracketless, quoteless subtext.
        (?> [^\(\)\"\']+ )
        |
        #  Quoted text.
        (??{ $double_quoted_text_regexp }) |
        (??{ $single_quoted_text_regexp })
        |
        #  Expression containing sub-brackets.
        (??{ $matching_round_brackets_regexp })
    )*
    \)
    /sxo;

my $bare_identifier_regexp = qr/
    [a-zA-Z_][a-zA-Z0-9_]*
    /sxo;

my $function_regexp = qr/
    #  abc( expr )
    $bare_identifier_regexp
    $matching_round_brackets_regexp
    /sxo;

my $capture_function_regexp = qr/
    ^
    #  abc( expr )
    ($bare_identifier_regexp)
    \(
    \s*
    (.*?)
    \s*
    \)
    $
    /sxo;

#  Chained structure:
#  var.sub.sub
#  var.sub['sub']
#  var['sub'].sub
#  var['sub']['sub'] fails!
#  var.sub.method()
#  var['sub'].method()
#  var.method().sub
#  var.method()['sub']
#  func().sub.sub ?
#  func().method().sub

my $subscript_operator_regexp = qr/
    (?: \. | \-\> )
    /sxo;

my $expr_subscript_regexp    = $matching_square_brackets_regexp;
my $capture_expr_subscript_regexp = qr/
    ^
    \[
    \s*
    (.*?)
    \s*
    \]
    $
    /sxo;
my $literal_subscript_regexp = qr/
    $subscript_operator_regexp
    $bare_identifier_regexp
    /sxo;
my $capture_literal_subscript_regexp = qr/
    ^
    $subscript_operator_regexp
    ($bare_identifier_regexp)
    $
    /sxo;
my $method_subscript_regexp  = qr/
    $subscript_operator_regexp
    $function_regexp
    /sxo;
my $capture_method_subscript_regexp = qr/
    ^
    #  . | ->
    $subscript_operator_regexp
    #  abc( expr )
    ($bare_identifier_regexp)
    \(
    \s*
    (.*?)
    \s*
    \)
#    ($matching_round_brackets_regexp)
    $
    /sxo;

my $chained_operation_top_regexp = qr/
    (?:
    #  Function goes first to take matching precedence over bareword
    $function_regexp |
    $bare_identifier_regexp
    )
    /sxo;
my $chained_operation_subscript_regexp = qr/
    (?:
    $expr_subscript_regexp |
    #  Method goes first to take matching precedence over bareword
    $method_subscript_regexp |
    $literal_subscript_regexp
    )
    /sxo;
my $chained_operation_regexp = qr/
    $chained_operation_top_regexp
    (?: $chained_operation_subscript_regexp )*
    /sxo;

my $capture_chained_operation_top_regexp = qr/
    ^
    ($chained_operation_top_regexp)
    #  we don't care at this point what the rest of the crud is.
    (.*)
    $
    /sxo;
my $capture_chained_operation_subscript_regexp = qr/
    ^
    ($chained_operation_subscript_regexp)
    #  we don't care at this point what the rest of the crud is.
    (.*)
    $
    /sxo;

my $literal_number_regexp = qr/
    #  1 or more digits.
    \d+
    #  Optionally a decimal fraction.
    (?: \. \d+ )?
    /sxo;

my $unary_operator_regexp = qr/
    (?: \! | not (?=\s) | - )
    /sxo;
my $capture_unary_operator_regexp = qr/
    ^
    ( \! | not (?=\s) | - )
    \s*
    (.*)
    $
    /sxo;

my $atomic_expr_regexp = qr/
    #  Optionally a unary operator
    (?: $unary_operator_regexp \s* )?
    #  Followed by an atomic value
    (?:
        #  A bracketed sub-expression.
        $matching_round_brackets_regexp
        |
        #  A chained operation.
        $chained_operation_regexp
        |
        #  A literal number
        $literal_number_regexp
        |
        #  A literal string
        $single_quoted_text_regexp
    )
    /sxo;

my $operator_regexp = join( '|', map { "\Q$_\E" } keys( %operators ) );
$operator_regexp = qr/
    (?: $operator_regexp )
    /sxo;

my $expr_regexp = qr/
    \s*
    (?:
        #  A sequence of atomic epressions and operators.
        $atomic_expr_regexp
        (?:
            \s+
            $operator_regexp
            \s+
            $atomic_expr_regexp
        )*
    )
    \s*
    /sxo;
#            (?:
#                \s+
#                $operator_regexp
#                \s+
#                $atomic_expr_regexp
#            )
#            |
#            (?:
#                \s+
#                \?
#                \s+
#                $atomic_expr_regexp
#                \s+
#                \:
#                $atomic_expr_regexp
#            )

my $capture_expr_op_remain_regexp = qr/
    ^
    \s*
    ($atomic_expr_regexp)
    \s+
    ($operator_regexp)
    \s+
    (.*)
    $
    /sxo;

#my $capture_expr_if_else_remain_regexp = qr/
#    ^
#    \s*
#    ($atomic_expr_regexp)
#    \s+ \? \s+
#    ($atomic_expr_regexp)
#    \s+ \: \s+
#    ($atomic_expr_regexp)
#    \s*
#    (.*?)
#    \s*
#    $
#    /sx;

my $capture_expr_comma_remain_regexp = qr/
    ^
    ($expr_regexp)
    (?:
        (?: , | => )
        \s*
        (.*)
    )?
    $
    /sxo;

BEGIN
{
    use Exporter   ();

    $Template::Sandbox::VERSION     = '1.04';
    @Template::Sandbox::ISA         = qw( Exporter );

    @Template::Sandbox::EXPORT      = qw();
    @Template::Sandbox::EXPORT_OK   = qw(
        inconstant
        needs_template
        undef_ok
        has_args no_args
        one_arg two_args three_args any_args
        def_func
        );
    %Template::Sandbox::EXPORT_TAGS = (
        function_sugar => [ qw(
            inconstant
            needs_template
            undef_ok
            has_args no_args
            one_arg two_args three_args any_args
            ) ],
        );
}

sub _find_local_functions
{
    my ( $self ) = @_;

    return( \%functions ) unless ref( $self );

    $self->{ local_functions } ||= {};
    return( $self->{ local_functions } );
}

sub register_template_function
{
    my $self = shift;
    my ( $local_functions );

    $local_functions = $self->_find_local_functions();

    while( my $name = shift )
    {
        my ( $func );

        $func = shift;

        #  TODO:  Carp has errors croaking from here.
        $self->caller_error(
            "Bad template function '$name' to register_template_function(), " .
            "expected sub ref or 'function_sugar'ed sub ref, got: " .
            ( ref( $func ) || "'$func'" ) )
            unless ref( $func ) eq 'ARRAY' or ref( $func ) eq 'CODE';

        #  do local $^W = undef; in calling block to suppress.
        $self->caller_warning(
            "Template function '$name' exists, overwriting." )
            if $^W and $local_functions->{ $name };

        #  If they don't use the function sugar, we assume they're not fussy
#  TODO: probably safer to error since constant/inconstant shouldn't be assumed
        $func = any_args $func if ref( $func ) eq 'CODE';

        $local_functions->{ $name } = $func;
    }
}

sub add_template_function
{
    my $self = shift;

    $self->register_template_function( @_ );
}

sub unregister_template_function
{
    my $self = shift;
    my ( $local_functions );

    $local_functions = $self->_find_local_functions();

    while( my $name = shift )
    {
        $self->caller_warning(
            "Template function '$name' does not exist, cannot be removed." )
            if $^W and not $local_functions->{ $name };

        delete $local_functions->{ $name };
    }
}

sub delete_template_function
{
    my $self = shift;

    $self->unregister_template_function( @_ );
}

sub _find_local_syntaxes
{
    my ( $self ) = @_;

    return( \%syntaxes ) unless ref( $self );

    $self->{ local_syntaxes } ||= {
        #  Faux values to define the auto opcode generation for local syntaxes.
        #  We use negative values to avoid clash with class-level opcodes.
        '.next_instr'      => -(LOCAL_SYNTAX),
        '.instr_increment' => -1,
        '.instr'           => {},
        };
    $self->{ local_token_aliases } ||= {};
    return( $self->{ local_syntaxes } );
}

sub register_template_syntax
{
    my $self = shift;
    my ( $local_syntaxes );

    $local_syntaxes = $self->_find_local_syntaxes();

    while( my $name = shift )
    {
        my ( $syntax );

        $syntax = shift;

        #  TODO:  Carp has errors when croaking from here.
        $self->caller_error(
            "Bad template syntax '$name' to register_template_syntax(), " .
            "expected hash ref, got: " . ( ref( $syntax ) || "'$syntax'" ) )
            unless ref( $syntax ) eq 'HASH';

        $self->caller_error( "Missing compile callback for syntax $name" )
             unless $syntax->{ compile };
        $self->caller_error( "Missing run callback for syntax $name" )
             unless $syntax->{ run };

        #  do local $^W = undef; in calling block to suppress.
        $self->caller_warning(
            "Template syntax '$name' exists, overwriting." )
            if $^W and $local_syntaxes->{ $name };

        $syntax = { %{$syntax} };

        #  Icky.
        $syntax->{ instr } = $local_syntaxes->{ '.next_instr' };
        $local_syntaxes->{ '.next_instr' } +=
            $local_syntaxes->{ '.instr_increment' };

        $local_syntaxes->{ $name } = { %{$syntax} };
        $local_syntaxes->{ '.instr' }->{ $syntax->{ instr } } = $name;
    }
}

sub add_template_syntax
{
    my $self = shift;

    $self->register_template_syntax( @_ );
}

sub unregister_template_syntax
{
    my $self = shift;
    my ( $local_syntaxes );

    $local_syntaxes = $self->_find_local_syntaxes();

    while( my $name = shift )
    {
        unless( $local_syntaxes->{ $name } )
        {
            $self->caller_warning(
                "Template syntax '$name' does not exist, cannot be removed." )
                if $^W;
            next;
        }

        delete $local_syntaxes->{ '.instr' }->{
            $local_syntaxes->{ $name }->{ instr } };
        delete $local_syntaxes->{ $name };
    }
}

sub delete_template_syntax
{
    my $self = shift;

    $self->unregister_template_syntax( @_ );
}

sub get_valid_singular_constructor_param
{
    my ( $self ) = @_;

    return( qw/template cache logger template_root allow_bare_expr
        ignore_module_dependencies open_delimiter close_delimiter
        vmethods template_toolkit_compat/ );
}

sub get_valid_multiple_constructor_param
{
    my ( $self ) = @_;

    return( qw/copy_global_functions template_function template_syntax
        library/ );
}

#  TODO: implement these constructor options:
#    -
sub new
{
    my $this = shift;
    my ( $self, $class, %param, %valid_singular, %valid_multiple );

    $self = {};
    $class = ref( $this ) || $this;
    bless $self, $class;

    %valid_singular =
        map { $_ => 1 } $self->get_valid_singular_constructor_param();
    %valid_multiple =
        map { $_ => 1 } $self->get_valid_multiple_constructor_param();

    #  Read remaining args.
    %param = ();
    while( my $param_name = shift )
    {
        my $param_value = shift;

        if( $valid_singular{ $param_name } )
        {
            $param{ $param_name } = $param_value;
        }
        elsif( $valid_multiple{ $param_name } )
        {
            $param{ $param_name } ||= [];
            push @{$param{ $param_name }}, $param_value;
        }
        else
        {
            $self->caller_error( "Unknown constructor param: '$param_name'" );
        }
    }

    $self->{ phase } = 'initialization';
    $self->initialize( \%param );
    $self->{ phase } = 'post-initialization';

    return( $self );
}

sub initialize
{
    my ( $self, $param ) = @_;

    #  Do this early in case anything needs logging.
    if( exists $param->{ logger } )
    {
        $self->{ logger } = $param->{ logger } if $param->{ logger };
    }
    else
    {
        $self->{ logger } = Log::Any->get_logger();
    }

    #  For the paranoid, to prevent other code changing them after
    #  we initialize.
    $self->{ local_functions } = Clone::clone( \%functions )
        if exists $param->{ copy_global_functions };

    if( exists $param->{ template_function } )
    {
        foreach my $arg ( @{$param->{ template_function }} )
        {
            $self->register_template_function( @{$arg} );
        }
    }
    if( exists $param->{ template_syntax } )
    {
        foreach my $arg ( @{$param->{ template_syntax }} )
        {
            $self->register_template_syntax( @{$arg} );
        }
    }
    if( exists $param->{ library } )
    {
        foreach my $arg ( @{$param->{ library }} )
        {
#  Neccessary?
#            eval "use $arg->[ 0 ];";
            $arg->[ 0 ]->export_template_functions( $self,
                @{$arg}[ 1..@{$arg} - 1 ] );
        }
    }

    $self->{ ignore_module_dependencies } =
        $param->{ ignore_module_dependencies }
        if exists $param->{ ignore_module_dependencies };

    if( $param->{ template_toolkit_compat } )
    {
        $self->{ open_delimiter }  = '[%'
            unless exists $param->{ open_delimiter };
        $self->{ close_delimiter } = '%]'
            unless exists $param->{ close_delimiter };
        $self->{ allow_bare_expr } = 1
            unless exists $param->{ allow_bare_expr };
        $self->{ vmethods }        = 1
            unless exists $param->{ vmethods };
    }

    $self->{ open_delimiter } = $param->{ open_delimiter }
        if exists $param->{ open_delimiter };
    $self->{ close_delimiter } = $param->{ close_delimiter }
        if exists $param->{ close_delimiter };
    $self->{ allow_bare_expr } = $param->{ allow_bare_expr }
        if exists $param->{ allow_bare_expr };
    $self->{ vmethods } = $param->{ vmethods }
        if exists $param->{ vmethods };

    $self->set_cache( $param->{ cache } )
        if exists $param->{ cache };
    $self->set_template_root( $param->{ template_root } )
        if exists $param->{ template_root };
    $self->set_template( $param->{ template } )
        if exists $param->{ template };

    $self->{ vars }   = {};
    $self->{ debug }  = {};
}

sub set_cache
{
    my ( $self, $cache ) = @_;

    $self->{ cache } = $cache;
    delete $self->{ cache_uses_extended_set };
}

sub _cache_uses_extended_set
{
    my ( $self ) = @_;
    my ( $cache );

    return( $self->{ cache_uses_extended_set } )
        if exists $self->{ cache_uses_extended_set };

    $cache = $self->{ cache };
    return( $self->{ cache_uses_extended_set } = 1 )
        if $cache->isa( 'Cache::CacheFactory' ) or
           ( $cache->can( 'set_takes_named_param' ) and
             $cache->set_takes_named_param() );
    return( $self->{ cache_uses_extended_set } = 0 );
}

sub set_template_root
{
    my ( $self, $dir ) = @_;

    $self->{ template_root } = $dir;
}

sub get_template_candidates
{
    my ( $self, $filename, $current_dir ) = @_;

    return( $self->{ template_root } ?
        File::Spec->catfile( $self->{ template_root }, $filename ) :
        $filename );
}

sub get_include_candidates
{
    my ( $self, $filename, $current_dir ) = @_;

    return( $current_dir ?
        File::Spec->catfile( $current_dir, $filename ) :
        $filename );
}

sub find_template
{
    my ( $self, $filename, $current_dir ) = @_;
    my ( @candidates );

    @candidates = $self->get_template_candidates( $filename, $current_dir );
    foreach my $candidate ( @candidates )
    {
        return( $candidate ) if -e $candidate;
    }

    $self->error( "Unable to find matching template from candidates:\n" .
        join( "\n", @candidates ) );
}

sub find_include
{
    my ( $self, $filename, $current_dir ) = @_;
    my ( @candidates );

    @candidates = $self->get_include_candidates( $filename, $current_dir );

    foreach my $candidate ( @candidates )
    {
        return( $candidate ) if -e $candidate;
    }

    $self->error( "Unable to find matching include from candidates:\n" .
        join( "\n", @candidates ) );
}

sub cache_key
{
    my ( $self, $keys ) = @_;
    local $Storable::canonical = 1;

    return( Digest::MD5::md5_hex( Storable::nfreeze( $keys ) ) );
}

sub get_additional_dependencies
{
#    my ( $self ) = @_;

    return( [] );
}

sub set_template
{
    my ( $self, $filename, $defines ) = @_;
    my ( $cache_key );

#my $start_time = Time::HiRes::time();

    #  Shallow copy is safe, keys/values should only be scalars.
    $defines = $defines ? { %{$defines} } : {};
    $self->{ defines }        = $defines;
    $self->{ special_values } = {};
    delete $self->{ template };

    $self->{ filename }    = $self->find_template( $filename );
    $defines->{ FILENAME } = $self->{ filename };

    if( $self->{ cache } )
    {
#my $fetchstart = Time::HiRes::time();
        #  $defines at this stage includes all unique compile-time
        #  parameters that effect the final compiled template, this
        #  is more than just the filename, so we need to generate
        #  a simple string key from multiple inputs.
        $cache_key = $self->cache_key( $defines );
        $self->{ template } = $self->{ cache }->get( $cache_key );
#warn "Cache fetch: " . $self->{ filename } . " " .
#  sprintf( "%.6fs", Time::HiRes::time() - $fetchstart );
    }

    unless( $self->{ template } )
    {
        my ( $compiletime );

        $compiletime = time();  #  Before the compile, to be safe.

        $self->{ dependencies } = $self->get_additional_dependencies();

        #  If we're caching, the validity of the cache depends on the
        #  last-modified of the template module as well as the template
        #  files, unless we've been told to ignore it.
        if( $self->{ cache } and not $self->{ ignore_module_dependencies } )
        {
            my ( $class_handle );

            $class_handle = Class::Handle->new( ref( $self ) );
            push @{$self->{ dependencies }},
                #  TODO: Ew, ugly and non-portable.
                grep { defined( $_ ) }
                map  { s/\:\:/\//g; s/$/\.pm/; $INC{ $_ }; }
                $class_handle->self_and_super_path();
        }

        $self->{ template } =
            $self->_read_template( $self->{ filename }, $defines );

        $self->_compile_template();

        if( $self->{ cache } )
        {
            #  If they're using Cache::CacheFactory we can make use of
            #  the dependencies and created at timestamps, if not we
            #  fall back on the basic Cache::Cache style API.
#  TODO: wrap compat cache behaviour with our own dependencies checking.
            if( $self->_cache_uses_extended_set() )
            {
                $self->{ cache }->set(
                    key          => $cache_key,
                    data         => $self->{ template },
                    dependencies => $self->{ dependencies },
                    created_at   => $compiletime,
                    );
            }
            else
            {
                $self->{ cache }->set( $cache_key, $self->{ template } );
            }
        }
    }

#CORE::warn( "set_template( $filename ) took " .
#  sprintf( "%.3f", Time::HiRes::time() - $start_time ) . "s" );
}

#  TODO: split/merge parts from set_template() above.
sub set_template_string
{
    my ( $self, $template_string, $defines ) = @_;
    my ( $cache_key );

#my $start_time = Time::HiRes::time();

    #  Shallow copy is safe, keys/values should only be scalars.
    $defines = $defines ? { %{$defines} } : {};
    $self->{ defines }        = $defines;
    $self->{ special_values } = {};
    delete $self->{ template };

    #  Erk.  Better way of making this cacheable surely?
    $self->{ filename }    = 'string:///' . $template_string;
    $defines->{ FILENAME } = $self->{ filename };

    if( $self->{ cache } )
    {
#my $fetchstart = Time::HiRes::time();
        #  $defines at this stage includes all unique compile-time
        #  parameters that effect the final compiled template, this
        #  is more than just the filename, so we need to generate
        #  a simple string key from multiple inputs.
        $cache_key = $self->cache_key( $defines );
        $self->{ template } = $self->{ cache }->get( $cache_key );
#warn "Cache fetch: " . $self->{ filename } . " " .
#  sprintf( "%.6fs", Time::HiRes::time() - $fetchstart );
    }

    unless( $self->{ template } )
    {
        my ( $compiletime );

        $compiletime = time();  #  Before the compile, to be safe.

        $self->{ dependencies } = $self->get_additional_dependencies();

        #  If we're caching, the validity of the cache depends on the
        #  last-modified of the template module as well as the template
        #  files, unless we've been told to ignore it.
        if( $self->{ cache } and not $self->{ ignore_module_dependencies } )
        {
            my ( $class_handle );

            $class_handle = Class::Handle->new( ref( $self ) );
            push @{$self->{ dependencies }},
                #  TODO: Ew, ugly and non-portable.
                grep { defined( $_ ) }
                map  { s/\:\:/\//g; s/$/\.pm/; $INC{ $_ }; }
                $class_handle->self_and_super_path();
        }

        $self->{ template } =
            $self->_read_template_from_string( $template_string, $defines );

        $self->_compile_template();

        if( $self->{ cache } )
        {
            #  If they're using Cache::CacheFactory we can make use of
            #  the dependencies and created at timestamps, if not we
            #  fall back on the basic Cache::Cache style API.
#  TODO: wrap compat cache behaviour with our own dependencies checking.
            if( $self->_cache_uses_extended_set() )
            {
                $self->{ cache }->set(
                    key          => $cache_key,
                    data         => $self->{ template },
                    dependencies => $self->{ dependencies },
                    created_at   => $compiletime,
                    );
            }
            else
            {
                $self->{ cache }->set( $cache_key, $self->{ template } );
            }
        }
    }

#CORE::warn( "set_template( $filename ) took " .
#  sprintf( "%.3f", Time::HiRes::time() - $start_time ) . "s" );
}

sub _error_message
{
    my $self = shift;
    my ( $error, $pos );

    $self = {} unless ref( $self );  #  Hack for calling as a class method.

    $error = join( '', @_ );
    $error = "Template " . ( $self->{ phase } ? $self->{ phase } . ' ' : '' ) .
        "error: $error";
    $pos = $self->{ current_pos };
    if( $pos )
    {
        my ( $files );

        if( $self->{ template } and
            ( ref( $self->{ template } ) eq 'HASH' ) and
            $self->{ template }->{ files } )
        {
            $files = $self->{ template }->{ files };
        }
        elsif( $self->{ files } )
        {
            $files = $self->{ files };
        }
        else
        {
            $files = [];
        }
        $error .= " at line $pos->[ 1 ], char $pos->[ 2 ] of " .
            "'$files->[ $pos->[ 0 ] ]'";
        if( $self->{ pos_stack } )
        {
            my ( $first );

            $first = 1;
            foreach $pos ( @{$self->{ pos_stack }} )
            {
                $error .= "\n  called from " .
                    "line $pos->[ 1 ], char $pos->[ 2 ] of " .
                    "'$files->[ $pos->[ 0 ] ]'"
                    unless $first;
                $first = 0;
            }
        }
    }
    return( $error );
}

sub log_error
{
    my ( $self, $message ) = @_;

    return unless ref( $self );  #  No logging if class method.
    $self->{ logger }->error( $message ) if $self->{ logger };
}

sub log_warning
{
    my ( $self, $message ) = @_;

    return unless ref( $self );  #  No logging if class method.
    $self->{ logger }->warning( $message ) if $self->{ logger };
}

sub error
{
    my $self = shift;
    my ( $message );

    $message = $self->_error_message( @_ );
    $self->log_error( $message );
    $self->fatal_exit( $message );
}

sub caller_error
{
    my $self = shift;
    my ( $message );

    $message = $self->_error_message( @_ );
    $self->log_error( $message );
    $self->caller_fatal_exit( $message );
}

sub fatal_exit
{
    my ( $self, $message ) = @_;

    die $message;
}

sub caller_fatal_exit
{
    my ( $self, $message ) = @_;

#  TODO: restore once Carp stops dying with:
#     Bizarre copy of HASH in sassign at [...]/Carp/Heavy.pm line 96.
#    croak $message;
    die $message;
}

sub warning
{
    my $self = shift;
    my ( $message );

    $message = $self->_error_message( @_ );
    $self->log_warning( $message );
    warn $message;
}

sub caller_warning
{
    my $self = shift;
    my ( $message );

    $message = $self->_error_message( @_ );
    $self->log_warning( $message );
    carp $message;
}

sub add_var
{
    my ( $self, $var, $value ) = @_;

    $self->caller_error(
        "Bad argument to add_var, expected top-level variable name, got: $var"
        )
        if $var =~ /\./o;

    $self->{ vars }->{ $var } = $value;
}

sub add_vars
{
    my ( $self, $vars ) = @_;
    my ( @bad_vars );

    $self->caller_error(
        "Bad var(s) in add_vars, expected top-level variable name, got: " .
        join( ', ', @bad_vars )
        )
        if @bad_vars = grep /\./o, keys( %{$vars} );

    foreach my $var ( keys( %{$vars} ) )
    {
        $self->{ vars }->{ $var } = $vars->{ $var };
    }
}

sub _var_value
{
    my ( $self, $var ) = @_;

    return( $self->{ vars }->{ $var } );
}

sub merge_var
{
    my ( $self, $var, $value, $ref ) = @_;

    $ref = $self->{ vars } unless $ref;

#CORE::warn( "merge_var( ",
#  Data::Dumper::Dumper( $var ), ", ",
#  Data::Dumper::Dumper( $value ), ", ",
#  Data::Dumper::Dumper( $ref->{ $var } ), ")\n" );

    unless( exists( $ref->{ $var } ) and ref( $value ) and
        ( ref( $value ) eq 'HASH' or ref( $value ) eq 'ARRAY' ) )
    {
#CORE::warn( "Doesn't exist, setting\n" );
        $ref->{ $var } = $value;
        return;
    }

    if( ref( $value ) eq 'HASH' )
    {
        foreach my $key ( keys( %{$value} ) )
        {
            $self->merge_var( $key, $value->{ $key }, $ref->{ $var } );
        }
    }
    elsif( ref( $value ) eq 'ARRAY' )
    {
        if( ref( $ref->{ $var } ) eq 'ARRAY' )
        {
            push @{$ref->{ $var }}, @{$value};
        }
        else
        {
            #  Ew, trying to merge array with non-array?
            #  TODO: error?
            $ref->{ $var } = $value;
        }
    }
}

sub merge_vars
{
    my ( $self, $vars ) = @_;

    foreach my $var ( keys( %{$vars} ) )
    {
        $self->merge_var( $var, $vars->{ $var } );
    }
}

sub clear_vars
{
    my ( $self ) = @_;

    $self->{ vars } = {};
}

sub _escape_string
{
    my ( $self, $string ) = @_;

    $string =~ s/\'/\\\'/go;
    return( $string );
}

sub _define_value
{
    my ( $self, $defines, $define, $default, $quote, $pos ) = @_;
    my ( $value );

#$self->warning( "replacing define '$define', default '$default', quote is $quote, pos '$pos'" );
    if( $self->{ seen_defines }->{ $define }++ )
    {
        $value = "[recursive define '$define']";
    }
    elsif( defined( $defines->{ $define } ) )
    {
        $value = $defines->{ $define };
    }
    elsif( defined( $default ) )
    {
        $value = $default;
    }
    else
    {
        $value = "[undefined preprocessor define '$define']";
    }

    $value = $self->_replace_defines( $value, $defines );
    $self->{ seen_defines }->{ $define }--;

    $value = "'" . $self->_escape_string( $value ) . "'" if $quote;

    if( defined( $pos ) )
    {
        my ( $lines, $definelen, $valuelen );

        $lines     = $value =~ tr/\n//;
        $definelen = 3 + ( $quote ? 2 : 0 ) + length( $define ) +
            ( defined( $default ) ? length( $default ) : 0 );
        $valuelen  = length( $value );

        if( $lines )
        {
            push @{$self->{ offsets }}, [ $pos, $valuelen, -$lines,
                $definelen - $valuelen,
                ]
        }
        else
        {
            push @{$self->{ offsets }}, [ $pos, $valuelen, 0,
                $definelen - $valuelen,
                ]
        }
    }

    return( $value );
}

sub _replace_defines
{
    my ( $self, $template_content, $defines ) = @_;
    my ( $top );

    #  Replace any preprocessor defines.
    unless( $self->{ seen_defines } )
    {
        $self->{ seen_defines } = {};
        $self->{ offsets } = [];
        $top = 1;
    }
    1 while $template_content =~ s/\$\{('?)([A-Z0-9_]+)(?::([^\}]*))?\1\}/
        $self->_define_value( $defines, $2, $3, $1,
            $top ? pos( $template_content ) : undef )/geox;
    if( $top )
    {
        delete $self->{ seen_defines };
        delete $self->{ offsets } unless @{$self->{ offsets }};
        if( $self->{ offsets } )
        {
            #  pos() gives us position in original string, we need to
            #  renumber to be position in replaced string.
            my $carry = 0;
            foreach my $offset ( @{$self->{ offsets }} )
            {
                $offset->[ 0 ] -= $carry;
                $carry += $offset->[ 3 ];
            }
#my $t = $template_content;
#foreach my $offset ( reverse( @{$self->{ offsets }} ) )
#{
#    substr( $t, $offset->[ 0 ] + $offset->[ 1 ], 0 ) = "XXX";
#    substr( $t, $offset->[ 0 ], 0 ) = "XXX";
#}
#print "Replaced template:\n$t\n";
#use Data::Dumper;
#print "Using offsets: " . Data::Dumper::Dumper( $self->{ offsets } ) . "\n";
        }
    }

    return( $template_content );
}

sub _read_template
{
    my ( $self, $filename, $defines ) = @_;
    my ( $fh, $template );

    push @{$self->{ dependencies }}, $filename;

    $fh = IO::File->new( $filename, '<' );
    #  TODO: $! can get trashed if $filename is interpolated - investigate
    #  TODO: is this perl 5.10.0's $! bug, or mine?
#    $self->caller_error( "Unable to read $filename: $!" ) unless $fh;
    $self->caller_error( "Unable to read ", $filename, ": $!" ) unless $fh;
    {
        local $/;
        $template = <$fh>;
    }
    $fh->close;

    #  Replace any preprocessor defines.
    $template = $self->_replace_defines( $template, $defines );

    return( $template );
}

sub _read_template_from_string
{
    my ( $self, $template, $defines ) = @_;

    #  Replace any preprocessor defines.
    $template = $self->_replace_defines( $template, $defines );

    return( $template );
}

#  Looks for combination of positional and named parameters to a syntax
#  token and returns a hashref of named parameters.
#  TODO: this is largely obsolete for everything except includes,
#  TODO: should be retired in favour of something specialized and faster.
sub _parse_args
{
    my ( $self, $args, $type ) = @_;
    my ( $count, %param, @words, @pos_param, @keyword_param, $instr,
         @positions, @valid, $syntax );

#    #  Heeeello hackery.
#    $args = "iterator=\"$1\" set=\"$2\""
#        if $type eq 'for' and $args =~ /^(.*) in (.*)$/o;

    $syntax = $self->{ local_syntaxes }->{ $type } || $syntaxes{ $type };

    @positions = $syntax->{ positional_args } ?
        @{$syntax->{ positional_args }} : ();
    @valid     = $syntax->{ valid_args } ? @{$syntax->{ valid_args }} : undef;

    %param = ();

    @words = split( /\s+/, $args );
    #  Merge quoted args.
#  TODO: rename instr to in_str for semantic clarity vs "instr"uction.
    $instr = 0;
    for( $count = 0; $count < @words; $count++ )
    {
        if( $instr )
        {
            $instr = 0 if $words[ $count ] =~ /\"$/;
            $words[ $count - 1 ] .= ' ' . $words[ $count ];
            @words =
                ( @words[ 0..$count - 1 ], @words[ $count + 1..@words - 1 ] );
            $count--;
        }
        else
        {
            next unless $words[ $count ] =~ /^\"/ or $words[ $count ] =~ /=\"/;
            next if $words[ $count ] =~ /\"$/;
            $instr = 1;
        }
    }

    #  Split into positional parameters and keyword paramaters.
    for( $count = 0; $count < @words; $count++ )
    {
        last if $words[ $count ] =~ /=/;
    }

    @pos_param     = $count ? @words[ 0..$count - 1 ]   : ();
    @keyword_param = $count < @words ?
        @words[ $count..@words - 1 ] : ();

    #  Squidge any "overshoot" positional param onto the final pos param.
    #  TODO: splice!
    @pos_param = ( @pos_param[ 0..@positions - 2 ],
        join( ' ', @pos_param[ @positions - 1..@pos_param - 1 ] ) )
        if @pos_param > @positions;

    $count = 0;
    foreach my $word ( @pos_param )
    {
        $word = $1 if $word =~ /^\"(.*)\"$/;
        $param{ $positions[ $count++ ] } = $word;
    }

    foreach my $word ( @keyword_param )
    {
        my ( $keyword, $value );

        ( $keyword, $value ) = split( /=/, $word, 2 );

        unless( defined( $value ) )
        {
            $self->error( "Undefined value for keyword: '$keyword' on " .
                "parse_args( $args, $type )" );
        }

        $value = $1 if $value =~ /^\"(.*)\"$/;

        #  TODO: validate arg names.
        $param{ $keyword } = $value;
    }

    return( { %param } );
}

sub _compile_template
{
    my ( $self ) = @_;
    my ( $i, @hunks, @files, @pos_stack, @nest_stack, @compiled, %includes,
         %trim, $trim_next, %file_numbers, @define_stack,
         $local_syntaxes, $local_token_aliases, $local_syntax_regexp,
         $hunk_regexp, $syntax_regexp,
         $open_delimiter, $close_delimiter, $open_regexp, $close_regexp );

    @files           = ( $self->{ filename } );
    %file_numbers    = ( $self->{ filename } => 0 );
    $self->{ files } = \@files;

    #  Stack of what position in which file we're currently at.
    @pos_stack    = ( [
        $file_numbers{ $self->{ filename } }, 1, 1, 0, $self->{ offsets },
        ] );
    delete $self->{ offsets };
    #  Stack of what defines are available.
    @define_stack = ( $self->{ defines } );
    #  Stack of unclosed block-level statements.
    @nest_stack   = ();
    #  The tokenized/compiled template.
    @compiled     = ();
    #  Files we're currently including.
    %includes     = ( $self->{ filename } => 1 );
    #  Stuff we're going to trim later.
    %trim         = ();

    $open_delimiter  = $self->{ open_delimiter }  || '<:';
    $close_delimiter = $self->{ close_delimiter } || ':>';

    $open_regexp  = qr/\Q$open_delimiter\E/;
    $close_regexp = qr/\Q$close_delimiter\E/;

    $local_token_aliases = $self->{ local_token_aliases } || {};
    $local_syntaxes      = $self->{ local_syntaxes } || {};

#  TODO: class-level syntax aliases
#  TODO: split into class/instance versions and unroll to construct time?
#  TODO: or generate-on-demand but class/instance copy invalidated on change.
    #  Egads!
    $local_syntax_regexp = join( ' | ',
        map { join( ' \s+ ', split( /\s+/, $_ ) ) }
        grep( /^[^\.]/,
            keys( %{$local_token_aliases} ), keys( %{$local_syntaxes} ),
            values( %{$syntaxes{ '.instr' }} ) ) );
    $local_syntax_regexp = ' | ' . $local_syntax_regexp
        if $local_syntax_regexp;

    $syntax_regexp = qr/(
          var | expr |
          (?:if|unless) | else? \s* (?:if|unless) | else |
          end \s* (?:if|unless) |
          for(?:each)? | end \s* for(?:each)? | end |
          include | end \s* include |
          \# |
          debug
          $local_syntax_regexp
        ) \s+
        /ix;
    $syntax_regexp = qr/(?:$syntax_regexp)?/ if $self->{ allow_bare_expr };
    $hunk_regexp = qr/^$open_regexp \s*
         $syntax_regexp (.*?) \s* $close_regexp (.+)? $/sx;

    @hunks = split( /(?=$open_regexp)/s, $self->{ template }, -1 );
    delete $self->{ template };

    $self->{ pos_stack } = \@pos_stack;
    $self->{ phase }     = 'compile';

#my ( $dumpme );
    for( $i = 0; $i < @hunks; $i++ )
    {
        my ( $hunk, $pos, $lines, $queue_pos, $last, $hunklen, $hunkstart,
             $offset_index );

        $hunk = $hunks[ $i ];

        $pos = [ @{$pos_stack[ 0 ]}[ 0..2 ] ];
        $self->{ current_pos } = $pos;

        if( $hunk =~ $hunk_regexp )
        {
            my ( $token, $syntax, $args, $rest );

            $token = lc( $1 || 'expr' );
            $args  = $2;
            $rest  = $3;

            #  TODO:  still possible?  What triggers it?
            #  error, unclosed token?
            $self->error( "unexepected $open_delimiter, ",
                "possibly unterminated $close_delimiter" )
                if $args =~ $open_regexp;

            if( defined( $rest ) )
            {
                $hunk =~ s/$close_regexp(?:.*)$/$close_delimiter/s;
                splice( @hunks, $i, 1, $hunk, $rest );
            }

            $token =~ s/\s+/ /go;

            if( $token eq 'end' )
            {
                $self->error( "end found without opening block" )
                    unless @nest_stack;
                $token = ( $nest_stack[ 0 ][ 0 ] eq FOR ) ?
                    'endfor' : 'endif';
            }

            $token = $local_token_aliases->{ $token }
                if $local_token_aliases->{ $token };
            $token = $token_aliases{ $token }
                if $token_aliases{ $token };
            $syntax = $local_syntaxes->{ $token } || $syntaxes{ $token };

            #  Fudge things a little so that flow-control tokens
            #  on a line by themselves don't produce a bunch of
            #  empty lines in the output.
            #  Are we a zero-width token on a line by itself?
            if( $syntax->{ zero_width } and
                $i < @hunks - 1 and
                ( ( not @compiled ) or
                  ( $compiled[ @compiled - 1 ]->[ 0 ] == LITERAL and
                    $compiled[ @compiled - 1 ]->[ 2 ] =~ /\n\ *$/ ) or
                  ( $compiled[ @compiled - 1 ]->[ 0 ] == CONTEXT_PUSH ) ) and
                $hunks[ $i + 1 ] =~ /^\n\ */ )
            {
                $trim_next = 1;
            }
            else
            {
                $trim_next = 0;
            }

            if( $syntax->{ compile } )
            {
                my ( $compiler, $opcode );

                $args = $self->_parse_args( $args, $token );

                $compiler = $syntax->{ compile };
                $opcode   = $syntax->{ instr };
                $args = $compiler->( $self, $token, $pos, $args );
                push @compiled, [ $opcode, $pos, $args ] if defined $args;
            }
            elsif( $token eq 'debug' )
            {
                $args = $self->_parse_args( $args, $token );

                $args = 0 unless keys( %{$args} );

                push @compiled,
                    [ DEBUG, $pos, $args ];
            }
            elsif( $token eq 'expr' or $token eq 'var' )
            {
                my ( $expr );

                $expr = $self->_compile_expression( $args );

                push @compiled,
                    [ EXPR, $pos, $expr,
                      #  Void-wrap assign expressions.
                      ( ( $expr->[ 0 ] == OP_TREE ) and
                        ( $expr->[ 2 ] eq '=' ) ) ? 1 : 0 ];
            }
            elsif( $token eq 'if' or $token eq 'unless' )
            {
                my ( $expr );

                $expr = $self->_compile_expression( $args );
                if( $token ne 'if' )
                {
                    if( $expr->[ 0 ] == LITERAL )
                    {
                        $expr->[ 2 ] = not $expr->[ 2 ];
                    }
                    else
                    {
                        $expr = [ UNARY_OP, 'unless', 'not', $expr ];
                    }
                }
                push @compiled,
                    [ JUMP_IF, $pos, undef, $expr ];
#                push @compiled,
#                    [ JUMP_IF, $pos, undef,
#                       $self->_compile_expression( $args ),
#                       $token eq 'if' ? 1 : 0 ];
                unshift @nest_stack, [ 'if', @compiled - 1 ];
            }
            elsif( $token eq 'elsif' or $token eq 'elsunless' )
            {
                my ( $expr );

                if( ( not @nest_stack ) or
                    ( $nest_stack[ 0 ][ 0 ] ne 'if' and
                      $nest_stack[ 0 ][ 0 ] ne 'elsif' ) )
                {
                    $self->error( "elsif found without opening if or elsif" );
                }
                #  Closing jump of previous block.
                push @compiled,
                    [ JUMP, $pos, undef ];

                $expr = $self->_compile_expression( $args );
                if( $token ne 'elsif' )
                {
                    if( $expr->[ 0 ] == LITERAL )
                    {
                        $expr->[ 2 ] = not $expr->[ 2 ];
                    }
                    else
                    {
                        $expr = [ UNARY_OP, 'elsunless', 'not', $expr ];
                    }
                }
                push @compiled, [ JUMP_IF, $pos, undef, $expr ];
#                push @compiled,
#                    [ JUMP_IF, $pos, undef,
#                       $self->_compile_expression( $args ),
#                       $token eq 'elsif' ? 1 : 0 ];
                #  Now, update jump address of previous if/elsif
                $compiled[ $nest_stack[ 0 ][ 1 ] ][ 2 ] =
                    @compiled - 1;
                unshift @nest_stack, [ 'elsif', @compiled - 1 ];
            }
            elsif( $token eq 'else' )
            {
                if( ( not @nest_stack ) or
                    ( $nest_stack[ 0 ][ 0 ] ne 'if' and
                      $nest_stack[ 0 ][ 0 ] ne 'elsif' ) )
                {
                    $self->error( "else found without opening if or elsif" );
                }
                #  Closing jump of previous block.
                push @compiled,
                    [ JUMP, $pos, undef ];
                #  Now, update jump address of previous if/elsif
                $compiled[ $nest_stack[ 0 ][ 1 ] ][ 2 ] = @compiled;
                unshift @nest_stack, [ 'else', scalar( @compiled ) ];
            }
            elsif( $token eq 'endif' or $token eq 'endunless' )
            {
                if( ( not @nest_stack ) or
                    ( $nest_stack[ 0 ][ 0 ] ne 'if' and
                      $nest_stack[ 0 ][ 0 ] ne 'elsif' and
                      $nest_stack[ 0 ][ 0 ] ne 'else' ) )
                {
                    $self->error(
                        "endif found without opening if, elsif or else" );
                }

                #  Update jump address of previous if/elsif
                $compiled[ $nest_stack[ 0 ][ 1 ] ][ 2 ] = @compiled
                    unless $nest_stack[ 0 ][ 0 ] eq 'else';

                while( @nest_stack )
                {
                    my $last = shift @nest_stack;

                    if( $last->[ 0 ] eq 'if' )
                    {
                        #  It's our opening if, stop popping.
                        last;
                    }
                    elsif( $last->[ 0 ] eq 'elsif' or $last->[ 0 ] eq 'else' )
                    {
                        #  Need to update the jump address of the closing
                        #  jump of the block _prior_ to this elsif/else.
                        $compiled[ $last->[ 1 ] - 1 ][ 2 ] = @compiled;
                    }
                    else
                    {
                        #  "cannot happen".
                        $self->error(
                            "nesting stack appears to be corrupted" );
                    }
                }
            }
            elsif( $token eq 'for' )
            {
                my ( $iterator, $set );

                #  TODO: syntax checking/error check needed here.
                ( $iterator, $set ) = $args =~ /^(.*) in (.*)$/io;

                push @compiled,
                    [ FOR, $pos, undef, $iterator,
                      $self->_compile_expression( $set ),
                      1 ];
                unshift @nest_stack, [ FOR, @compiled - 1 ];
            }
            elsif( $token eq 'endfor' )
            {
                if( ( not @nest_stack ) or
                    $nest_stack[ 0 ][ 0 ] ne FOR )
                {
                    $self->error(
                         "endfor found without opening for" );
                }

                my $last = shift @nest_stack;

                #  Grab our iterator and set from the opening for
                #  TODO: needed anymore?  run grabs it from for-stack.
                push @compiled,
                    [ END_FOR, $pos, $last->[ 1 ] + 1,
                      $compiled[ $last->[ 1 ] ][ 3 ],
                      $compiled[ $last->[ 1 ] ][ 4 ] ];
                #  Update jump address of opening for.
                $compiled[ $last->[ 1 ] ][ 2 ] = @compiled;
            }
            elsif( $token eq 'include' )
            {
                my ( $filename, $inc_template, @inc_hunks, %defines );

                #  We support var renaming:
                #  ie: <: include pagerwidget offset=param.offset
                #         total=results.__size__ pagesize=param.n :>

                $args = $self->_parse_args( $args, 'include' );

                #  Extract the filename.
                #  If the filename is empty-string then we ignore the
                #  include statement, allowing us to do things like
                #  <: include ${DEFINE:} :> without knowing if the define
                #  exists or not.
                if( $filename = $args->{ filename } )
                {
                    my ( $volume, $current_dir );

                    delete $args->{ filename };

                    ( $volume, $current_dir ) = File::Spec->splitpath(
                        $define_stack[ 0 ]->{ FILENAME } );
                    #  Make sure volume is part of the current dir so
                    #  windows doesn't choke.
                    $current_dir = File::Spec->catpath(
                        $volume, $current_dir, '' );

                    %defines = %{$define_stack[ 0 ]};

                    $self->{ defines } = \%defines;
                    unshift @define_stack, \%defines;

                    #  Parse out any defines.
                    foreach my $key (
                        grep { $_ eq uc( $_ ) } keys( %{$args} ) )
                    {
                        $defines{ $key } = $args->{ $key };
                        delete $args->{ $key };
                    }
                    $args = { map
                        { $_ => $self->_compile_expression( $args->{ $_ } ) }
                        keys( %{$args} ) };
                    $args = 0 unless keys( %{$args} );

                    $filename = $self->find_include( $filename, $current_dir );

                    $self->error( "recursive include of $filename" )
                        if $includes{ $filename };

                    $defines{ FILENAME } = $filename;

                    $includes{ $filename } = 1;
                    $inc_template =
                        $self->_read_template( $filename, \%defines );
                    $inc_template =~ s/\n$//;
                    @inc_hunks = split( /(?=<:)/, $inc_template, -1 );
                    $inc_template = 0;

                    splice( @hunks, $i + 1, 0,
                        @inc_hunks, '<: endinclude :>' );

                    push @compiled,
                        [ CONTEXT_PUSH, $pos, $args ];
                    unless( exists( $file_numbers{ $filename } ) )
                    {
                        $file_numbers{ $filename } = @files;
                        push @files, $filename;
                    }
                    $queue_pos = [ $file_numbers{ $filename }, 1, 1, 0,
                        $self->{ offsets } ];
                    delete $self->{ offsets };
                }
            }
            elsif( $token eq 'endinclude' )
            {
                #  <: endinclude :> is a faux-token, it never gets read
                #  in from a template (isn't valid syntax even), but gets
                #  inserted to mark the end of the inserted hunks from
                #  an <: include :>
                #  "cannot happen".
                $self->error( "endinclude found while not within an include" )
                    unless @pos_stack;

                my $last = shift @pos_stack;
                delete $includes{ $files[ $last->[ 0 ] ] };
                shift @define_stack;
                $self->{ defines } = $define_stack[ 0 ];
                push @compiled,
                    [ CONTEXT_POP, $pos ];
                next;  #  So we don't update pos with this faux-token.
            }
            elsif( $token eq '#' )
            {
                #  We're a comment, don't compile it.
            }
            else
            {
                #  Shouldn't be possible to get through the regexp to this.
                $self->error( "unrecognised token ($token)" );
            }
        }
        else
        {
            #  We're a literal unless we're a malformed token
            if( $hunk =~ /^$open_regexp/ )
            {
                #  Trim bits after the close token if there is one,
                #  makes a clearer error message.
                $hunk =~ s/($close_regexp).*$/$1/;
                $self->error( "unrecognised token ($hunk)" );
            }
            if( length( $hunk ) )
            {
                $trim{ @compiled } = 1 if $trim_next;
                push @compiled, [ LITERAL, $pos, $hunk ];
            }
            $trim_next = 0;
        }

# +--------------------+------------------------+-----------------------------+
# |  define >          |           nl           |         !nl                 |
# +--- hunk v ---------+------------------------+-----------------------------+
# |        !nl         |   not possible (1)     | offsets: char               |
# |  nl after defines  |  offsets: nl, !char    | offsets: nl, !char (no-op)  |
# | nl before defines  | offset: nl             | offsets: char               |
# |                    | char:                  |                             |
# |                    |  chars between nl &    |                             |
# |                    |  start of define (2) + |                             |
# |                    |  original define len + |                             |
# |                    |  chars after define    |                             |
# | nl between defines |      treat in reverse series as after/before         |
# +--------------------+------------------------+-----------------------------+
#
#  TODO: (1) define spans hunks? (add test case!)
#  TODO: define spans defines?   (add test case!)
#  (2) characters is "fudged count", there may be other defines there. :(
#
# Detection:
#   nl in define: nl offset != 0
#   nl in hunk: nl in final hunk != total nl in offsets
#


        #  Update pos.
        $hunklen    = length( $hunk );
        $pos        = $pos_stack[ 0 ];
        $hunkstart  = $pos->[ 3 ];
        $pos->[ 3 ] += $hunklen;

#use Data::Dumper;
#print "After hunk: xxx${hunk}xxx\nPos is: " . Data::Dumper::Dumper( $pos ) . "\n";

        #  Do we have offsets, and have we just passed one?
        $offset_index = -1;
        while( $pos->[ 4 ] and $offset_index < @{$pos->[ 4 ]} - 1 and
               $pos->[ 4 ]->[ $offset_index + 1 ]->[ 0 ] <= $pos->[ 3 ] )
        {
            my ( $offset );

            $offset_index++;
            $offset = $pos->[ 4 ]->[ $offset_index ];
            #  Replace any newlines in the section that was the contents
            #  of a define, this is so that they don't count towards line
            #  counts or finding the "most recent newline" for character
            #  position counts.
            #  This is inelegant but much simpler (and possibly faster)
            #  than trying to compensate and find the "right" newline
            #  to count from, especially since defines containing newlines
            #  are hopefully a corner-case.
#print "Offset index: $offset_index\nOffset: " . Data::Dumper::Dumper( $offset ) . "\n";
#print "substr( hunk, " . ( $offset->[ 0 ] - $hunkstart ) . ", " . ( $offset->[ 1 ] ) . " )\n" if $offset->[ 2 ];

            substr( $hunk, $offset->[ 0 ] - $hunkstart, $offset->[ 1 ] ) =~
                s/\n/ /go
                if $offset->[ 2 ];
        }

#        $lines = () = $hunk =~ /\n/g;
#        $lines = $#{ [ $hunk =~ /\n/g ] } + 1;
        $lines   = $hunk =~ tr/\n//;
        if( $lines )
        {
            $pos->[ 1 ] += $lines;
            $pos->[ 2 ] =
                ( $hunk =~ /\n(.+)\z/mo ) ? ( length( $1 ) + 1 ) : 1;
        }
        else
        {
            $pos->[ 2 ] += $hunklen;
        }

        if( $offset_index != -1 )
        {
            my ( @offsets, $nlpos );

            @offsets = splice( @{$pos->[ 4 ]}, 0, $offset_index + 1 );
            $pos->[ 4 ] = undef unless @{$pos->[ 4 ]};

            $nlpos = $lines ? ( $pos->[ 3 ] - $pos->[ 2 ] ) : 0;

            foreach my $offset ( @offsets )
            {
                #  Don't apply the offset if it was before the final
                #  non-define newline
                next if $offset->[ 0 ] < $nlpos;
#use Data::Dumper;
#print "Applying offset: " . Data::Dumper::Dumper( $offset ) . "\n";
#                $pos->[ 1 ] += $offset->[ 2 ];
                $pos->[ 2 ] += $offset->[ 3 ];
            }
        }

        unshift @pos_stack, $queue_pos if $queue_pos;
    }

    $self->error( "unterminated if or for block" ) if @nest_stack;

    #  "cannot happen".
    $self->error( "include stack not empty, corrupted?" ) if @pos_stack > 1;

    #  TODO: scan for undef jump addresses.

    foreach my $addr ( keys( %trim ) )
    {
        #  "cannot happen".
        $self->error( "trim on non-literal, trim-stack corrupted?" )
            unless $compiled[ $addr ]->[ 0 ] == LITERAL;
        $compiled[ $addr ]->[ 2 ] =~ s/^\n//o;
    }

    #  We're done.
#    $self->{ template } = {
#            program => [ @compiled ],
#            files   => [ @files ],
#        };
    $self->{ template } = {
            program => \@compiled,
            files   => \@files,
        };
    $self->_optimize_template();
    $self->{ template }->{ last_instr } =
        @{$self->{ template }->{ program }} - 1;

    delete $self->{ current_pos };
    delete $self->{ pos_stack };
    delete $self->{ files };
    delete $self->{ phase };

#$dumpme = 1;
#use CGI;
#print CGI->header('text/plain');

#if( $dumpme )
#{
#print "\n----\n" . $self->dumpable_template() . "----\n";
#exit(0);
#}
}

sub _optimize_template
{
    my ( $self ) = @_;
    my ( $program, @nest_stack, %deletes, %jump_targets, @loop_blocks,
         $value );

#    my ( @function_table, %function_index );

    #  Optimization pass:
    #    TODO: unroll constant low-count fors?

    $program = $self->{ template }->{ program };

    #  Fold constant expr into constant instr.
    for( my $i = 0; $i < @{$program}; $i++ )
    {
        #  Are we an EXPR instr and is our expr a LITERAL expr?
        next unless $program->[ $i ]->[ 0 ] == EXPR and
                    $program->[ $i ]->[ 2 ]->[ 0 ] == LITERAL;

#warn "Folding literal expr $i (val: " . $program->[ $i ]->[ 2 ]->[ 2 ] . ") (orig: " . $program->[ $i ]->[ 2 ]->[ 1 ] . ") into literal instr.";

        $program->[ $i ]->[ 0 ] = LITERAL;
        $program->[ $i ]->[ 2 ] = $program->[ $i ]->[ 2 ]->[ 2 ];
    }


    #  Fold constant JUMP_IF into JUMP or delete.
    %deletes    = ();
    for( my $i = 0; $i < @{$program}; $i++ )
    {
        next unless $program->[ $i ]->[ 0 ] == JUMP_IF and
                    $program->[ $i ]->[ 3 ]->[ 0 ] == LITERAL;

        $value = $self->_eval_expression( $program->[ $i ]->[ 3 ], 1 );
#        $value = not $value if $program->[ $i ]->[ 4 ];

        if( $value )
        {
            #  Always true, remove the JUMP.
#warn "Folding constant JUMP_IF into no-op.";
            $deletes{ $i } = 1;
        }
        else
        {
            #  Always false, fold it into a JUMP.
#warn "Folding constant JUMP_IF into JUMP.";
            $program->[ $i ] = [ JUMP, $program->[ $i ]->[ 1 ],
                $program->[ $i ]->[ 2 ] ];
        }
    }
    $self->_delete_instr( $program, keys( %deletes ) ) if %deletes;


    #  Trim empty context pushes (TODO: that have no assigns in top level)
    %deletes    = ();
    @nest_stack = ();
    for( my $i = 0; $i < @{$program}; $i++ )
    {
        if( $program->[ $i ]->[ 0 ] == CONTEXT_PUSH )
        {
            unshift @nest_stack, $i;
            $deletes{ $i } = 1 unless $program->[ $i ]->[ 2 ];
            next;
        }
        if( $program->[ $i ]->[ 0 ] == CONTEXT_POP )
        {
            my ( $match );

            $match = shift @nest_stack;
            $deletes{ $i } = 1 if $deletes{ $match };
            next;
        }
    }
    $self->_delete_instr( $program, keys( %deletes ) ) if %deletes;


    #  Now scan for adjacent literals to merge where the second
    #  isn't a jump target.
    %deletes = ();

    #  For speed, prebuild a list of all jump targets.
    %jump_targets = ();
    foreach my $line ( @{$program} )
    {
        next unless $line->[ 0 ] == JUMP or
                    $line->[ 0 ] == JUMP_IF or
                    $line->[ 0 ] == FOR or
                    $line->[ 0 ] == END_FOR;
        $jump_targets{ $line->[ 2 ] } = 1;
    }

    #  Now scan for adjacent literals.
    for( my $i = @{$program} - 1; $i > 0; $i-- )
    {
        #  Are both ourself and our previous instr a literal?
        next if $program->[ $i ]->[ 0 ]     != LITERAL or
                $program->[ $i - 1 ]->[ 0 ] != LITERAL;

        #  Do any jumps lead to the second literal?
        next if $jump_targets{ $i };

#warn "Merging literal $i to previous.";
#warn "Merging literals [" . $program->[ $i - 1 ]->[ 2 ] . "] and [" . $program->[ $i ]->[ 2 ] . "]";

        #  Ok, no reason for us to remain apart, let's get married.
        $program->[ $i - 1 ]->[ 2 ] .= $program->[ $i ]->[ 2 ];
        $deletes{ $i } = 1;
    }
#warn "Literal merges: " . scalar( keys( %deletes ) );
    $self->_delete_instr( $program, keys( %deletes ) ) if %deletes;

    #  Look for loops that make no use of special loop vars.
    @loop_blocks = ();
    for( my $i = 0; $i < @{$program}; $i++ )
    {
        #  Are we a for statement?
        next if $program->[ $i ]->[ 0 ] != FOR;
        push @loop_blocks,
            [ $i, $program->[ $i ]->[ 2 ], $program->[ $i ]->[ 3 ] ];
    }
    #  TODO: this should be moved into the above loop to keep it single-pass.
    foreach my $block ( @loop_blocks )
    {
        my ( $special_vars_needed, $line );

        $special_vars_needed = 0;
        FORBLOCK: for( my $i = $block->[ 0 ] + 1; $i < $block->[ 1 ]; $i++ )
        {
            my ( @exprs );

            $line = $program->[ $i ];
            if( $line->[ 0 ] == EXPR )
            {
                @exprs = ( $line->[ 2 ] );
            }
            elsif( $line->[ 0 ] == FOR )
            {
                @exprs = ( $line->[ 4 ] );
            }
            elsif( $line->[ 0 ] == JUMP_IF )
            {
                @exprs = ( $line->[ 3 ] );
            }
            elsif( $line->[ 0 ] == CONTEXT_PUSH )
            {
                @exprs = values( %{$line->[ 2 ]} );
            }

            next unless @exprs;

            while( my $expr = shift( @exprs ) )
            {
                my ( $type );

                $type = $expr->[ 0 ];
                if( $type == VAR )
                {
                    my ( $segments );

                    $segments = $expr->[ 2 ];
                    #  Needs to have two or more segments.
                    next unless $expr->[ 4 ] > 0;
                    #  Top stem isn't our loop var, we're not interested.
                    next unless $segments->[ 0 ] eq $block->[ 2 ];

                    #  OK, it's refering to our loop var, is it a special?
                    if( ref( $segments->[ 1 ] ) or
                        exists( $special_values_names{ $segments->[ 1 ] } ) )
                    {
                        #  Yes, it's either a special or an inconstant
                        #  expression subscript that we can't rule out
                        #  as evaluating to a special at runtime.
                        $special_vars_needed = 1;
                        last FORBLOCK;
                    }
                }
                elsif( $type == OP_TREE )
                {
                    push @exprs, $expr->[ 3 ], $expr->[ 4 ];
                }
                elsif( $type == UNARY_OP )
                {
                    push @exprs, $expr->[ 3 ];
                }
                elsif( $type == FUNC )
                {
                    push @exprs, @{$expr->[ 3 ]};
                }
                elsif( $type == METHOD )
                {
                    push @exprs, @{$expr->[ 4 ]};
                }
            }
        }
        $program->[ $block->[ 0 ] ]->[ 5 ] = 0 unless $special_vars_needed;
    }


#    #  walk program looking for functions, adding to function table.
#    #  NOTE: turned out to not make a difference in run-time, but may revisit.
#    @function_table = ();
#    %function_index = ();
#    foreach my $line ( @{$program} )
#    {
#        my ( $op, @op_queue );
#        @op_queue = ();
#
#        if( $line->[ 0 ] == EXPR )
#        {
#            push @op_queue, $line->[ 2 ];
#        }
#        elsif( $line->[ 0 ] == JUMP_IF )
#        {
#            push @op_queue, $line->[ 3 ];
#        }
#        elsif( $line->[ 0 ] == URL )
#        {
#            push @op_queue, %{$line->[ 2 ]};
#        }
#        elsif( $line->[ 0 ] == FOR )
#        {
#            push @op_queue, $line->[ 4 ];
#        }
#        elsif( $line->[ 0 ] == CONTEXT_PUSH )
#        {
#            push @op_queue, values( %{$line->[ 2 ]} );
#        }
#        while( defined( $op = shift( @op_queue ) ) )
#        {
#            next if not ref( $op ) or $op->[ 0 ] == VAR or
#                    $op->[ 0 ] == LITERAL or $op->[ 0 ] == TEMPLATE;
#            if( $op->[ 0 ] == OP_TREE )
#            {
#                push @op_queue, $op->[ 3 ], $op->[ 4 ];
#                next;
#            }
#            if( $op->[ 0 ] == UNARY_OP )
#            {
#                push @op_queue, $op->[ 3 ];
#                next;
#            }
#            if( $op->[ 0 ] == METHOD )
#            {
#                push @op_queue, @{$op->[ 4 ]};
#                next;
#            }
#            $self->error( "Unknown EXPR opcode: " . $op->[ 0 ] .
#                " in function table construction." )
#                unless $op->[ 0 ] == FUNC;
#
##warn "Looking at op " . _tinydump( $op );
##warn "  Is function $op->[ 2 ]().";
#            if( not $function_index{ $op->[ 2 ] } )
#            {
#                push @function_table, $op->[ 2 ];
#                $function_index{ $op->[ 2 ] } = $#function_table;
#            }
#            $op->[ 2 ] = $function_index{ $op->[ 2 ] };
##warn "  Replaced with $op->[ 2 ].";
#            push @op_queue, @{$op->[ 3 ]};
#        }
#    }
#    $template->{ function_table } = [ @function_table ];
}

#  Warning, pass-by-ref: modifies $program.
sub _delete_instr
{
    my ( $self, $program, @addrs ) = @_;
    my ( %renumbers, $instr, $num, $lastnum, $lastoffset, $offset, $numaddr );

#warn "** Deleting instr: " . join( ', ', @addrs ) . ".";
#warn "-- Pre:\n" . $self->dumpable_template();

    #  Delete all the stuff we've marked for deletion.

    #  First we need to sort the deletes.
    @addrs = sort { $a <=> $b } @addrs;

    #  Then we delete the instructions from last to first.
    #  (To avoid renumbering issues).
    foreach my $addr ( reverse( @addrs ) )
    {
        splice( @{$program}, $addr, 1 );
    }

#warn "-- Deleted:\n" . $self->dumpable_template();

    #  Now we need to renumber any jump and loop targets affected.
    %renumbers = ();
    $lastnum = $lastoffset = 0;
    $numaddr = @addrs - 1;
    foreach my $line ( @{$program} )
    {
        next unless ( $instr = $line->[ 0 ] ) == JUMP or
                      $instr == JUMP_IF or
                      $instr == FOR     or
                      $instr == END_FOR;

        if( exists( $renumbers{ $num = $line->[ 2 ] } ) )
        {
            $line->[ 2 ] = $renumbers{ $num };
            next;
        }

        #  This contraption takes advantages of the fact that jumps
        #  tend to have fairly local targets to other local jumps'
        #  targets, rather than searching from the start of the
        #  template each time.
        if( $lastnum <= $num )
        {
#use Data::Dumper;
#print "Jump target: $num.\nDeleted: ", Data::Dumper::Dumper( \@addrs ), "\n";
            #  This jump is forwards from our last, search forwards.
            for( $offset = $lastoffset; $offset <= $numaddr; $offset++ )
            {
#print "  Offset is $offset, addrs[ $offset ] is $addrs[ $offset ]\n";
                last if $addrs[ $offset ] >= $num;
            }
        }
        else
        {
            #  This jump is before our last, search backwards.
            for( $offset = $lastoffset; $offset > 0; $offset-- )
            {
                last if $addrs[ $offset - 1 ] < $num;
            }
        }
        $lastnum    = $num;
        $lastoffset = $offset;

        #  Cache the result, if-elsif-else will have lots of the same targets.
        $renumbers{ $num } = ( $line->[ 2 ] -= $offset );
    }

#warn "-- Renumbered:\n" . $self->dumpable_template();
}

sub _compile_expression
{
    my ( $self, $expression ) = @_;
    my ( @top_level, $highest_weight, $highest_pos );

    $expression =~ s/^\s+//;
    $expression =~ s/\s+$//;

    $self->error( "Not a well-formed expression: $expression" )
        unless $expression =~ /^$expr_regexp$/so;

    while( $expression =~ $capture_expr_op_remain_regexp )
    {
        # $lhs = $1;
        # $op  = $2;
        # $rhs = $3;
        push @top_level, $1, $2;
        $expression = $3;
    }

    return( $self->_build_op_tree( [ @top_level, $expression ] ) )
        if @top_level;

    #  Not a compound statement, must be atomic.

    #  Is it a unary op?
    if( my ( $op, $subexpr ) =
            $expression =~ $capture_unary_operator_regexp )
    {
        $subexpr = $self->_compile_expression( $subexpr );

        #  Fold constant values.
        return( [ LITERAL, $expression,
            $self->_eval_unary_op( $op, $subexpr ) ] )
            if $subexpr->[ 0 ] == LITERAL;

        return( [ UNARY_OP, $expression, $op, $subexpr ] );
    }

    #  Is it a bracketed expression?
    #  TODO: Do I care at this point if it's matching?
#    return( $self->_compile_expression( substr( $expression, 1, -1 ) ) )
#        if $expression =~ /^$matching_round_brackets_regexp$/so;
    return( $self->_compile_expression( $1 ) )
        if $expression =~ /^\((.*)\)$/so;

    #  A literal number
    return( [ LITERAL, $expression, $expression, 0 ] )
        if $expression =~ /^$literal_number_regexp$/so;

    #  A literal string
    if( $expression =~ /^$single_quoted_text_regexp$/so )
    {
        my ( $string );

        #  Strip leading/trailing ' and unescape backslashed characters.
        $string = substr( $expression, 1, -1 );
        $string =~ s/\\(.)/$1/go;
        return( [ LITERAL, $expression, $string, 0 ] );
    }

    #  A variable or chained construct (including functions)
    return( $self->_compile_chained_operation( $expression ) )
        if $expression =~ /^$chained_operation_regexp$/so;

    #  "cannot happen".
    $self->error( "Unrecognised atomic expression element: $expression" );
}

#  TODO: replace with "replace tightest-binding operator with subtree"
#        while-loop, rather than recursive divide-and-conquer by
#        loosest-binding operator.
#        will eleminate the depth*depth cartesian loops.
sub _build_op_tree
{
    my ( $self, $arr ) = @_;
    my ( $highest_weight, $highest_pos, $op, $lhs, $rhs );

#print "build_op_tree( ", Data::Dumper::Dumper( $arr ), "\n";

    #  "cannot happen"
    $self->error( "Empty expression" ) unless @{$arr};

#  TODO: cache @{$arr} size.
    for( my $i = 0; $i < @{$arr}; $i += 2 )
    {
        #  TODO: this is a crappy hack to provide compat with recursion.
        next if ref( $arr->[ $i ] );
        $arr->[ $i ] = $self->_compile_expression( $arr->[ $i ] );
    }

    return( $arr->[ 0 ] ) if @{$arr} == 1;

    #  Look for literals to fold together.
#print "Looking at: ", Data::Dumper::Dumper( $arr ), "\n";
    for( my $i = 1; $i < @{$arr} - 1; $i += 2 )
    {
        my ( $op, $weight );

        $op = $arr->[ $i ];
        $weight = $operators{ $op }->[ 0 ];

        $lhs = $arr->[ $i - 1 ];
        $rhs = $arr->[ $i + 1 ];

#print "  Looking at op $i: '$op'\n";
        #  If we're higher or equal precedence to the operators either
        #  side of us, and our lhs and rhs are literal values, we're
        #  eligible for folding.
        if( ( ( $i < 3 ) or
              ( $weight <= $operators{ $arr->[ $i - 2 ] }->[ 0 ] ) ) and
            ( ( $i >= @{$arr} - 2 ) or
              ( $weight <= $operators{ $arr->[ $i + 2 ] }->[ 0 ] ) ) and
            ( $lhs->[ 0 ] == LITERAL ) and ( $rhs->[ 0 ] == LITERAL ) )
        {
            my ( $original );

            #  Rebuild of "original" is surely hackery of the finest order. :(
            $original = ( $lhs->[ 3 ] ? "( $lhs->[ 1 ] )" : $lhs->[ 1 ] ) .
                " $op " .
                ( $rhs->[ 3 ] ? "( $rhs->[ 1 ] )" : $rhs->[ 1 ] );

            splice( @{$arr}, $i - 1, 3,
                [ LITERAL, $original,
                  $self->_eval_op( $op, $lhs, $rhs ), 1 ] );
            $i = ( $i <= 3 ) ? 1 : $i - 4;
#print "  Folding, arr becomes: ", Data::Dumper::Dumper( $arr ), ", i = $i\n";
        }
    }

    return( $arr->[ 0 ] ) if @{$arr} == 1;

    $highest_weight = 0;
    for( my $i = 1; $i < @{$arr} - 1; $i += 2 )
    {
        my ( $op );

        $op = $arr->[ $i ];
#print "looking at op $i: $op\n";
        if( $operators{ $op }->[ 0 ] > $highest_weight )
        {
            $highest_weight = $operators{ $op }->[ 0 ];
            $highest_pos    = $i;
        }
    }
#print "highest_pos = $highest_pos, highest_op = $highest_op\n";

    $op  = $arr->[ $highest_pos ];
    $lhs = $self->_build_op_tree( [ @{$arr}[ 0..$highest_pos - 1 ] ] );
    $rhs = $self->_build_op_tree( [ @{$arr}[ $highest_pos + 1..@{$arr} - 1 ] ] );

    return( [ OP_TREE, '', $op, $lhs, $rhs ] );
}

sub _build_var
{
    my ( $self, $segments, $originals, $original ) = @_;
    my @segments  = @{$segments};
    my @originals = @{$originals};

    #  If we're just a subexpression with no subscripts, just return
    #  the subexpression.
    return( $segments[ 0 ] )
        if @segments == 1 and ref( $segments[ 0 ] );

    if( $segments[ @segments - 1 ] eq '__size__' )
    {
        pop @segments;
        pop @originals;
        return( [ FUNC, $original, 'size',
            [ $self->_build_var( \@segments, \@originals, $original ) ],
            ] );
    }

    return( [ VAR, $original, \@segments, \@originals, @segments - 1 ] );
}

sub _compile_chained_operation
{
    my ( $self, $chain ) = @_;
    my ( $original, $original_so_far, @segments, @originals, $segment,
         $subscript );

#print "compile_chained_operation( $chain )\n";

    return( $symbolic_literals{ $chain } )
        if exists( $symbolic_literals{ $chain } );


    $original = $chain;

    @segments = @originals = ();
    if( ( $segment, $chain ) =
            $chain =~ $capture_chained_operation_top_regexp )
    {
#        $segment = $1;
#        $chain   = $2 || '';
        $original_so_far = $segment;

#print "Capture top on '$original', segment '$segment', chain '$chain'\n";

        if( $segment =~ $capture_function_regexp )
        {
            push @originals, $segment;
            $segment = $self->_compile_function( $1, $2, $original );
            return( $segment ) unless $chain;
            $segment = $segment->[ 2 ] if $segment->[ 0 ] == LITERAL;
            push @segments, $segment;
        }
        else
        {
            push @segments, $segment;
            push @originals, $segment;
        }
    }
    else
    {
        #  TODO FIXME: error.
        die "FIXME";
    }

    while( $chain and
           ( $segment, $chain ) =
                $chain =~ $capture_chained_operation_subscript_regexp )
    {
#        $segment = $1;
#        $chain   = $2 || '';
#print "Segment: $segment\nRest: $chain\n";

        #  TODO: use a capture rather than m// and s///
        if( $segment =~ $capture_literal_subscript_regexp )
        {
#print "  Literal\n";
            $original_so_far .= $segment;
            push @segments,  $1;
            push @originals, $1;
            next;
        }
        if( ( $subscript ) = $segment =~ $capture_expr_subscript_regexp )
        {
#print "  Expr\n";
            #  var[ ... ] expression subscript notation.

            $original_so_far .= $segment;
#            $subscript = $1;
            my $index = $self->_compile_expression( $subscript );

            #  If it's a constant push it up as if it
            #  was a dotted literal index.
            if( $index->[ 0 ] == LITERAL )
            {
                push @segments, $index->[ 2 ];
            }
            else
            {
                push @segments, $index;
            }
#            $subscript =~ s/^\s+//o;
#            $subscript =~ s/\s+$//o;
            push @originals, $subscript;
            next;
        }
        #  TODO: use a capture rather than m// and s///
        if( my ( $method, $args ) =
                $segment =~ $capture_method_subscript_regexp )
        {
#print "  Method\n";

            my $var = $self->_build_var( \@segments, \@originals,
                $original_so_far );

            if( $self->{ vmethods } )
            {
                #  We convert "vmethods" into our normal function style.

                my $func = $self->_compile_function(
                    $method, $args, $original, [ $var ] );

                #  Fold if it's a literal.
                $func = $func->[ 2 ] if $func->[ 0 ] == LITERAL;
                @segments = ( $func );
            }
            else
            {
                $args = $self->_compile_function_args( $args );
                @segments  = ( [ METHOD, $original, $var, $method, $args ] );
            }
            @originals = ( $original_so_far );
            $original_so_far .= $segment;
            next;
        }
        #  TODO FIXME: error.
        die "FIXME";
    }

    $self->error( "Malformed variable segment: '$chain' in '$original'" )
        if $chain;

    return( $self->_build_var( \@segments, \@originals, $original ) );
}

sub _compile_function
{
    my ( $self, $func, $args, $expression, $prepend_args ) = @_;
    my ( $numargs, $func_def );

#    $args = length( $args) > 2 ? substr( $args, 1, -2 ) : '';

    $func_def = $functions{ $func } if $functions{ $func };
    $func_def = $self->{ local_functions }->{ $func }
        if $self->{ local_functions } and
           $self->{ local_functions }->{ $func };

    $self->error( "Unknown function: $func" ) unless $func_def;

    $args = $self->_compile_function_args( $args );
    unshift @{$args}, @{$prepend_args} if $prepend_args;

    #  Check the number of args.
    if( ( $numargs = $func_def->[ FUNC_ARG_NUM ] ) >= 0 )
    {
        $self->error( "too few args to $func(), expected $numargs " .
            "and got " . @{$args} . " in $expression" )
            if @{$args} < $numargs;
        $self->error( "too many args to $func(), expected $numargs " .
            "and got " . @{$args} . " in $expression" )
            if @{$args} > $numargs;
    }

    unless( $func_def->[ FUNC_INCONST ] )
    {
        my ( $nonliteral );

        foreach my $arg ( @{$args} )
        {
            next if $arg->[ 0 ] == LITERAL;
            $nonliteral = 1;
            last;
        }

#CORE::warn( "$expression has " . ( $nonliteral ? "nonliteral" : "literal" ) . " args" );
        unless( $nonliteral )
        {
            my ( $ret );

            $ret = $self->_eval_function( $func, $args );

            return( [ LITERAL, $expression,
                ( ( ref( $ret ) eq 'SCALAR' ) ? ${$ret} : $ret ), 1 ] );
        }
    }

    unshift @{$args}, [ TEMPLATE ]
        if $func_def->[ FUNC_NEEDS_TEMPLATE ];

    return( [ FUNC, $expression, $func, $args ] );
}

sub _compile_function_args
{
    my ( $self, $arglist ) = @_;
    my ( $original, @args, $nextarg );

    $arglist =~ s/^\s+//;
    $arglist =~ s/\s+$//;

    $original = $arglist;

    @args = ();
    while( defined( $arglist ) and length( $arglist ) and
        ( $nextarg, $arglist ) =
            ( $arglist =~ $capture_expr_comma_remain_regexp ) )
    {
#        $nextarg = $1;
#        $arglist = $2;
        push @args, $self->_compile_expression( $nextarg );
    }
    $self->error(
        "Malformed function arguments list: '$arglist' in '$original'" )
        if $arglist;
    return( \@args );
}

sub _eval_expression
{
    my ( $self, $expr, $undef_ok ) = @_;
    my ( $type, $val );

#  "can't happen" in normal use, will error on next line anyway.
#    $self->error( "Bad arg to _eval_expression(): $expr" )
#        unless ref( $expr );

#$self->{ exprcount }->{ $type }++;
#my $exprstart = Time::HiRes::time();
    if( ( $type = $expr->[ 0 ] ) == LITERAL )
    {
        $val = $expr->[ 2 ];
    }
    elsif( $type == VAR )
    {
        $val = $self->_eval_var( @{$expr}, $undef_ok );
    }
    elsif( $type == OP_TREE )
    {
#        $val = $self->_eval_op( $expr->[ 2 ], $expr->[ 3 ], $expr->[ 4 ] );
        #  WARNING: this is unrolled below from _eval_op: keep in sync.
#eval
#{
        $val = $operators{ $expr->[ 2 ] };
        #  Do we defer evaluation or not?
        if( $val->[ 2 ] )
        {
            $val = $val->[ 1 ]->( $self, $expr->[ 3 ], $expr->[ 4 ] );
        }
        else
        {
            $val = $val->[ 1 ]->( $self,
                $self->_eval_expression( $expr->[ 3 ] ),
                $self->_eval_expression( $expr->[ 4 ] ) );
        }
#};
#$self->error( "$@" ) if $@;
    }
    elsif( $type == UNARY_OP )
    {
        #  TODO: unroll?  common enough to bother?
        $val = $self->_eval_unary_op( $expr->[ 2 ], $expr->[ 3 ] );
    }
    elsif( $type == FUNC )
    {
#        $val = $self->_eval_function( $expr->[ 2 ], $expr->[ 3 ] );
        #  WARNING: this is unrolled below from _eval_function: keep in sync.

#warn "Eval func $expr->[ 2 ] against " . _tinydump( [ @function_table ] );
#        $val = $function_table[ $expr->[ 2 ] ];

        #  TODO: should copy_global_functions block class-function lookup?
        $val = $functions{ $expr->[ 2 ] } if $functions{ $expr->[ 2 ] };
        $val = $self->{ local_functions }->{ $expr->[ 2 ] }
            if $self->{ local_functions } and
               $self->{ local_functions }->{ $expr->[ 2 ] };
        $self->error( "Unknown function: $expr->[ 2 ]" ) unless $val;
        if( $val->[ FUNC_UNDEF_OK ] )
        {
            $val = $val->[ FUNC_FUNC ]->(
                map { $self->_eval_expression( $_, 1 ) } @{$expr->[ 3 ]} );
        }
        else
        {
            $val = $val->[ FUNC_FUNC ]->(
                map { $self->_eval_expression( $_ ) } @{$expr->[ 3 ]} );
        }
    }
    elsif( $type == METHOD )
    {
        $val = $self->_eval_method( $expr->[ 2 ], $expr->[ 3 ], $expr->[ 4 ] );
    }
    elsif( $type == TEMPLATE )
    {
        return( $self );
    }
    else
    {
        $self->error( "Unknown expression opcode: $type" );
    }
#$self->{ exprprofile }->{ $type } += Time::HiRes::time() - $exprstart;

    #  Undef warning.
    $self->warning( "undefined template value '$expr->[ 1 ]'" )
        unless defined( $val ) or $undef_ok or $expr->[ 1 ] eq 'undef';

    return( $val );
}

sub _eval_op
{
    my ( $self, $op, $lhs, $rhs ) = @_;

#my $ret;
#$self->{ opcount }->{ $op }++;
#my $opstart = Time::HiRes::time();
#$ret = $operators{ $op }->[ 1 ]->( $self, $lhs, $rhs );
#$self->{ opprofile }->{ $op } += Time::HiRes::time() - $opstart;
#return( $ret );

    #  WARNING: this function is unrolled above in _eval_expr: keep in sync.

    $op = $operators{ $op };

    #  Do we defer evaluation or not?
    return( $op->[ 1 ]->( $self,
        $self->_eval_expression( $lhs ),
        $self->_eval_expression( $rhs ) ) )
        unless $op->[ 2 ];

    return( $op->[ 1 ]->( $self, $lhs, $rhs ) );
}

sub _eval_unary_op
{
    my ( $self, $op, $expr ) = @_;

    #  "|| 0" is there because !1 in perl is '' but we want 0.
    #  !'' gives 1, so seems reasonable !'whatever' should be 0 too not ''.
    return( !$self->_eval_expression( $expr, 1 ) || 0 )
        if $op eq '!';
    return( ( not $self->_eval_expression( $expr, 1 ) ) || 0 )
        if $op eq 'not';
    #  TODO: This is odd for strings, probably should error or warn.
    return( -$self->_eval_expression( $expr ) )
        if $op eq '-';

    $self->error( "Unknown unary operator: '$op'" );
}

sub _assign_var
{
    my ( $self, $lhs, $rhs ) = @_;
    my ( $var_stack, $counter, $sz, $var );

    #  TODO: this should be compile-time ideally.
    $self->error( "Invalid LHS to assignment: $lhs->[ 1 ]" )
        if $lhs->[ 0 ] != VAR;

    #  TODO: this should be compile-time ideally.
    $self->error( "Can only assign to top-level variables: $lhs->[ 1 ]" )
        if @{$lhs->[ 2 ]} > 1;

    $var = $lhs->[ 2 ]->[ 0 ];

    $var_stack = $self->{ var_stack };
    $var_stack->[ 0 ]->{ $var } = $rhs;
    $sz      = @{$var_stack};
    $counter = 1;
    while( $counter < $sz )
    {
        return( $rhs ) unless exists( $var_stack->[ $counter ]->{ $var } );
        $var_stack->[ $counter ]->{ $var } = $rhs;
        $counter++;
    }

    return( $rhs );
}

sub _eval_var
{
    #  The stem value _is_ the value if there's no other segments.
    #  This is pulled above the sub's argument extraction for speed, I
    #  will rot in hell for this, but it _is_ performance-critical.
    return( $_[ 0 ]->{ var_stack_top }->{ $_[ 3 ]->[ 0 ] } )
        unless $_[ 5 ];

    my ( $self, $instr, $original, $segments, $originals, $last, $undef_ok ) = @_;
    my ( $val, $stem, $i, $special_values, $leaf, $type );

    $stem = $segments->[ 0 ];
    $special_values = $self->{ special_values };

    #  Check to see if it's a special loop variable or something.
    if( $last >= 1 and
        $special_values->{ $stem } and
        exists( $special_values_names{ $segments->[ 1 ] } ) )
    {
        #  Don't bother checking that the leaf isn't a ref, it won't
        #  match a key and saves on a ref() call when it isn't.
        $val = $special_values->{ $stem }->[
            $special_values_names{ $segments->[ 1 ] } ];
        $i = 2;
    }
    else
    {
        $i = 1;
        #  Determine the stem (top-level) value
        if( ref( $stem ) )
        {
            #  Top level is an expression not a var.
            $val = $self->_eval_expression( $stem );
        }
        else
        {
            $val = $self->{ var_stack_top }->{ $stem };
        }
    }

    #  Navigate our way down the remaining segments.
    for( ; $i <= $last; $i++ )
    {
        if( ref( $leaf = $segments->[ $i ] ) )
        {
            #  It's an index expression of the style var[index]
            unless( defined( $leaf = $self->_eval_expression( $leaf ) ) )
            {
                return( undef ) if $undef_ok;
                $self->error(
                    "Undefined index '$originals->[ $i ]' in " .
                    "'$original'" );
            }

            #  Check to see if it's a special loop variable or something.
            #  Only need to do this if we're an EXPR subscript, constant
            #  ones will have been checked outside the loop.
            if( $i == 1 )
            {
                if( $special_values->{ $stem } and
                    exists( $special_values_names{ $leaf } ) )
                {
                    $val = $special_values->{ $stem }->[
                        $special_values_names{ $leaf } ];
                    next;
                }
            }
        }

        unless( defined( $val ) )
        {
            return( undef ) if $undef_ok;
            $self->error(
                "Can't get key '$leaf' " .
                ( $originals->[ $i ] ne $leaf ?
                  "(from '$originals->[ $i ]') " : "" ) .
#"(with segments " . Data::Dumper::Dumper( $segments ) . ") " .
                  "of undefined parent in '$original'" );
        }

        if( not ( $type = ref( $val ) ) )
        {
#use Data::Dumper;
#warn "originals = " . Data::Dumper::Dumper( $originals ) . "\ni = $i\nleaf = $leaf\noriginal = $original\nsegments = " . Data::Dumper::Dumper( $segments ) . "\n";

            $self->error(
                "Can't get key '$leaf' " .
                ( $originals->[ $i ] ne $leaf ?
                    "(from '$originals->[ $i ]') " : "" ) .
                "of non-reference parent in '$original'" );
        }
        elsif( $type eq 'ARRAY' )
        {
            $self->error(
                "Can't index array-reference with string '$leaf' " .
                ( $originals->[ $i ] ne $leaf ?
                    "(from '$originals->[ $i ]') " : "" ) .
                "in '$original'" )
                unless $leaf =~ /^\d+$/o;
            $val = defined( $val->[ $leaf ] ) ? $val->[ $leaf ] : undef;
        }
        else
        {
            $val = defined( $val->{ $leaf } ) ? $val->{ $leaf } : undef;
        }
    }

    return( $val );
}

sub _eval_function
{
    my ( $self, $func, $args ) = @_;
    my ( $val );

    #  WARNING: this function is unrolled above in _eval_expr: keep in sync.

    #  TODO: should copy_global_functions block class-function lookup?
    $val = $functions{ $func } if $functions{ $func };
    $val = $self->{ local_functions }->{ $func }
        if $self->{ local_functions } and
           $self->{ local_functions }->{ $func };
    $self->error( "Unknown function: $func" ) unless $val;

    if( $val->[ FUNC_UNDEF_OK ] )
    {
        $args = [ map { $self->_eval_expression( $_, 1 ) } @{$args} ];
    }
    else
    {
        $args = [ map { $self->_eval_expression( $_ ) } @{$args} ];
    }

#$self->{ funccount }->{ $func }++;
#my $ret;
#my $start_time = Time::HiRes::time();
#    $ret = $functions{ $func }->[ 1 ]->( $self, @{$args} );
#$self->{ funcprofile }->{ $func } += Time::HiRes::time() - $start_time;
#    return( $ret );

    if( $val->[ FUNC_NEEDS_TEMPLATE ] )
    {
        return( $val->[ FUNC_FUNC ]->( $self, @{$args} ) );
    }
    else
    {
        return( $val->[ FUNC_FUNC ]->( @{$args} ) );
    }
}

sub _eval_method
{
    my ( $self, $expr, $method, $args ) = @_;
    my ( $exprdesc, $ret );

    $exprdesc = $expr->[ 1 ];
    $expr = $self->_eval_expression( $expr );

    $self->error( "Can't call method on undefined value $exprdesc" )
        unless defined $expr;
    $self->error( "Can't call method on non-reference value $exprdesc: $expr" )
        unless ref( $expr );

    #  For security reasons we don't want to allow calling
    #  just any old method on any old object from within a
    #  potentially user-defined template.
    $self->error( 'Invalid method to call from within a template: ' .
        ref( $expr ) . "->$method" )
        unless $expr->valid_template_method( $method );

    $args = [ map { $self->_eval_expression( $_ ) } @{$args} ];

    $ret = $expr->$method( @{$args} );

    return( $ret );
}

sub run
{
    my $self = $_[ 0 ];
    #  $line, $instr, $value lexically belong inside the loop,
    #  but in such a tight loop it's a performance hit, they're
    #  initialized at the start of each use anyway.
    #  If oddness ensues, move this line into the head of the loop and
    #  see if oddness abates.
    my ( $lineno, $ret, @var_stack, @for_stack, $run_start,
        $program, $last_instr, $special_values, $line, $instr, $value );

    #  For large templates this tricks perl's memory handling into
    #  giving us a big chunk of contiguous memory so that $ret .= $whatever
    #  doesn't have to keep incrementally adding more memory, this can
    #  give a minor-but-not-insignificant speed boost of ~2-3%.
    #  This may be highly sensitive to perl version and OS, and I'm
    #  not sure it does nice things to the memory profile of the process
    #  either...
    $ret = ' ' x 80_000;
    $ret = '';
    $lineno = 0;

    @var_stack = ( $self->{ vars } );
    @for_stack = ();

    $self->{ var_stack }     = \@var_stack;
    $self->{ var_stack_top } = $var_stack[ 0 ];

    $self->{ phase } = 'runtime';

#my $total_instr = 0;

#foreach my $prof ( qw/instr expr func op/ )
#{
#    $self->{ "${prof}count" }   = {};
#    $self->{ "${prof}profile" } = {};
#}

    #  Local unroll of some of our properties
    $program        = $self->{ template }->{ program };
    $last_instr     = $self->{ template }->{ last_instr };
#    @function_table =
#        map { $functions{ $_ } } @{$self->{ template }->{ function_table }};
    $special_values = $self->{ special_values };

    while( $lineno <= $last_instr )
    {
        $line  = $program->[ $lineno++ ];
        $self->{ current_pos } = $line->[ 1 ];

        #  TODO: look at $pos->[ 0 ] to determine file and recreate
        #    the "stack" for error traces if neccessary.

#$self->{ instrcount }->{ $line->[ 0 ] }++;
#my $instrstart = Time::HiRes::time();
        if( ( $instr = $line->[ 0 ] ) == LITERAL )
        {
            $ret .= $line->[ 2 ];
        }
        elsif( $instr == EXPR )
        {
            $value = $self->_eval_expression( $line->[ 2 ] );
            $ret .= ( ( ref( $value ) eq 'SCALAR' ) ? ${$value} : $value )
                unless $line->[ 3 ];
        }
        elsif( $instr == JUMP )
        {
#$ret .= "[jump]";
            $lineno = $line->[ 2 ];
        }
        elsif( $instr == JUMP_IF )
        {
#$ret .= "[jump if/unless $line->[3]]";
            $value = $self->_eval_expression( $line->[ 3 ], 1 );
#            $value = not $value if $line->[ 4 ];
            $lineno = $line->[ 2 ] unless $value;
        }
        elsif( $instr == FOR )
        {
            my ( $iterator, $set, $set_value, $hash, $last, $specials_needed );

            $iterator        = $line->[ 3 ];
            $set             = $line->[ 4 ];
            $specials_needed = $line->[ 5 ];

            $set_value = $self->_eval_expression( $set, 1 );
            $set_value = [] unless defined $set_value;

            if( ref( $set_value ) eq 'HASH' )
            {
                $hash      = $set_value;
                $set_value = [ sort( keys( %{$set_value} ) ) ];
            }
            elsif( not ref( $set_value ) )
            {
                #  If it's a number make it into a loop of 0..number.
                #  If they want 1..number they can <: if x != 1 :> inside it.
                $set_value = [ 0..int( $set_value ) ];
            }

#  TODO: assign and compare
            $last = @{$set_value} - 1;
            if( $last == -1 )
            {
                $lineno = $line->[ 2 ];
            }
            else
            {
                my ( $context );

                $value = $set_value->[ 0 ];
                $special_values->{ $iterator } =
                    [
                        0,
                        1,
                        0,
                        1,
                        0,
                        $last == 0 ? 1 : 0,
                        undef,
                        $last == 0 ?
                            undef : $set_value->[ 1 ],
                        $hash ? $hash->{ $value } : undef,
                    ]
                    if $specials_needed;
                #  Optimization: only create a new context if needed.
                if( $var_stack[ 0 ]->{ $iterator } )
                {
                    $context = { %{$var_stack[ 0 ]} };
                    $context->{ $iterator } = $value;
                    unshift @var_stack, $context;
                    $self->{ var_stack_top } = $context;
                }
                else
                {
                    $var_stack[ 0 ]->{ $iterator } = $value;
                }
                unshift @for_stack, [
                    0, $last, $set_value, $hash, $context ? 1 : 0,
                    $specials_needed,
                    ];
            }
        }
        elsif( $instr == END_FOR )
        {
            my ( $iterator, $set_value, $counter, $hash, $last,
                 $specials_needed );

            $iterator = $line->[ 3 ];

            $counter = ++$for_stack[ 0 ]->[ LOOP_STACK_COUNTER ];
            $last    = $for_stack[ 0 ]->[ LOOP_STACK_LAST ];

            if( $counter <= $last )
            {
                $set_value       = $for_stack[ 0 ]->[ LOOP_STACK_SET ];
                $hash            = $for_stack[ 0 ]->[ LOOP_STACK_HASH ];
                $specials_needed = $for_stack[ 0 ]->[ LOOP_STACK_SPECIALS ];

                $var_stack[ 0 ]->{ $iterator } = $set_value->[ $counter ];
                $special_values->{ $iterator } =
                    [
                        $counter,
                        ( $counter % 2 ) ? 0 : 1,
                        $counter % 2,
                        0,
                        $counter == $last ? 0 : 1,
                        $counter == $last ? 1 : 0,
                        $set_value->[ $counter - 1 ],
                        $counter == $last ?
                            undef :
                            $set_value->[ $counter + 1 ],
                        $hash ? $hash->{ $set_value->[ $counter ] } : undef,
                    ]
                    if $specials_needed;

                $lineno = $line->[ 2 ];
            }
            else
            {
                if( $for_stack[ 0 ]->[ LOOP_STACK_CONTEXT ] )
                {
                    shift @var_stack;
                    $self->{ var_stack_top } = $var_stack[ 0 ];
                }
                else
                {
                    delete $var_stack[ 0 ]->{ $iterator };
                }
                shift @for_stack;
                delete $special_values->{ $iterator };
            }
        }
        elsif( $instr == CONTEXT_PUSH )
        {
            my ( $context, $new_context );

            #  TODO: needed ||?  empty contexts should be optimized away now.
            $new_context = $line->[ 2 ] || {};
            $context = { %{$var_stack[ 0 ]} };
            foreach my $var ( keys( %{$new_context} ) )
            {
                $context->{ $var } = $self->_eval_expression(
                    $new_context->{ $var }, 1 )
            }
            unshift @var_stack, $context;
            $self->{ var_stack_top } = $context;
        }
        elsif( $instr == CONTEXT_POP )
        {
#$ret .= "[context_pop]";
            shift @var_stack;
            $self->{ var_stack_top } = $var_stack[ 0 ];
        }
#  TODO:  ick, hate cut-n-paste code.
#  TODO:  unroll constant parts of hash lookups to local var
        elsif( $self->{ local_syntaxes }->{ '.instr' }->{ $instr } )
        {
            my ( $executor, $token );

            $token    = $self->{ local_syntaxes }->{ '.instr' }->{ $instr };
            $executor = $self->{ local_syntaxes }->{ $token }->{ run };
            $value    = $executor->( $self, $token, $line->[ 2 ] );
            $ret .= $value if defined $value;
        }
#  TODO:  ick, hate cut-n-paste code.
#  TODO:  unroll constant parts of hash lookups to local var
        elsif( $syntaxes{ '.instr' }->{ $instr } )
        {
            my ( $executor, $token );

            $token    = $syntaxes{ '.instr' }->{ $instr };
            $executor = $syntaxes{ $token }->{ run };
            $value    = $executor->( $self, $token, $line->[ 2 ] );
            $ret .= $value if defined $value;
        }
        elsif( $instr == DEBUG )
        {
            $self->{ debug }->{ $line->[ 2 ]->{ type } } =
                ( $line->[ 2 ]->{ state } eq 'on' );
        }
#$self->{ instrprofile }->{ $instr } += Time::HiRes::time() - $instrstart;
    }

    delete $self->{ current_pos };
    delete $self->{ var_stack };
    delete $self->{ var_stack_top };
    delete $self->{ phase };

    return( \$ret );
}

sub _tersedump
{
    return( Data::Dumper->new( [ @_ ] )->Terse(1)->Useqq(1)->Dump() );
}

sub _tinydump
{
    return( Data::Dumper->new( [ @_ ] )->Indent(0)->Quotekeys(0)->Pair('=>')->Terse(1)->Useqq(1)->Dump() );
}

sub dumpable_template
{
    my ( $self ) = @_;
    my ( $lineno, $ret, %instr_names );

    $ret = '';
    $lineno = 0;
    %instr_names = (
        (LITERAL)      => 'literal',
        (EXPR)         => 'expr',
        (JUMP)         => 'jump',
        (JUMP_IF)      => 'jump_if',
        (FOR)          => 'for',
        (END_FOR)      => 'end_for',
        (CONTEXT_PUSH) => 'context_push',
        (CONTEXT_POP)  => 'context_pop',
        );

    foreach my $line ( @{$self->{ template }->{ program }} )
    {
        my ( $instr, $file );

        $file = $self->{ template }->{ files }->[ $line->[ 1 ][ 0 ] ];
        $file = 'template-string' if $file =~ m{^string:///};
        $ret .= sprintf( "%04d: [%-20s %3d %3d][%-12s] ", $lineno++,
            $file, $line->[ 1 ][ 1 ], $line->[ 1 ][ 2 ],
            $instr_names{ $line->[ 0 ] } || $line->[ 0 ] );

        $instr = $line->[ 0 ];
        if( $instr == LITERAL )
        {
#            $ret .= "\"$line->[2]\"\n";
            $ret .= _tinydump( $line->[ 2 ] ) . "\n";
        }
        elsif( $instr == EXPR )
        {
            $ret .= _tinydump( $line->[ 2 ] ) .
                ( $line->[ 3 ] ? " (void)" : "" ). "\n";
        }
        elsif( $instr == JUMP )
        {
            $ret .= "$line->[2]\n";
        }
        elsif( $instr == JUMP_IF )
        {
            $ret .= $line->[ 2 ] . ' unless ' .
                _tinydump( $line->[ 3 ] ) . "\n";
        }
        elsif( $instr == FOR )
        {
            $ret .= "$line->[ 3 ] in " . _tinydump( $line->[ 4 ] ) .
                " then $line->[ 2 ]";
            $ret .= " (no special-vars)" unless $line->[ 5 ];
            $ret .= "\n";
        }
        elsif( $instr == END_FOR )
        {
            $ret .= "$line->[ 3 ] in " . _tinydump( $line->[ 4 ] ) .
                " repeat $line->[ 2 ]\n";
        }
        elsif( $instr == CONTEXT_PUSH )
        {
            $ret .= "context push of " . _tinydump( $line->[ 2 ] ) . "\n";
        }
        elsif( $instr == CONTEXT_POP )
        {
            $ret .= "context pop\n";
        }
#  TODO: local syntax support.
    }

    return( $ret );
}

#sub _decompile_template
#{
#    my ( $self ) = @_;
#    my ( $lineno, $ret );
#
#    $ret = '';
#    $lineno = 0;
#
#    foreach my $line ( @{$self->{ template }->{ program }} )
#    {
#        my ( $instr );
#
#        $instr = $line->[ 0 ];
#        if( $instr == LITERAL )
#        {
#            $ret .= ( $line->[ 2 ] =~ /^$/ ) ?
#                "<: empty literal :>" : $line->[ 2 ];
#            next;
#        }
#        $ret .= "<: $instr ";
#        if( $instr == EXPR )
#        {
#            my ( $dump );
#
#            $dump = Data::Dumper::Dumper( $line->[ 2 ] );
#            $dump =~ s/^\$VAR1 = //;
#            $dump =~ s/;\n$//;
#            $ret .= $line->[ 2 ]->[ 1 ] . " ($dump)";
#        }
#        elsif( $instr == JUMP )
#        {
#            $ret .= "$line->[2]";
#        }
#        elsif( $instr == JUMP_IF )
#        {
#            $ret .= $line->[ 2 ] .
#                ( $line->[ 4 ] ? ' unless ' : ' if ' ) .
#                "$line->[3]";
#        }
#        elsif( $instr == FOR )
#        {
#            $ret .= "$line->[ 3 ] in $line->[ 4 ] then $line->[ 2 ]";
#        }
#        elsif( $instr == END_FOR )
#        {
#            $ret .= "$line->[ 3 ] in $line->[ 4 ] repeat $line->[ 2 ]";
#        }
#        elsif( $instr == CONTEXT_PUSH )
#        {
#            my ( $dump );
#
#            $dump = defined( $line->[ 2 ] ) ? Data::Dumper::Dumper( $line->[ 2 ] ) : 'undef';
#            $dump =~ s/^\$VAR1 = //;
#            $dump =~ s/;\n$//;
#            $dump =~ s/\s+/ /g;
#            $ret .= "context push of $dump";
#        }
#        elsif( $instr == CONTEXT_POP )
#        {
#            $ret = substr( $ret, 0, -1 );
#        }
##  TODO: support for local syntax
#        else
#        {
#            $ret .= "(unhandled by decompile)";
#        }
#        $ret .= " :>";
#    }
#
#    return( $ret );
#}

1;

__END__