File Coverage

blib/lib/HTML/Template/Compiled.pm

Criterion	Covered	Total	%
statement	789	919	85.8
branch	262	378	69.3
condition	83	147	56.4
subroutine	98	110	89.0
pod	22	67	32.8
total	1254	1621	77.3

package HTML::Template::Compiled;
our $VERSION = '1.002_001'; # TRIAL VERSION
use Data::Dumper;
use Scalar::Util;
BEGIN {
use constant D => $ENV{HTC_DEBUG} || 0;
}
use strict;
use warnings;
use Digest::MD5 qw/ md5_hex /;

use Carp;
use Fcntl qw(:seek :flock);
use File::Spec;
use File::Basename qw(dirname basename);
use HTML::Template::Compiled::Utils qw(:walkpath :log :escape &md5);
use HTML::Template::Compiled::Expression qw(:expressions);
use HTML::Template::Compiled::Compiler;
# TODO
eval {
    require URI::Escape;
};
#eval {
#    require Encode;
#};
#my $Encode = $@ ? 0 : 1;

use base 'Exporter';
our @EXPORT_OK = qw(&HTC);
use HTML::Template::Compiled::Parser qw(
    $CASE_SENSITIVE_DEFAULT $NEW_CHECK
    $DEBUG_DEFAULT $SEARCHPATH
    %FILESTACK %COMPILE_STACK %PATHS $DEFAULT_ESCAPE $DEFAULT_QUERY
    $UNTAINT $DEFAULT_TAGSTYLE $MAX_RECURSE
);
use vars qw($__ix__);

use constant MTIME    => 0;
use constant CHECKED  => 1;
use constant LMTIME   => 2;
use constant LCHECKED => 3;

use constant DEBUG_COMPILED => 0b001;

use constant DEBUG_CACHE_FILE_MISS => 0b0001;
use constant DEBUG_CACHE_FILE_HIT  => 0b0010;
use constant DEBUG_CACHE_MEM_MISS  => 0b0100;
use constant DEBUG_CACHE_MEM_HIT   => 0b1000;

our $DEBUG = 0;
our $LAST_EXCEPTION;

# options / object attributes
use constant PARAM => 0;

BEGIN {
    my @map = (
        undef, qw(
          path md5_path filename file scalar filehandle
          file_cache cache_dir cache search_path
          loop_context case_sensitive global_vars
          default_path
          debug debug_file objects perl out_fh default_escape
          filter formatter
          globalstack use_query parse_tree parser compiler includes
          plugins open_mode chomp expire_time strict warnings line_info
          args optimize
        )
          #use_expressions
    );

    for my $i ( 1 .. $#map ) {
        my $method = "_$map[$i]";
        my $get    = sub { return $_[0]->[$i] };
        my $set;
            $set = sub { $_[0]->[$i] = $_[1] };
        no strict 'refs';
        *{"get$method"} = $get;
        *{"set$method"} = $set;
    }
}

# tired of typing?
sub HTC { __PACKAGE__->new(@_) }

sub new {
    my ( $class, %args ) = @_;
    D && $class->log("new()");
    # handle the "type", "source" parameter format (does anyone use it?)
    if ( exists $args{type} ) {
        exists $args{source} or $class->_error_no_source();
        $args{type} =~ m/^(?:filename|scalarref|arrayref|filehandle)$/
          or $class->_error_wrong_source();
        $args{ $args{type} } = $args{source};
        delete $args{type};
        delete $args{source};
    }
    if (exists $args{filename}) {
        return $class->new_file($args{filename}, %args);
    }
    elsif (exists $args{scalarref}) {
        return $class->new_scalar_ref($args{scalarref}, %args);
    }
    elsif (exists $args{filehandle}) {
        return $class->new_filehandle($args{filehandle}, %args);
    }
    elsif (exists $args{arrayref}) {
        return $class->new_array_ref($args{arrayref}, %args);
    }
    croak("$class->new called with not enough arguments");
}

sub _error_no_query {
    my ($self) = @_;
    my $class = ref $self || $self;
    carp "You are using query() but have not specified that you want to use it"
    . " (specify with use_query => 1)";
}

sub _error_not_compiled {
    my ($self) = @_;
    my $class = ref $self || $self;
    carp "Template was not compiled yet";
}

sub _error_wrong_source {
    my ($self) = @_;
    my $class = ref $self || $self;
    croak("$class->new() : type parameter must be set to 'filename', "
        . "'arrayref', 'scalarref' or 'filehandle'!");
}

sub _error_no_source {
    my ($self) = @_;
    my $class = ref $self || $self;
    croak("$class->new() called with 'type' parameter set,"
       . " but no 'source'!");
}

sub _error_template_sources {
    my ($self) = @_;
    my $class = ref $self || $self;
    croak(
        "$class->new called with multiple (or no) template sources specified!"
          . "A valid call to new() has exactly ne filename => 'file' OR exactly one"
          . " scalarref => \\\$scalar OR exactly one arrayref => \\\@array OR"
          . " exactly one filehandle => \*FH"
      );
}

sub _error_empty_filename {
    my ($self) = @_;
    my $class = ref $self || $self;
    croak("$class->new called with empty filename parameter!");
}

sub new_from_perl {
    my ($class, %args) = @_;
    my $self = bless [], $class;
    $self->init_args(\%args);
    D && $self->log("new(perl) filename: $args{filename}");

    $self->init_cache(\%args);
    $self->init(%args);
    $self->set_perl( $args{perl} );
    $self->set_filename( $args{filename} );
    my $md5path = md5_hex(@{ $args{path} || [] });
    $self->set_path( $args{path} );
    $self->set_md5_path( $md5path );
    $self->set_scalar( $args{scalarref} );

    unless ( $self->get_scalar ) {
        my $file =
          $self->createFilename( $self->get_path, \$self->get_filename );
        $self->set_file($file);
    }
    return $self;
}

sub new_file {
    my ($class, $filename, %args) = @_;
    my $self = bless [], $class;
    $self->init_args(\%args);
    $args{path} = $self->build_path($args{path});
    $self->_error_empty_filename()
        if (!defined $filename or !length $filename);
    $args{filename} = $filename;
    if (exists $args{scalarref}
        || exists $args{arrayref} || exists $args{filehandle}) {
        $self->_error_template_sources;
    }
    $self->set_filename( $filename );
    $self->init_cache(\%args);
    my $md5path = md5_hex(@{ $args{path} || [] });
    $self->set_path( $args{path} );
    $self->set_md5_path( $md5path );
    if (my $t = $self->from_cache(\%args)) {
        $t->init_includes();
        return $t;
    }
    $self->init(%args);
    $self->from_scratch;
    $self->init_includes;
    return $self;
}

sub new_filehandle {
    my ($class, $filehandle, %args) = @_;
    my $self = bless [], $class;
    $self->init_args(\%args);
    if (exists $args{scalarref}
        || exists $args{arrayref} || exists $args{filename}) {
        $self->_error_template_sources;
    }
    $args{filehandle} = $filehandle;
    $args{path} = $self->build_path($args{path});
    $self->set_filehandle( $args{filehandle} );
    $args{cache} = 0;
    $self->init_cache(\%args);
    my $md5path = md5_hex(@{ $args{path} || [] });
    $self->set_path( $args{path} );
    $self->set_md5_path( $md5path );
    if (my $t = $self->from_cache(\%args)) {
        return $t;
    }
    $self->init(%args);
    $self->from_scratch;
    $self->init_includes;
    return $self;
}

sub new_array_ref {
    my ($class, $arrayref, %args) = @_;
    if (exists $args{scalarref}
        || exists $args{filehandle} || exists $args{filename}) {
        $class->_error_template_sources;
    }
    my $scalarref = \( join '', @$arrayref );
    delete $args{arrayref};
    return $class->new_scalar_ref($scalarref, %args);
}

sub new_scalar_ref {
    my ($class, $scalarref, %args) = @_;
    my $self = bless [], $class;
    $self->init_args(\%args);
    if (exists $args{arrayref}
        || exists $args{filehandle} || exists $args{filename}) {
        $self->_error_template_sources;
    }
    $args{scalarref} = $scalarref;
    $args{path} = $self->build_path($args{path});
    $self->init_cache(\%args);
    $self->set_scalar( $args{scalarref} );
    my $text = $self->get_scalar;
    my $md5  = md5($$text);
#    if ($args{cache} and !$md5) {
#        croak "For caching scalarrefs you need Digest::MD5";
#    }
    $self->set_filename($md5);
    D && $self->log("md5: $md5");
    my $md5path = md5_hex(@{ $args{path} || [] });
    $self->set_path( $args{path} );
    $self->set_md5_path( $md5path );
    if (my $t = $self->from_cache(\%args)) {
        return $t;
    }
    $self->init(%args);
    $self->from_scratch;
    $self->init_includes;
    return $self;
}

sub init_includes {
    my ($self) = @_;
    my $includes = $self->get_includes;
    my $cache = $self->get_cache_dir||'';
    for my $fullpath (keys %$includes) {
        my ($path, $filename, $htc) = @{ $includes->{$fullpath} };
        D && $self->log("checking $fullpath ($filename) $htc?");
        # TODO check $cache
        $cache .= '-' . $self->get_md5_path;
        #warn __PACKAGE__.':'.__LINE__.": init_includes() $filename\n";
        if (not $htc or HTML::Template::Compiled::needs_new_check($cache||'',$filename, $self->get_expire_time)
        ) {
            $htc = $self->new_from_object($path,$filename,$fullpath,$cache);
        }
        $includes->{$fullpath}->[2] = $htc;
        $includes->{$fullpath}->[2]->set_plugins($self->get_plugins);
    }
}

sub build_path {
    my ($self, $path) = @_;
    unless (defined $path) {
        $path = [];
    }
    elsif (!ref $path) {
        $path = [$path];
    }
    defined $ENV{'HTML_TEMPLATE_ROOT'}
        and push @$path, $ENV{'HTML_TEMPLATE_ROOT'};
    return $path;
}

sub from_scratch {
    my ($self) = @_;
    D && $self->log("from_scratch filename=".$self->get_filename);
    my $fname = $self->get_filename;
    if ( defined $fname and !$self->get_scalar and !$self->get_filehandle ) {

        #D && $self->log("tried from_cache() filename=".$fname);
        my $file = $self->createFilename( $self->get_path, \$fname );
        D && $self->log("set_file $file ($fname)");
        $self->set_file($file);
    }
    elsif ( defined $fname ) {
        $self->set_file($fname);
    }
    D && $self->log( "compiling... " . $self->get_filename );
    $self->compile();
    return $self;
}

sub from_cache {
    my ($self, $args) = @_;
    my $t;
    D && $self->log( "from_cache() filename=" . $self->get_filename );

    $args ||= {};
    my $plug = $args->{plugin} || [];
    my $debug = $self->get_debug || $args->{debug};
    # try to get memory cache
    if ( $self->get_cache ) {
        my $dir = $self->get_cache_dir;
        $dir = '' unless defined $dir;
        $dir .= '-' . $self->get_md5_path;
        my $fname  = $self->get_filename;
        $t = $self->from_mem_cache($dir,$fname, $args);
        if ($t) {
            $t->set_args($args);
            if (@$plug) {
                $t->set_plugins($plug);
                $t->load_plugins($plug);
            }
            if ($debug->{cache} & DEBUG_CACHE_MEM_HIT) {
                warn "### HTML::Template::Compiled Cache Debug ### MEM CACHE HIT: $fname\n";
            }
            return $t;
        }
#        warn __PACKAGE__.':'.__LINE__.": not in mem cache: $fname\n";
        if ($debug->{cache} & DEBUG_CACHE_MEM_MISS) {
            warn "### HTML::Template::Compiled Cache Debug ### MEM CACHE MISS: @{[ $self->get_filename ]}\n";
        }
    }
    D && $self->log( "from_cache() 2 filename=" . $self->get_filename );

    # not in memory cache, try file cache
    if ( $self->get_cache_dir ) {
        my $file = $self->get_scalar || $self->get_filehandle
            ? $self->get_filename
            : $self->createFilename( $self->get_path, \$self->get_filename );
        my $dir     = $self->get_cache_dir;
        if (defined $dir and not -d $dir) {
            croak "Cachedir '$dir' does not exist";
        }
        $t = $self->from_file_cache($dir, $file);
        if ($t) {
            $t->set_args($args);
            if (@$plug) {
                $t->set_plugins($plug);
                $t->load_plugins($plug);
            }
            if ($debug->{cache} & DEBUG_CACHE_FILE_HIT) {
                warn "### HTML::Template::Compiled Cache Debug ### FILE CACHE HIT: @{[ $self->get_filename ]}\n";
            }
            return $t;
        }
        if ($debug->{cache} & DEBUG_CACHE_FILE_MISS) {
            warn "### HTML::Template::Compiled Cache Debug ### FILE CACHE MISS: @{[ $self->get_filename ]}\n";
        }
    }
    D && $self->log( "from_cache() 3 filename=" . $self->get_filename );
    return;
}

{
    my $cache;
    # {
    #   $cachedir => {
    #     $filename => $htc_object,
    my $times;

    sub needs_new_check {
        my ($dir, $fname, $expire_time) = @_;
        my $times  = $times->{$dir}->{$fname} or return 1;
        my $now = time;
        return 0 if $now - $times->{checked} < $expire_time;
        return 1;
    }

    sub from_mem_cache {
        my ($self, $dir, $fname, $args) = @_;
        my $cached = $cache->{$dir}->{$fname};
        my $times  = $times->{$dir}->{$fname};
        D && $self->log("\$cached=$cached \$times=$times \$fname=$fname\n");
        if ( $cached && $self->uptodate($times, $args) ) {
            return $cached->clone;
        }
        D && $self->log("no or old memcache");
        return;
    }

    sub _debug_cache {
        my ($self) = @_;
        my $dir = $self->get_cache_dir;
        my $objects = $cache->{$dir};
        my $times = $times->{$dir};
        warn Data::Dumper->Dump([\$times], ['times']);
        my @keys = keys %$objects;
        warn Data::Dumper->Dump([\@keys], ['keys']);
    }
    sub add_mem_cache {
        my ( $self, %times ) = @_;
        D && $self->stack(1);
        my $dir = $self->get_cache_dir;
        $dir = '' unless defined $dir;
        my @c = caller();
        $dir .= '-' . $self->get_md5_path;
        my $fname = $self->get_filename;
        D && $self->log( "add_mem_cache $fname" );
        my $clone = $self->clone;
        $clone->clear_params();
        my @plugs = @{ $self->get_plugins || [] };
        for my $i (0 .. $#plugs) {
            if (ref $plugs[$i]) {
                if ($plugs[$i]->can('serialize')) {
                    $plugs[$i] = $plugs[$i]->serialize();
                }
            }
        }
        $clone->set_plugins(\@plugs);
        $cache->{$dir}->{$fname} = $clone;
        $times->{$dir}->{$fname} = \%times;
    }

    sub clear_cache {
        my $dir = $_[0]->get_cache_dir;

        # clear the whole cache
        $cache = {}, $times = {}, return unless defined $dir;

        # only specific directory
        $cache->{$dir} = {};
        $times->{$dir} = {};
    }

    sub clear_filecache {
        my ( $self, $dir ) = @_;
        defined $dir
          or $dir = $self->get_cache_dir;
        return unless -d $dir;
        ref $self and $self->lock;
        opendir my $dh, $dir or die "Could not open '$dir': $!";
        my @files = grep { m/(\.pl|\.storable)$/ } readdir $dh;
        for my $file (@files) {
            my $file = File::Spec->catfile( $dir, $file );
            unlink $file or die "Could not delete '$file': $!";
        }
        ref $self and $self->unlock;
        return 1;
    }

    sub uptodate {
        my ( $self, $cached_times, $args ) = @_;
        return 1 if $self->get_scalar;
        my $expire_time = $self->get_expire_time;
        $expire_time = $args->{expire_time} unless defined $expire_time;
#         unless ($cached_times) {
#             my $dir = $self->get_cache_dir;
#             $dir = '' unless defined $dir;
#             my $fname  = $self->get_filename;
#             my $cached = $cache->{$dir}->{$fname};
#             $cached_times  = $times->{$dir}->{$fname};
#             return unless $cached;
#         }
        my $now = time;
        if ( $now - $cached_times->{checked} < $expire_time ) {
            return 1;
        }
        else {
            my $file = $self->createFilename( $self->get_path, \$self->get_filename );
            $self->set_file($file);
            #print STDERR "uptodate($file)\n";
            my @times = $self->_checktimes($file);
            if ( $times[MTIME] <= $cached_times->{mtime} ) {
                D && $self->log("uptodate template old");
                # set last check time to new value
                $cached_times->{checked} = $now;
                return 1;
            }
        }
        # template is not up to date, re-compile it
        return 0;
    }



}

sub compile {
    my ($self) = @_;
    my ( $source, $compiled );
    my $compiler = $self->get_compiler;
    if ( my $file = $self->get_file and !$self->get_scalar ) {

        D && $self->log( "compile from file " . $file );
        die "Could not open '$file': $!" unless -f $file;
        my @times = $self->_checktimes($file);
        my $text  = $self->_readfile($file);
        my ( $source, $compiled ) = $compiler->compile( $self, $text, $file );
        $self->set_perl($compiled);
        $self->get_cache and $self->add_mem_cache(
            checked => time,
            mtime   => $times[MTIME],
        );
        D && $self->log("compiled $file");

        if ( $self->get_cache_dir ) {
            D && $self->log("add_file_cache($file)");
            $self->add_file_cache(
                $source,
                checked => time,
                mtime   => $times[MTIME],
            );
        }
    }
    elsif ( my $text = $self->get_scalar ) {
        my $md5 = $self->get_filename;    # yeah, weird
        D && $self->log("compiled $md5");
        my ( $source, $compiled ) = $compiler->compile( $self, $$text, $md5 );
        $self->set_perl($compiled);
        if ( $self->get_cache_dir ) {
            D && $self->log("add_file_cache($file)");
            $self->add_file_cache(
                $source,
                checked => time,
                mtime   => time,
            );
        }
    }
    elsif ( my $fh = $self->get_filehandle ) {
        local $/;
        my $data = <$fh>;
        my ( $source, $compiled ) = $compiler->compile( $self, $data, '' );
        $self->set_perl($compiled);

    }
}

sub add_file_cache {
    my ( $self, $source, %times ) = @_;
    $self->lock;
    my $cache    = $self->get_cache_dir;
    if (defined $cache and not -d $cache) {
        croak "Cachedir '$cache' does not exist";
    }
    my $plfile   = $self->escape_filename( $self->get_file );
    my $filename = $self->get_filename;
    my $lmtime   = localtime $times{mtime};
    my $lchecked = localtime $times{checked};
    my $cachefile = "$cache/$plfile";
    D && $self->log("add_file_cache() $cachefile");
    {
        require Storable;
        require B::Deparse;
        local $Storable::Deparse = 1;
        my $clone = $self->clone;
        $clone->prepare_for_cache;
        my $v = $self->VERSION || '0.01';
        my $to_cache = {
            htc => $clone,
            version => $v,
            times => {
                mtime => $times{mtime},
                checked => $times{checked},
            },
        };
        Storable::store($to_cache, "$cachefile.storable");
    }
    $self->unlock;
}

sub get_plugin {
    my ($self, $class) = @_;
    for my $plug (@{ $self->get_plugins || [] }) {
        return $plug if (ref $plug || $plug) eq $class;
    }
    return;
}

sub from_file_cache {
    my ($self, $dir, $file) = @_;
    D && $self->stack;
    D && $self->log("include file: $file");

    my $escaped = $self->escape_filename($file);
    my $req     = File::Spec->catfile( $dir, "$escaped.storable" );
    return unless -f $req;
    return $self->include_file($req);
}

sub include_file {
    my ( $self, $req ) = @_;
    D && $self->log("do $req");
    my $r;
    my $t;
    {
        require Storable;
        require B::Deparse;
        local $Storable::Eval = 1;
        my $cache;
        eval {
            $cache = Storable::retrieve($req);
        };
        #warn __PACKAGE__.':'.__LINE__.": error? $@\n";
        return if $@;
        my $cached_version = $cache->{version};
        $t = $cache->{htc};
        if (($t->VERSION || '0.01') ne $cached_version || !$t->uptodate( $cache->{times} )) {
            # is not uptodate
            return;
        }
        my $plug = $t->get_plugins || [];
        $t->get_cache and $t->add_mem_cache(
            checked => $cache->{times}->{checked},
            mtime   => $cache->{times}->{mtime},
        );
    }
    return $t;
}

sub createFilename {
    my ( $self, $path, $filename_ref, $cwd ) = @_;
    my $filename = $$filename_ref;
    D && $self->log("createFilename($path,$filename)");
    D && $self->stack(1);
#warn __PACKAGE__.':'.__LINE__.": ---- createFilename($path, $$filename_ref, $cwd)\n";
    if ($path) {
        local $" = "\0";
        my $cached = $PATHS{"@$path"}->{$filename};
        return $cached if defined $cached;
    }
    if ( !$path or
        (File::Spec->file_name_is_absolute($filename) &&
        -f $filename) ) {
        return $filename;
    }
    else {
        D && $self->log( "file: " . File::Spec->catfile( $path, $filename ) );
        if ($path && @$path) {
            my @search = @$path;
            for ( @search ) {
                my $fp = File::Spec->catfile( $_, $filename );
                if (-f $fp) {
                    local $" = "\0";
                    $PATHS{"@$path"}->{$filename} = $fp;
                    return $fp;
                }
            }
            # not found in $path, try current template dir
            if (defined $cwd) {
                my $fp = File::Spec->catfile( $cwd, $filename );
                if (-f $fp) {
                    for my $p (@search) {
                        if ($fp =~ m{^\Q$p\E(.*)}) {
                            my $rest = $1;
                            my (undef, @p) = File::Spec->splitdir($rest);
                            $rest = File::Spec->catfile(@p);
                            $$filename_ref = $rest;
                            $PATHS{"@$path"}->{$rest} = $fp;
                        }
                    }
                    return $fp;
                }
            }
        }
        elsif (-f $filename) {
            $PATHS{''}->{$filename} = $filename;
            return $filename;
        }

        # TODO - bug with scalarref
        croak "'$filename' not found";
    }
}

sub dump {
    my ( $self, $var ) = @_;
    require Data::Dumper;
    local $Data::Dumper::Indent   = 1;
    local $Data::Dumper::Sortkeys = 1;
    return Data::Dumper->Dump( [$var], ['DUMP'] );
}

sub dump_var {
    my ($class, $var, $varname) = @_;
    local $Data::Dumper::Terse = 0;
    local $Data::Dumper::Indent = 2;
    local $Data::Dumper::Purity = 0;
    local $Data::Dumper::Pad = "";
    local $Data::Dumper::Useqq = 0;
    local $Data::Dumper::Deepcopy = 0;
    local $Data::Dumper::Quotekeys = 1;
    local $Data::Dumper::Bless = 'bless';
    local $Data::Dumper::Pair = ' => ';
    local $Data::Dumper::Maxdep = 0;
    local $Data::Dumper::Useperl = 0;
    local $Data::Dumper::Sortkeys = 1;
    return Data::Dumper->Dump( [$var], [$varname] );
}

sub init_cache {
    my ($self, $args) = @_;
    my $cachedir = $args->{file_cache_dir};
    if ($args->{file_cache}) {
        $self->set_cache_dir($cachedir) if $args->{file_cache};
    }
    $self->set_cache( exists $args->{cache} ? $args->{cache} : 1 );
}

sub init_args {
    my ($self, $args) = @_;

    if (exists $args->{cache_dir}) {
        # will soon be deprecated
        $args->{file_cache_dir} = delete $args->{cache_dir};
        unless (exists $args->{file_cache}) {
            # warn in future versions
            $args->{file_cache} = 1;
        }
    }

    if ($args->{plugin} and (ref $args->{plugin}) ne 'ARRAY') {
        $args->{plugin} = [$args->{plugin}];
    }
    my $debug_cache_args = delete $args->{cache_debug} || 0;
    my $debug_cache = 0;
    if ($debug_cache_args) {
        unless (ref $debug_cache_args) {
            # no array ref, just a true value
            $debug_cache |= DEBUG_CACHE_FILE_MISS | DEBUG_CACHE_FILE_HIT | DEBUG_CACHE_MEM_MISS | DEBUG_CACHE_MEM_HIT;
        }
        else {
            for my $opt (@$debug_cache_args) {
                if ($opt eq 'file_miss') {
                    $debug_cache |= DEBUG_CACHE_FILE_MISS;
                }
                elsif ($opt eq 'file_hit') {
                    $debug_cache |= DEBUG_CACHE_FILE_HIT;
                }
                elsif ($opt eq 'mem_miss') {
                    $debug_cache |= DEBUG_CACHE_MEM_MISS;
                }
                elsif ($opt eq 'mem_hit') {
                    $debug_cache |= DEBUG_CACHE_MEM_HIT;
                }
            }
        }
    }
    # check deprecated
    for (qw(method_call deref formatter_path default_path formatter)) {
        if (exists $args->{$_}) {
            croak "Option $_ is deprecated, see documentation";
        }
    }
    if (exists $args->{dumper}) {
        croak "Option dumper is deprecated, use a plugin instead";
    }

    my $debug_file = delete $args->{debug_file} || 0;
    my $debug_compiled = delete $args->{debug} ? 1 : 0;
    my $debug = 0;
    $debug |= DEBUG_COMPILED if $debug_compiled;

    $args->{debug} = {
        options => $debug,
        file    => $debug_file,
        cache   => $debug_cache,
    };
    my %optimize = (
        initial_var  => 1,
        object_check => 0,
        root_hash    => 0,
        %{ $args->{optimize} || {} },
    );

    %$args = (
        search_path_on_include => $SEARCHPATH,
        loop_context_vars      => 0,
        case_sensitive         => $CASE_SENSITIVE_DEFAULT,
#        debug_file             => 0,
        objects                => 'strict',
        out_fh                 => 0,
        global_vars            => 0,
        default_escape         => $DEFAULT_ESCAPE,
        default_path           => PATH_DEREF,
        use_query              => $DEFAULT_QUERY,
        #use_expressions        => 0,
        use_perl               => 0,
        open_mode              => '',
        no_includes            => 0,
        pre_chomp              => 0,
        post_chomp             => 0,
        expire_time            => $NEW_CHECK,
        strict                 => 1,
        optimize               => \%optimize,
        %$args,
    );
    $self->set_args($args);
#    return %defaults;
}

sub init {
    my ( $self, %args ) = @_;
    $self->set_expire_time($args{expire_time});
    $self->set_loop_context(1) if $args{loop_context_vars};
    $self->set_case_sensitive( $args{case_sensitive} );
    $self->set_default_escape( $args{default_escape} );
    $self->set_default_path( $args{default_path} );
    $self->set_use_query( $args{use_query} );
    $self->set_chomp([$args{pre_chomp}, $args{post_chomp}]);
    $self->set_strict( $args{strict} );
    $self->set_optimize($args{optimize});
    my $warnings = $args{warnings} || 0;
    unless ($warnings eq 1 or $warnings eq 'fatal') {
        $warnings = 0;
    }
    $self->set_warnings($warnings);
    my $line_info = 0;
    if ($args{line_info}) {
        $line_info = 1;
    }
    $self->set_line_info($line_info);
    #$self->set_use_expressions( $args{use_expressions} );
    if ($args{use_expressions}) {
        require HTML::Template::Compiled::Expr;
    }
    $args{open_mode} = '' unless length $args{open_mode};
    if ($args{open_mode}) {
        $args{open_mode} =~ s/^[<>]//; # <:utf8
    }
    $self->set_open_mode( $args{open_mode} );
    $self->set_search_path( $args{search_path_on_include} );
    $self->set_includes({});
    if ( $args{filter} ) {
        require HTML::Template::Compiled::Filter;
        $self->set_filter(
            HTML::Template::Compiled::Filter->new( $args{filter} ) );
    }
    $self->set_debug( $args{debug} );
    $self->set_debug_file( $args{debug_file} );
    $self->set_objects( $args{objects} );
    $self->set_out_fh( $args{out_fh} );
    $self->set_global_vars( $args{global_vars} );
    if (my $plugins = $args{plugin}) {
        $self->set_plugins($plugins);
    }
    my $compiler = $self->compiler_class->new;
    $self->set_compiler($compiler);
    my $tagstyle = $args{tagstyle};
    my $parser;
    if (ref $tagstyle eq 'ARRAY') {
        # user specified named styles or regexes
        $parser = $self->parser_class->new(
            tagstyle        => $tagstyle,
            use_expressions => $args{use_expressions},
            strict          => $args{strict},
        );
        $parser->set_perl($args{use_perl});
    }
    $args{parser} = ${$args{parser}} if ref $args{parser} eq 'REF';
    if (UNIVERSAL::isa($args{parser}, 'HTML::Template::Compiled::Parser')) {
        $parser = $args{parser};
    }
    unless ($parser) {
        $parser ||= $self->parser_class->default();
        $parser->set_perl($args{use_perl});
        $parser->set_expressions($args{use_expressions});
        $parser->set_strict($args{strict});
    }
    $parser->set_chomp([$args{pre_chomp}, $args{post_chomp}]);
    if ($args{use_perl}) {
        $parser->add_tagnames({
            HTML::Template::Compiled::Token::OPENING_TAG() => {
                PERL => [sub { 1 }],
            }
        });
    }
    if ($args{no_includes}) {
        $parser->remove_tags(qw/ INCLUDE INCLUDE_VAR INCLUDE_STRING /);
    }
    $self->set_parser($parser);
    if (my $plugins = $self->get_plugins) {
        $self->init_plugins($plugins);
        $self->set_plugins($plugins);
    }
}

{
    my %_plugins;
    sub load_plugins {
        my ($self, $plugins) = @_;
        for my $plug (@$plugins) {
            next if ref $plug;
            next if $_plugins{$plug};
            if ($plug =~ m/^::/) {
                $plug = "HTML::Template::Compiled::Plugin$plug";
            }
            next if $_plugins{$plug};
            unless ($plug->can('register')) {
                eval "require $plug";
                if ($@) {
                    carp "Could not load plugin $plug\n";
                }
            }
            $_plugins{$plug} = 1;
        }
    }
}

sub init_plugins {
    my ($self, $plugins) = @_;
    $self->load_plugins($plugins);
    my $parser = $self->get_parser;
    my $compiler = $self->get_compiler;
    for my $plug (@$plugins) {
        my $actions = $self->get_plugin_actions($plug);
        if (my $tagnames = $actions->{tagnames}) {
            $parser->add_tagnames($tagnames);
        }
        if (my $escape = $actions->{escape}) {
            $compiler->add_escapes((ref $plug) || $plug, $escape);
        }
        if (my $tags = $actions->{compile}) {
            $compiler->add_tags($tags);
        }
    }
}

{
    my $classes = {};

    sub register {
        my ($class, $plugins) = @_;
        $plugins = [$plugins] unless ref $plugins eq 'ARRAY';
        for my $plug (@$plugins) {
            my $actions = $plug->register;
            my $plug_class = (ref $plug) || $plug;
            $classes->{ $plug_class} = $actions;
            HTML::Template::Compiled::Compiler->setup_escapes($plug_class, $actions->{escape}||{});
        }
    }

    sub get_plugin_actions {
        my ($self, $pclass) = @_;
        return $classes->{ref $pclass || $pclass};
    }
}


sub _readfile {
    my ( $self, $file ) = @_;
    my $open_mode = $self->get_open_mode;
    open my $fh, "<$open_mode", $file or die "Cannot open '$file': $!";
    local $/;
    <$fh>;
}

sub get_code {
    return $_[0]->get_perl;
}

sub compile_early { 1 }

sub method_call { '.' }
sub deref { '.' }
sub formatter_path { '/' }

sub parser_class { 'HTML::Template::Compiled::Parser' }

sub compiler_class { 'HTML::Template::Compiled::Compiler' }

sub quote_file {
    defined(my $f = $_[1]) or return '';
    $f =~ s/'/\\'/g;
    return qq/'$f'/;
}

# this method gets a varname like 'var' or 'object.method'
# or 'hash.key' and makes valid perl code out of it that will
# be eval()ed later
# so assuming . is the character for dereferencing hashes the string
# hash.key (found inside ) will be converted to
# '$t->get_var($P, $$C, 1, [PATH_DEREF, 'key'])'
# the get_var method walks the paths given through the data structure.
# $P is the parameter hash of the template, $C is a reference to the current
# parameter hash. the third argument to get_var is 'final'.
#  is a 'final' path, and  is not.
# so final means it's in 'print-context'.


# -------- warning, ugly code
# i'm trading maintainability for efficiency here

sub try_global {
    my ( $self, $walk, $path ) = @_;
    my $stack = $self->get_globalstack || [];
    #warn Data::Dumper->Dump([\$stack], ['stack']);
    for my $item ( $walk, reverse @$stack ) {
        if (my $code = UNIVERSAL::can($item, $path)) {
            my $r =  $code->($item);
            return $r;
        }
        else {
            next unless exists $item->{$path};
            return $item->{$path};
        }
    }
    return;
}

{
    sub _walk_formatter {
        my ($self, $walk, $key, $global) = @_;
        my $ref = ref $walk;
        my $fm = $HTML::Template::Compiled::Formatter::formatter;
        my $sub = exists $fm->{$ref} ? $fm->{$ref}->{$key} : undef;
        my $stack = [];
        my $new_walk;
        if ($global) {
            $stack = $self->get_globalstack || [];
        }
        for my $item ($walk, reverse @$stack) {
            #print STDERR "::::::: formatter $walk -> $key (sub=$sub)\n";
            if (defined $sub) {
                $new_walk = $sub->($walk);
                last;
            }
            elsif (exists $item->{$key}) {
                #print STDERR "===== \$item->{$key} exists! '$item->{$key}'\n";
                $new_walk = $item->{$key};
                last;
            }
            # try next item in stack
        }
        #print STDERR "---- formatter $walk\n";
        return $new_walk;
    }

	# ----------- still ugly code
    # not needed anymore
#    if (my $formatter = $self->get_formatter() and $final and my $ref = ref $walk) {
#        if (my $sub = $formatter->{$ref}->{''}) {
#            my $return = $sub->($walk,$self,$P);
#            return $return unless ref $return;
#        }
#    }
#	return $walk;
}

# end ugly code, phooey

# returns if the var is valid
# only allow '.', '/', '+', '-' and '_'
# fix 2007-07-23: HTML::Template allows every character
# although the documentation says it doesn't.
sub validate_var {
    return 1;
    #return $_[1] !~ tr{a-zA-Z0-9._[]/#-}{}c;
}

sub escape_filename {
    my ( $t, $f ) = @_;
    $f =~ s#([/:\\])#'%'.uc sprintf"%02x",ord $1#ge;
    return $f;
}

sub _checktimes {
    my $self = shift;
    D && $self->stack;
    my $filename = shift;
    my $mtime    = ( stat $filename )[9];

    #print STDERR "stat $filename = $mtime\n";
    my $checked  = time;
    my $lmtime   = localtime $mtime;
    my $lchecked = localtime $checked;
    return ( $mtime, $checked, $lmtime, $lchecked );
}

sub clone {
    my ($self) = @_;
    return bless [@$self], ref $self;
}

sub new_scalar_from_object {
    my ($self, $scalar) = @_;
    my $new = $self->clone;
    $new->set_includes({});
    $new->set_perl(undef);
    $new->set_filehandle();
    $new->set_cache(0);
    $new->set_cache_dir(undef);
    $new->set_scalar(\$scalar);
    my $md5 = md5($scalar);
    $new->set_filename($md5);
    $new = $new->from_scratch;
    return $new;
}
# create from existing object (TMPL_INCLUDE)
sub new_from_object {
    my ( $self, $path, $filename, $fullpath, $cache ) = @_;
    unless (defined $filename) {
        my ($file) = (caller(1))[3];
        croak "Filename is undef (in template $file)";
    }
    my $new = $self->clone;
    D && $self->log("new_from_object($path,$filename,$fullpath,$cache)");
    $new->set_filename($filename);
    #if ($fullpath) {
    #    $self->set_file($fullpath);
    #}
    $new->set_includes({});
    $new->set_scalar();
    $new->set_filehandle();
    my $md5path = md5_hex(@{ $path || [] });
    $new->set_path($path);
    $new->set_md5_path( $md5path );
    $new->set_perl(undef);
    if (my $cached = $new->from_cache($self->get_args)) {
        $cached->set_plugins($self->get_plugins);
        $cached->init_includes;
        return $cached
    }
    unless ($new->get_compiler) {
        my %args = %{ $self->get_args || {} };
        $new->init(%args);
    }
    $new = $new->from_scratch;
    $new->init_includes;
    return $new;
}

sub prepare_for_cache {
    my ($self) = @_;
    $self->clear_params;
    my @plugs = @{ $self->get_plugins || [] };
    for my $i (0 .. $#plugs) {
        if (ref $plugs[$i]) {
            if ($plugs[$i]->can('serialize')) {
                $plugs[$i] = $plugs[$i]->serialize();
            }
        }
    }
    $self->set_plugins(\@plugs);
    my $includes = $self->get_includes;
    for my $fullpath (keys %$includes) {
        my ($path, $filename, $htc) = @{ $includes->{$fullpath} };
        $includes->{$fullpath} = [$path, $filename];
    }
    $self->set_parser(undef);
    $self->set_compiler(undef);
    $self->set_args(undef);
    $self->set_globalstack(undef);
}

sub preload {
    my ( $class, $dir ) = @_;
    opendir my $dh, $dir or die "Could not open '$dir': $!";
    my @files = grep { m/\.pl|\.storable$/ } readdir $dh;
    closedir $dh;
    my $loaded = 0;
    for my $file (@files) {
        my $success = $class->include_file( File::Spec->catfile( $dir, $file ) );
        $loaded++ if $success;
    }
    return scalar $loaded;
}

sub precompile {
    my ($class, %args) = @_;
    my $files = delete $args{filenames};
    return unless ref $files eq 'ARRAY';
    my @precompiled;
    for my $file (@$files) {
        my $htc = $class->new(%args,
            (ref $file eq 'SCALAR'
                ? 'scalarref'
                : ref $file eq 'ARRAY'
                ? 'arrayref'
                : ref $file eq 'GLOB'
                ? 'filehandle'
                : 'filename') => $file,
        );
        push @precompiled, $htc,
    }
    return \@precompiled;
}

sub clear_params {
    $_[0]->[PARAM] = ();
}

sub get_param {
    return $_[0]->[PARAM];
}

sub param {
    my $self = shift;
    if (!@_) {
        return $self->query();
        return UNIVERSAL::can($self->[PARAM],'can')
            ? $self->[PARAM]
            : $self->[PARAM]
                ? keys %{$self->[PARAM]}
                : ();
    }
    my %p;
    if (@_ == 1) {
        if ( ref $_[0] ) {
            # feed a hashref or object
            if (ref $_[0] eq 'HASH') {
                # hash, no object
                %p = %{ $_[0] };
            }
            else {
                $self->[PARAM] = $_[0];
                return;
            }
        }
        else {
            # query a parameter
            return $self->[PARAM]->{ $_[0] };
        }
    }
    else {
        %p = @_;
    }

    if ( !$self->get_case_sensitive ) {
        my $lc = $self->lchash( {%p} );
        %p = %$lc;
    }
    $self->[PARAM]->{$_} = $p{$_} for keys %p;
}

sub query {
    my ($self, $what, $tags) = @_;
    # param() no arguments should behave like query
    # query() is not activated by default, and
    # my %param = (); $htc->param(%param); should
    # *not* call query(). so we check if the user wants
    # a return value; that indicates that they wanted to
    # use query-like behaviour.
    return unless defined wantarray();
    #print STDERR "query(@_)\n";
    my $info = $self->get_parse_tree
        or do {
            $self->_error_no_query();
            return;
        };
    unless (ref $info) {
        # not compiled yet!
        $self->_error_not_compiled();
        return;
    }
    my $pointer = {children => $info};
    $tags = [] unless defined $tags;
    $tags = [$tags] unless ref $tags eq 'ARRAY';
    my $includes = $self->get_includes;
    my %include_info = map {
        $includes->{$_}->[1] => $includes->{$_}->[2]->get_parse_tree;
    } keys %{ $includes };
    for my $tag (@$tags) {
        my $value;
        my %includes = map {
            my $item = $pointer->{children}->{$_};
            ($item->{type} eq 'INCLUDE' and $include_info{$_})
                ? (%{$include_info{$_}})
                : ()
        } keys %{ $pointer->{children} };
        if (defined ($value = $pointer->{children}->{lc $tag})) {
            $pointer = $value;
        }
        elsif (defined ($value = $includes{lc $tag})) {
            $pointer = $value;
        }
        else {
            return;
        }
    }
    unless ($what) {
        my @return = map {
            my $item = $pointer->{children}->{$_};
            ($item->{type} eq 'INCLUDE' and $include_info{$_})
            ? (keys %{$include_info{$_}})
            : $_;
        } keys %{ $pointer->{children} };
        return @return;
    }
    elsif ($what eq 'name') {
        my $type = $pointer->{type};
        return $type;
    }
    elsif ($what eq 'loop') {
        if ($pointer->{type} eq 'LOOP') {
            my @return = map {
                my $item = $pointer->{children}->{$_};
                ($item->{type} eq 'INCLUDE' and $include_info{$_})
                ? (keys %{$include_info{$_}})
                : $_;
            } keys %{ $pointer->{children} };
            return @return;
        }
        else { croak "error: (@$tags) is not a LOOP" }
    }
    return;
}

# =head2 lchash
#
#   my $capped_href = $self->lchash(\%href);
#
# Input:
#     - hashref or arrayref of hashrefs
#
# Output: Returns a reference to a cloned data structure where all the keys are
# capped.
#
# =cut

sub lchash {
    my ( $self, $data ) = @_;
    my $lc;
    if ( ref $data eq 'HASH' ) {
        for my $key ( keys %$data ) {
            my $uc_key = lc $key;
            my $val    = $self->lchash( $data->{$key} );
            $lc->{$uc_key} = $val;
        }
    }
    elsif ( ref $data eq 'ARRAY' ) {
        for my $item (@$data) {
            my $new = $self->lchash($item);
            push @$lc, $new;
        }
    }
    else {
        $lc = $data;
    }
    return $lc;
}

sub output {
    my ( $self, $fh ) = @_;
    my $p = $self->[PARAM] || {};
    # if we only have an object as parameter
    $p = ref $p eq 'HASH'
        ? \% { $p }
        : $p;
    my $f = $self->get_file;
    $fh = \*STDOUT unless $fh;
    if ($DEBUG) {
        my $output;
        eval {
            $output = $self->get_perl()->( $self, $p, \$p, $fh );
        };
        if ($@) {
            $LAST_EXCEPTION = $@;
            my $filename = $self->get_file;
            die "Error while executing '$filename': $@";
        }
        return $output;
    }
    else {
        $self->get_perl()->( $self, $p, \$p, $fh );
    }
}

sub import {
    my ( $class, %args ) = @_;
    if ( $args{compatible} ) {
        carp "Usage of use option 'compatible' is deprecated";
        $class->CaseSensitive(0);
        $class->SearchPathOnInclude(0);
        $class->UseQuery(1);
    }
    elsif ( $args{speed} ) {
        carp "Usage of use option 'speed' is deprecated";
        # default at the moment
        $class->CaseSensitive(1);
        $class->SearchPathOnInclude(1);
        $class->UseQuery(0);
    }
    if (exists $args{short}) {
        carp "Usage of use option 'short' is deprecated";
        __PACKAGE__->export_to_level(1, scalar caller(), 'HTC');
    }
}

sub var2expression {
    my ($self, $var) = @_;
    $var = $self->get_compiler->parse_var($self,
        var             => $var,
        method_call     => $self->method_call,
        deref           => $self->deref,
        formatter_path => $self->formatter_path,
    );
    return $var;
}

sub ExpireTime {
    my ($class, $seconds) = @_;
    $NEW_CHECK = $seconds;
}

sub EnableSub {
    carp "Warning: Subref variables are not supported any more, use HTML::Template::Compiled::Classic instead";
}

sub CaseSensitive {
    my ($class, $bool) = @_;
    $CASE_SENSITIVE_DEFAULT = $bool ? 1 : 0;
}

sub SearchPathOnInclude {
    my ($class, $bool) = @_;
    $SEARCHPATH = $bool ? 1 : 0;
}

sub UseQuery {
    my ($class, $bool) = @_;
    $DEFAULT_QUERY = $bool ? 1 : 0;
}

sub pushGlobalstack {
    my $stack = $_[0]->get_globalstack;
    push @$stack, $_[1];
    $_[0]->set_globalstack($stack);
}

sub popGlobalstack {
    my $stack = $_[0]->get_globalstack;
    pop @$stack;
    $_[0]->set_globalstack($stack);
}


{
    my $lock_fh;

    sub lock {
        my $file = File::Spec->catfile( $_[0]->get_cache_dir, "lock" );
        unless ( -f $file ) {
            # touch
            open $lock_fh, '>', $file
              or croak "Could not open lockfile '$file' for writing: $!";
            close $lock_fh;
        }
        open $lock_fh, '+<', $file
          or croak "Could not open lockfile '$file' for read/write: $!";
        flock $lock_fh, LOCK_EX;
    }

    sub unlock {
        close $lock_fh;
    }
}


{
    my $loaded = 0;
    my $error = 0;
    sub require_storable {
        return 1 if $loaded;
        return 0 if $error;
        eval {
            require Storable;
        };
        if ($@) {
            $error = 1;
            return 0;
        }
        eval "use B::Deparse 0.61";
        if ($@) {
            $error = 1;
            return 0;
        }
        return 1;
    }
}

sub debug_code {
    my ($self, $html) = @_;
    my $perl = $self->get_perl;
    require B::Deparse;
    my $deparse = B::Deparse->new("-p", "-sC");
    my $body = $deparse->coderef2text($perl);
    my $filename = $self->get_file;
    #warn __PACKAGE__.':'.__LINE__.$".Data::Dumper->Dump([\$body], ['body']);
    my $message = '';
    if ($LAST_EXCEPTION and $LAST_EXCEPTION =~ m/at (?:\(eval \d*\)|\S+) line (\d+)\./) {
        my $rline = $1;
        my $line = $rline;
        $line--;
        my @lines = split m#$/#, $body;
        if ($line > $#lines) {
            $line = $#lines;
        }
        my $pre = $line > 0 ? join $/, @lines[0 .. $line - 1] : '';
        my $post = $line < $#lines ? join $/, @lines[$line + 1 .. $#lines] : '';
        my $error = "$/$/# ------------------- ERROR line $rline in template $filename -----------------$/";
        my $last = $LAST_EXCEPTION;
        $LAST_EXCEPTION =~ s#$/# #g;
        $error .= "# $last$/$lines[$line]$/";
        if ($html) {
            for ($pre, $error, $post) {
                s/
                s/>/>/g;
            }
            $message = <<"EOM";
$pre 




1534




 





 





 





 





 





 



 $error 




1535




 





 





 





 





 





 



 $post


EOM
        }
        else {
            $message .= $pre;
            $message .= $error;
            $message .= $post;
        }
    }
    else {
        $message = $LAST_EXCEPTION;
    }
    return $message;

}

1;

__END__