HTML::Template::Compiled - Template System Compiles HTML::Template files to Perl code

  use HTML::Template::Compiled speed => 1;
  # or for compatibility with HTML::Template
  # use HTML::Template::Compiled compatible => 1;
  # or use HTML::Template::Compiled::Classic
  my $htc = HTML::Template::Compiled->new(filename => 'test.tmpl');
  $htc->param(
    BAND => $name,
    ALBUMS => [
      { TITLE => $t1, YEAR => $y1 },
      { TITLE => $t2, YEAR => $y2 },
    ],
  );
  print $htc->output;

  test.tmpl:
  Band: <TMPL_VAR BAND>
  <TMPL_LOOP ALBUMS>
  Title: <TMPL_VAR TITLE> (<TMPL_VAR YEAR>)
  </TMPL_LOOP>

  use HTML::Template::Compiled compatible => 1;

  use HTML::Template::Compiled speed => 1;

  <TMPL_INCLUDE NAME="file.htc">

  <TMPL_INCLUDE_VAR NAME="file_include_var">
  $htc->param(file_include_var => "file.htc");

    template:
    inc: <%include_string foo %>

    code:
    $htc->param(
        foo => 'included=<%= bar%>',
        bar => 'real',
    );

    output:
    inc: included=real

  my %hash = (
    SELF => '/path/to/script.pl',
    LANGUAGE => 'de',
    BAND => 'Bauhaus',
    ALBUMS => [
    {
      NAME => 'Mask',
      SONGS => [ { NAME => 'Hair of the Dog' }, ... ],
    },
    ],
    INFO => {
      BIOGRAPHY => '...',
      LINK => '...'
    },
    NAME => "Cool script",
  );

  <TMPL_VAR .SELF>

  my $htc = HTML::Template::Compiled->new(
    ...
  );

  $htc->param(
    VAR => "blah",
    OBJECT => bless({...}, "Your::Class"),
  );

  <TMPL_VAR NAME="OBJECT.fullname">
  <TMPL_WITH OBJECT>
  Name: <TMPL_VAR fullname>
  </TMPL_WITH>

    __OUT__ 2**3;

    $OUT .= 2**3;
    # or
    print $fh 2**3;

    <tmpl_perl if (__CURRENT__->count > 42) { >

    <%perl if (__CURRENT__->count > 42) { %>

    <tmpl_loop list>
    <tmpl_perl unless (__INDEX__ % 3) { >
      </tr><tr>
    <tmpl_perl } >
    </tmpl_loop list>

    # takes the current position of the parameter
    # hash, key 'foo' and multiplies it with 3
    <%perl __OUT__ __CURRENT__->{foo} * 3; %>

  <TMPL_LOOP ALBUMS>
  Dump: <TMPL_VAR _ ESCAPE=DUMP|HTML>
  </TMPL_LOOP>

  <TMPL_WITH DEEP.PATH.TO.HASH>
  <TMPL_VAR NAME>: <TMPL_VAR AGE>
  </TMPL_WITH>

  <TMPL_VAR DEEP.PATH.TO.HASH.NAME>: <TMPL_VAR DEEP.PATH.TO.HASH.AGE>

 <tmpl_loop foo>
  Current item: <tmpl_var _ >
 </tmpl_loop>

 <tmpl_loop favourite_colors join=", ">
  <tmpl_var _ >
 </tmpl_loop>

 <tmpl_loop favourite_colors>
 <tmpl_unless __first__>, </tmpl_unless>
  <tmpl_var _ >
 </tmpl_loop>

 <tmpl_loop bingo break="3"> <tmpl_var _ ><if __break__>\n</if></tmpl_loop>

    $htc->param(bingo => [qw(X 0 _ _ X 0 _ _ X)]);

    X 0 _
    _ X 0
    _ _ X

    <tmpl_loop object.list_method context=list>
        <tmpl_var _ >
    </tmpl_loop>

  <tmpl_while resultset.fetchrow>
    <tmpl_var _.0>
  </tmpl_while>

    Sorted alphanumerically by default (since 0.93):
        <tmpl_each letters >
            <tmpl_var __key__ >:<tmpl_var __value__>
        </tmpl_each letters >
    Sorted numerically:
        <tmpl_each numbers sort=num >
            <tmpl_var __key__ >:<tmpl_var __value__>
        </tmpl_each numbers >
    Not sorted:
        <tmpl_each numbers sort=0 >
            <tmpl_var __key__ >:<tmpl_var __value__>
        </tmpl_each numbers >
    Sorted alphanumerically:
        <tmpl_each letters sort=alpha >
            <tmpl_var __key__ >:<tmpl_var __value__>
        </tmpl_each letters >

    <tmpl_each object.hash_method context=list>
    <tmpl_var __key__ >
    </tmpl_each>

  Wanted: <tmpl_var wanted>
    <tmpl_comment outer>
    this won't be printed
      <tmpl_comment inner>
        <tmpl_var unwanted>
      </tmpl_comment inner>
      <tmpl_var unwanted>
  </tmpl_comment outer>

  $htc->param(unwanted => "no thanks", wanted => "we want this");

  Wanted: we want this

  <tmpl_noparse>...</tmpl_noparse>

  <tmpl_verbatim>...</tmpl_verbatim>

 <tmpl_switch language>(or <tmpl_switch name=language>)
  <tmpl_case de>echt cool
  <tmpl_case en>very cool
  <tmpl_case es>superculo
  <tmpl_case fr,se>don't speak french or swedish
  <tmpl_case default>sorry, no translation for cool in language <%=language%> available
  <tmpl_case>(same as default)
 </tmpl_switch>

 <tmpl_case fr,default>

  my $t = HTML::Template::Compiled->new(
    path => 'templates',
    loop_context_vars => 1,
    filename => 'test.html',
    # for testing without cache comment out
    cache_dir => "cache",
  );

    my $htc = HTML::Template::Compiled->new(
        ...
        plugin => ['HTML::Template::Compiled::Foo::Bar'],
        # oor shorter:
        plugin => ['::Foo::Bar'],
    );

  HTML::Template::Compiled->precompile(
    # usual options like path, default_escape, global_vars, cache_dir, ...
    filenames => [ list of template-filenames ],
  );

package HTML::Template::Compiled;
# $Id: Compiled.pm 1113 2011-04-27 18:49:59Z tinita $
# doesn't work with make tardist
#our $VERSION = ($version_pod =~ m/^\$VERSION = "(\d+(?:\.\d+)+)"/m) ? $1 : "0.01";
our $VERSION = "0.95";
use Data::Dumper;
BEGIN {
use constant D => $ENV{HTC_DEBUG} || 0;
}
use strict;
use warnings;
use Digest::MD5 qw/ md5_hex /;

our $Storable = 1;
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;

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
        )
          #use_expressions
    );

    for my $i ( 1 .. $#map ) {
        my $method = "_$map[$i]";
        my $get    = eval qq#sub { return \$_[0]->[$i] }#;
        my $set;
            $set = eval qq#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;
    D && $self->log("new(perl) filename: $args{filename}");

    $self->init_cache(\%args);
    $self->init(%args);
    $self->set_perl( $args{perl} );
    $self->set_cache( exists $args{cache} ? $args{cache} : 1 );
    $self->set_filename( $args{filename} );
    $self->set_cache_dir( $args{cache_dir} );
    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->_check_deprecated_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->set_cache( exists $args{cache} ? $args{cache} : 1 );
    $self->init_cache(\%args);
    #$self->set_cache_dir( $args{cache_dir} );
    my $md5path = md5_hex(@{ $args{path} || [] });
    my $test = $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->_check_deprecated_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} );
    $self->set_cache(0);
    $self->init_cache(\%args);
    #$self->set_cache_dir( $args{cache_dir} );
    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->_check_deprecated_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->set_cache( exists $args{cache} ? $args{cache} : 1 );
    $self->init_cache(\%args);
    #$self->set_cache_dir( $args{cache_dir} );
    $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?");
        $cache .= '-' . $self->get_md5_path;
        if (HTML::Template::Compiled::needs_new_check(
                $cache||'',$filename)
        ) {
            $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 init_runtime_args {
    my ($self, %args) = @_;
    D && $self->log("init_runtime_args()");
    if ( my $filter = $args{filter} ) {
        unless ( $self->get_filter ) {
            $self->set_filter($filter);
        }
    }
    return $self;
}

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} || [];
    # 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);
        if ($t) {
            $t->set_plugins($plug) if @$plug;
            return $t;
        }
    }
    D && $self->log( "from_cache() 2 filename=" . $self->get_filename );

    # not in memory cache, try file cache
    if ( $self->get_cache_dir ) {
        #$self->init_runtime_args(%args);
        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;
        $t = $self->from_file_cache($dir, $file);
        if ($t) {
            $t->set_plugins($plug) if @$plug;
            return $t;
        }
    }
    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) = @_;
        my $times  = $times->{$dir}->{$fname} or return 1;
        my $now = time;
        return 0 if $now - $times->{checked} < $NEW_CHECK;
        return 1;
    }

    sub from_mem_cache {
        my ($self, $dir, $fname) = @_;
        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) ) {
            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 ) = @_;
        return 1 if $self->get_scalar;
#         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} < $NEW_CHECK ) {
            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;
    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");
    if ($Storable and require_storable()) {
        #require Storable;
        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},
            },
        };
        # TODO Storable cannot store qr//
        # but as we don't need those serialized anyway
        # we let Storable just store a dummy entry
        local $Storable::forgive_me = 1;
        local $SIG{__WARN__} = sub {
            my ($w) = @_;
            unless ($w =~ m/Can't store item REGEXP/) {
                warn $w;
            }
        };
        Storable::store($to_cache, "$cachefile.storable");
    }
    else {
    my $utf8 = $Encode && Encode::is_utf8($source);
    my $use_utf8 = $utf8 ? 'use utf8;' : '';
    open my $fh, ">" . ($utf8 ? ':utf8' : ''), "$cachefile.pl" or die $!;    # TODO File::Spec
    my $path     = $self->get_path;
    my $path_str = '['
      . ( join ', ', map { $self->quote_file($_) } @$path )
      . ']';
    my $isScalar = $self->get_scalar ? 1 : 0;
    my $query_info = $self->get_parse_tree;
    $query_info = Data::Dumper->Dump([$query_info], ['query_info']);
    my $parser =$self->get_parser;
    $parser = Data::Dumper->Dump([\$parser], ['parser']);
    local $Data::Dumper::Deepcopy = 1;
    my $includes = $self->get_includes;
    my $includes_empty = {map {
            $_ => [$includes->{$_}->[0], $includes->{$_}->[1], 0],
        } keys %$includes};
    my $includes_to_string = Data::Dumper->Dump(
        [$includes_empty], ['includes']
    );
    #$includes_to_string =~ s/\$includes = //;
    my $search_path = $self->get_search_path || 0;
    my $gl = $self->get_global_vars;
    my $debug_file = $self->get_debug_file;
    $debug_file =~ tr/a-z0,//cd;
    my $use_objects = $self->get_objects;
    $use_objects =~ tr/a-z0//cd;
    my $plugins = $self->get_plugins;
    my $plugin_dump = Data::Dumper->Dump([\@$plugins], ['plugin_dump']);
    my $file_args = $isScalar
      ? <<"EOM"
        scalarref => $isScalar,
        filename => '@{[$self->get_filename]}',
EOM
      : <<"EOM";
        filename => '@{[$self->get_filename]}',
EOM
    my $package = <<"EOM";
    $use_utf8
    package HTML::Template::Compiled;
# file date $lmtime
# last checked date $lchecked
# @$plugins
my $plugin_dump;
my $query_info;
my \$parser;
$parser;
my $includes_to_string;
my \$args = {
    # HTC version
    class => '@{[ref $self]}',
    version => '$VERSION',
    times => {
        mtime => $times{mtime},
        checked => $times{checked},
    },
    htc => {
        case_sensitive => @{[$self->get_case_sensitive]},
        cache_dir => '$cache',
        cache => '@{[$self->get_cache]}',
$file_args
    path => $path_str,
    out_fh => @{[$self->get_out_fh]},
    default_path   => '@{[$self->get_default_path]}',
    default_escape => '@{[$self->get_default_escape]}',
    loop_context_vars => '@{[$self->get_loop_context||0]}',
    use_query => \$query_info,
    parser => \$parser,
    global_vars => $gl,
    debug_file => '$debug_file',
    objects => '$use_objects',
    includes => \$includes,
    search_path_on_include => $search_path,
    plugin => \$plugin_dump,
    # TODO
    # dumper => ...
    # template subroutine
    perl => $source,
    },
};
EOM
    print $fh $package;
    D && $self->log("$cache/$plfile.pl generated");
    }
    $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 && require_storable()?"storable":"pl") );
    return unless -f $req;
    return $self->include_file($req);
}

sub include_file {
    my ( $self, $req ) = @_;
    D && $self->log("do $req");
    my $r;
    my $t;
    if ($Storable && require_storable()) {
        #require Storable;
        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},
        );
        $t->init_plugins($plug);
    }
    else {
    if ($UNTAINT) {
        # you said explicitly that you can trust your compiled code
        open my $fh, '<:utf8', $req or die "Could not open '$req': $!";
        my $code = <$fh>;
        if ($code =~ m/use utf8/) {
            binmode $fh, ':utf8';
            $Encode and Encode::_utf8_on($code);
        }
        local $/;
        $code .= <$fh>;
        my $utf8 = $Encode && Encode::is_utf8($code);
        if ( $code =~ m/(\A.*\z)/ms ) {
            $code = $1;
        }
        else {
            $code = "";
        }
        if ($utf8) {
            Encode::_utf8_on($code);
        }
        $r = eval $code;
    }
    else {
        $r = do $req;
    }
    if ($@) {
        # we had an error while including
        die "Error while including '$req': $@";
    }
    my $cached_version = $r->{version};
    my $class = $r->{class} || 'HTML::Template::Compiled';
    my $args = $r->{htc};
    # we first just create from cached perl-code
    $t = $class->new_from_perl(%$args);
    if ($VERSION ne $cached_version || !$t->uptodate( $r->{times} )) {
        # is not uptodate
        return;
    }
    $t->set_includes( $args->{includes} );
    $t->init_includes;
    $t->get_cache and $t->add_mem_cache(
        checked => $r->{times}->{checked},
        mtime   => $r->{times}->{mtime},
    );
    }
    return $t;
}

sub createFilename {
    my ( $self, $path, $filename ) = @_;
    D && $self->log("createFilename($path,$filename)");
    D && $self->stack(1);
    if ($path) {
        local $" = "\\";
        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) {
            for ( @$path ) {
                #if (ref $_) {
                #    my $foo = basename $$_;
                #    my ($dir, $f) = (dirname($$_), basename($$_));
                #    my $found = 0;
                #    while (defined $f) {
                #        ($dir, $f) = (dirname($dir), basename($dir));
                #        #sleep 1;
                #        my $fp = File::Spec->catfile( $dir, $filename );
                #        #warn __PACKAGE__.':'.__LINE__.": fp=$fp\n";
                #        if (-f $fp) {
                #            local $" = "\\";
                #            $PATHS{"@$path"}->{$filename} = $fp;
                #            return $fp;
                #        }
                #        last if $dir eq '.';
                #    }
                #}
                my $fp = File::Spec->catfile( $_, $filename );
                if (-f $fp) {
                    local $" = "\\";
                    $PATHS{"@$path"}->{$filename} = $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 _check_deprecated_args {
    my ($self, %args) = @_;
    for (qw(method_call deref formatter_path)) {
        if (exists $args{$_}) {
            croak "Option $_ is deprecated";
        }
    }
    if (exists $args{dumper}) {
        croak "Option dumper is deprecated, use a plugin instead";
    }
    if (exists $args{formatter}) {
        croak "Option formatter is deprecated, see documentation";
    }
}

sub init_cache {
    my ($self, $args) = @_;
    if (exists $args->{cache_dir}) {
        # will soon be deprecated
        $args->{file_cache_dir} = $args->{cache_dir};
        unless (exists $args->{file_cache}) {
            # warn in future versions
            $args->{file_cache} = 1;
        }
    }
    $self->set_cache_dir($args->{file_cache_dir}) if $args->{file_cache};
    my $cachedir = $self->get_cache_dir;
    if ($args->{file_cache} and defined $cachedir and not -d $cachedir) {
        croak "Cachedir '$cachedir' does not exist";
    }
}

sub init {
    my ( $self, %args ) = @_;
    my %defaults = (

        # defaults
        search_path_on_include => $SEARCHPATH,
        loop_context_vars      => 0,
        case_sensitive         => $CASE_SENSITIVE_DEFAULT,
        debug                  => $DEBUG_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,
        %args,
    );
    $self->set_loop_context(1) if $args{loop_context_vars};
    $self->set_case_sensitive( $defaults{case_sensitive} );
    $self->set_default_escape( $defaults{default_escape} );
    $self->set_default_path( $defaults{default_path} );
    $self->set_use_query( $defaults{use_query} );
    #$self->set_use_expressions( $defaults{use_expressions} );
    if ($defaults{use_expressions}) {
        require HTML::Template::Compiled::Expr;
    }
    if ($defaults{open_mode}) {
        $defaults{open_mode} =~ s/^[<>]//; # <:utf8
    }
    $self->set_open_mode( $defaults{open_mode} );
    $self->set_search_path( $defaults{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( $defaults{debug} );
    $self->set_debug_file( $defaults{debug_file} );
    $self->set_objects( $defaults{objects} );
    if ($defaults{objects} and $defaults{objects} eq 'nostrict') {
        require Scalar::Util;
    }
    $self->set_out_fh( $defaults{out_fh} );
    $self->set_global_vars( $defaults{global_vars} );
    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 => $defaults{use_expressions},
        );
        $parser->set_perl($defaults{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($defaults{use_perl});
        $parser->set_expressions($defaults{use_expressions});
    }
    if ($defaults{use_perl}) {
        $parser->add_tagnames({
            HTML::Template::Compiled::Token::OPENING_TAG() => {
                PERL => [sub { 1 }],
            }
        });
    }
    if ($defaults{no_includes}) {
        $parser->remove_tags(qw/ INCLUDE INCLUDE_VAR INCLUDE_STRING /);
    }
    $self->set_parser($parser);
    my $compiler = $self->compiler_class->new;
    $self->set_compiler($compiler);
    if ($defaults{plugin}) {
        my $plugins = ref $defaults{plugin} eq 'ARRAY' ? $defaults{plugin} : [$defaults{plugin}];
        $self->init_plugins($plugins);
        $self->set_plugins($plugins);
    }
}

sub init_plugins {
    my ($self, $plugins) = @_;
    my $parser = $self->get_parser;
    my $compiler = $self->get_compiler;
    for my $plug (@$plugins) {
        if (ref $plug) {
        }
        elsif ($plug =~ m/^::/) {
            $plug = "HTML::Template::Compiled::Plugin$plug";
        }
        unless ($plug->can('register')) {
            eval "require $plug";
            if ($@) {
                carp "Could not load plugin $plug\n";
            }
        }
        my $actions = $self->get_plugin_actions($plug);
        if (my $tagnames = $actions->{tagnames}) {
            $parser->add_tagnames($tagnames);
        }
        if (my $escape = $actions->{escape}) {
            $compiler->add_escapes($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;
            $classes->{ref $plug || $plug} = $actions;
        }
    }

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

sub _readfile {
    my ( $self, $file ) = @_;
    my $open_mode = $self->get_open_mode;
    my $fh;
    if ($] < 5.007001) {
        open $fh, $file or die "Cannot open '$file': $!";
    }
    else {
        $open_mode = '' unless length $open_mode;
        open $fh, "<$open_mode", $file or die "Cannot open '$file': $!";
    }
    local $/;
    my $text = <$fh>;
    return $text;
}

sub get_code {
    my ($self) = @_;
    my $perl = $self->get_perl;
    return $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 <tmpl_var name="hash.key">) 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 paramater hash of the template, $C is a reference to the current
# parameter hash. the third argument to get_var is 'final'.
# <tmpl_var foo> is a 'final' path, and <tmpl_with foo> 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
# 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) {
        $cached->set_plugins($self->get_plugins);
        $cached->init_includes;
        return $cached
    }
    $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);
}

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 $uc = $self->uchash( {%p} );
        %p = %$uc;
    }
    $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 uchash
# 
#   my $capped_href = $self->uchash(\%href);
# 
# Input:
#     - hashref or arrayref of hashrefs
# 
# Output: Returns a reference to a cloned data structure where all the keys are
# capped. 
# 
# =cut

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

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} ) {
        $class->CaseSensitive(0);
        $class->SearchPathOnInclude(0);
        $class->UseQuery(1);
    }
    elsif ( $args{speed} ) {
        # default at the moment
        $class->CaseSensitive(1);
        $class->SearchPathOnInclude(1);
        $class->UseQuery(0);
    }
    if (exists $args{short}) {
        __PACKAGE__->export_to_level(1, scalar caller(), 'HTC');
    }
}

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*\) 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/</&lt;/g;
                s/>/&gt;/g;
            }
            $message = <<"EOM";
<table border="0" style="background-color: #eeeeee;"><tr><td><pre>$pre</pre></td></tr>
<tr><td style="background-color: #ffffff; color: #ff0000"><pre>$error</pre></td></tr>
<tr><td><pre>$post</pre></td></tr></table>
EOM
        }
        else {
            $message .= $pre;
            $message .= $error;
            $message .= $post;
        }
    }
    else {
        $message = $LAST_EXCEPTION;
    }
    return $message;

}

my $version_pod = <<'=cut';
=pod

=head1 NAME

HTML::Template::Compiled - Template System Compiles HTML::Template files to Perl code

=head1 VERSION

$VERSION = "0.95"

=cut

sub __test_version {
    my $v = __PACKAGE__->VERSION;
    my ($v_test) = $version_pod =~ m/VERSION\s*=\s*"(.+)"/m;
    no warnings;
    return $v == $v_test ? 1 : 0;
}

1;

__END__