File Coverage

blib/lib/TX.pm

Criterion	Covered	Total	%
statement	225	284	79.2
branch	91	138	65.9
condition	23	68	33.8
subroutine	20	22	90.9
pod	3	6	50.0
total	362	518	69.8

package TX;

use 5.008008;
use strict;
use warnings;
use Text::Template::Library;
use File::Spec;
use Exporter 'import';
use Config qw/%Config/;
use Carp;

our @EXPORT_OK=qw(include);

our $VERSION='0.09';

our @attributes;
BEGIN {
  # define attributes and implement accessor methods
  @attributes=qw/path cache cachesize delimiters Ostack Vstack Lstack Fstack G
		 export_include auto_reload_templates package prepend output
		 binmode evalcache evalcachesize preserve_G/;
  for( my $i=0; $i<@attributes; $i++ ) {
    my $method_num=$i;
    ## no critic
    no strict 'refs';
    *{__PACKAGE__.'::'.$attributes[$method_num]}=
      sub : lvalue {$_[0]->[$method_num]};
    ## use critic
  }
}
sub attributes {@attributes}

our $TX;

sub new {
  my ($class, @param)=@_;
  $class=ref($class) || $class;

  my $I=bless []=>$class;

  $I->export_include=1;
  $I->prepend='';

  my (%public, %private, %ignored);
  foreach my $attr ($I->attributes) {
    if( $attr=~/^_/ ) {
      $private{$attr}=1;
    } else {
      $public{$attr}=1;
    }
  }
  my @initparam;
  while( my ($k, $v)=splice @param, 0, 2 ) {
    unless( exists $public{$k} ) {
      if( exists $private{$k} ) {
	$ignored{$k}=1;
      } else {
	push @initparam, $k, $v;
      }
      next;
    }
    $I->$k=$v;
  }

  @initparam=$I->init(@initparam);

  if( @initparam ) {
    my %o=@initparam;
    @ignored{keys %o}=();
  }

  if( keys %ignored ) {
    carp "the following parameters have been ignored: ".join(', ',
							     keys %ignored);
  }

  return $I;
}

sub init {
  my ($I, @param)=@_;

  if( defined $I->path ) {
    if( ref $I->path ne 'ARRAY' ) {
      $I->path=[split /\Q$Config{path_sep}\E/, $I->path];
    }
  } else {
    if( exists $ENV{TEMPLATE_PATH} ) {
      $I->path=[split /\Q$Config{path_sep}\E/, $ENV{TEMPLATE_PATH}];
    } else {
      $I->path=[];
      # default path is derived from the location of $0 and this module.
      # the filename component and last directory component of $0 are replaced
      # by 'templates'
      my ($vol, $dir, $filename)=File::Spec->splitpath($0);
      my @dirs;
      if( ref($I) ne __PACKAGE__ ) {
	($filename=ref($I))=~s!::!/!g; $filename.='.pm';
	if( exists $INC{$filename} ) {
	  ($vol, $dir, $filename)=File::Spec->splitpath($INC{$filename});
	  @dirs=File::Spec->splitdir($dir);
	  $filename=~s/\.pm$//;
	  push @dirs, $filename;
	  push @dirs, 'templates';
	  push @{$I->path},
	    File::Spec->catpath($vol, File::Spec->catdir(@dirs), '');
	}
      }

      ($filename=__PACKAGE__)=~s!::!/!g; $filename.='.pm';
      if( exists $INC{$filename} ) {
	($vol, $dir, $filename)=File::Spec->splitpath($INC{$filename});
	@dirs=File::Spec->splitdir($dir);
	$filename=~s/\.pm$//;
	push @dirs, $filename;
	push @dirs, 'templates';
	push @{$I->path},
	     File::Spec->catpath($vol, File::Spec->catdir(@dirs), '');
      }
    }
  }

  unless( defined $I->binmode ) {
    $I->binmode=$ENV{TEMPLATE_BINMODE};
  }

  $I->delimiters=$ENV{TEMPLATE_DELIMITERS} unless( defined $I->delimiters );

  if( defined $I->delimiters and ref $I->delimiters ne 'ARRAY' ) {
    my @l=split /\t+/, $I->delimiters, 2;
    @l==2 or @l=split /\s+/, $I->delimiters, 2;
    $I->delimiters=\@l if @l==2;
  }

  $I->cache={};
  if( defined $I->cachesize and $I->cachesize>0 ) {
    if( eval {require Tie::Cache::LRU} ) {
      tie %{$I->cache}, 'Tie::Cache::LRU', $I->cachesize;
    } else {
      warn "Cannot load Tie::Cache::LRU: $@";
    }
  }

  unless( defined $I->evalcache ) {
    $I->evalcache=$ENV{TEMPLATE_EVALCACHE};
  }

  if( $I->evalcache ) {
    $I->evalcache={} unless( ref($I->evalcache) eq 'HASH' );
    if( defined $I->evalcachesize and $I->evalcachesize>0 ) {
      if( eval {require Tie::Cache::LRU} ) {
	tie %{$I->evalcache}, 'Tie::Cache::LRU', $I->evalcachesize;
      } else {
	warn "Cannot load Tie::Cache::LRU: $@";
      }
    }
  }

  $I->Fstack=[];
  $I->Ostack=[];
  $I->Vstack=[];
  $I->Lstack=[];

  return @param;
}

sub clear_cache {
  my ($I, $re, $xor)=@_;

  local $_;
  if( @_>2 ) {
    # got both $re and $xor
    $re=qr/$re/ unless ref($re) eq 'Regexp';
    delete @{$I->cache}{grep( ($xor xor !$_=~$re), keys %{$I->cache} )};
  } elsif( @_>1 and ref($re) eq 'Regexp' ) {
    delete @{$I->cache}{grep( !$_=~$re, keys %{$I->cache} )};
  } elsif( @_>1 ) {
    $xor=$re=~s/^!//;
    $re=qr/$re/;
    delete @{$I->cache}{grep( ($xor xor !$_=~$re), keys %{$I->cache} )};
  } else {
    %{$I->cache}=();
  }
  return;
}

sub get_template {
  my ($I, $filename, $module)=@_;

  #use Data::Dumper; warn Dumper(\@_);

  if( ref $filename ) {
    my $template_string=$filename->{template};
    $filename=$filename->{filename};
    my $t=Text::Template::Library->new
      (
       TYPE=>'STRING', SOURCE=>$template_string,
       FILENAME=>$filename,
       ($I->delimiters ? (DELIMITERS=>$I->delimiters) : ()),
       BROKEN=>sub {
	 my %o=@_;
	 die $o{error} if ref $o{error};
	 $o{error}=~s/\s*\z//;
	 die "Template Error in $filename($o{lineno}): $o{error}\n";
       },
       PREPEND=>$I->prepend."\n;use strict; our (%V, %G, %L)\n",
       (defined $I->evalcache ? (EVALCACHE=>$I->evalcache) : ()),
      );
    die "Template Error: Cannot compile $filename\n" unless( $t->compile );
    $I->cache->{$filename}=[$t];
  } else {
    if( exists $I->cache->{$filename} and $I->auto_reload_templates ) {
      my ($path, $base);
      foreach my $p (@{$I->path}) {
	my $base=File::Spec->catfile($p, $filename);
	if( -f ($path=$base) && -r _ or
	    -f ($path=$base.".tmpl") && -r _ or
	    -f ($path=$base.".html") && -r _ ) {
	  my ($dev, $ino, $mtime)=(stat _)[0,1,9];
	  my $cachel=$I->cache->{$filename};
	  if( $cachel->[1]!=$dev or
	      $cachel->[2]!=$ino or
	      $cachel->[3]!=$mtime ) {
	    delete $I->cache->{$filename};
	  }
	  last;
	}
      }
    }
    unless( exists $I->cache->{$filename} ) {
      my $fh;
      my ($path, $base);
      foreach my $p (@{$I->path}) {
	my $base=File::Spec->catfile($p, $filename);
	my $mode=$I->binmode;
	if( defined $I->binmode ) {
	  $mode=~s/^:?/<:/;
	} else {
	  $mode='<';
	}
	if( open $fh, $mode, $path=$base or
	    open $fh, $mode, $path=$base.".tmpl" or
	    open $fh, $mode, $path=$base.".html" ) {
	  my $t=Text::Template::Library->new
	    (
	     TYPE=>'FILEHANDLE', SOURCE=>$fh,
	     FILENAME=>$filename,
	     ($I->delimiters ? (DELIMITERS=>$I->delimiters) : ()),
	     BROKEN=>sub {
	       my %o=@_;
	       die $o{error} if ref $o{error};
	       $o{error}=~s/\s*\z//;
	       die "Template Error in $path($o{lineno}): $o{error}\n";
	     },
	     PREPEND=>$I->prepend."\n;use strict; our (%V, %G, %L)\n",
	     (defined $I->evalcache ? (EVALCACHE=>$I->evalcache) : ()),
	    );
	  die "Template Error: Cannot compile $path\n" unless( $t->compile );
	  $I->cache->{$filename}=[$t, (stat $fh)[0,1,9]];
	  last;
	}
      }
    }
    die "Template Error: $filename not found in path ".
        join($Config{path_sep}, @{$I->path})."\n"
      unless( exists $I->cache->{$filename} );
  }

  if( defined $module and length $module ) {
    return $I->cache->{$filename}->[0]->module($module);
  } else {
    return $I->cache->{$filename}->[0];
  }
}

sub include {
  my $tmpl=shift;
  my $I;

  my $tx=$TX;

  if( eval {$tmpl->isa(__PACKAGE__)} ) {
    $I=$tmpl;
    $tmpl=shift;
  } elsif( $tx ) {
    $I=$tx;
  } else {
    $TX=$I=__PACKAGE__->new;
  }

  local $TX;
  $TX=$I;

  my ($filename, $tmp_filename, $module);
  if( ref($tmpl) ) {
    $filename=$tmpl;
    $module=$tmpl->{fragment};
  } else {
    ($tmp_filename, $module)=split /#/, $tmpl, 2;
    if( length $tmp_filename ) {
      $filename=$tmp_filename;
    } else {
      $filename=$I->Fstack->[0];
    }
  }
  unshift @{$I->Fstack}, $filename;

  my %opts;
  if( ref($_[0]) eq 'HASH' ) {
    %opts=%{shift()};
  }

  my $add_v='';
  $add_v=lc delete $opts{VMODE} if exists $opts{VMODE};
  my $keep_v=$add_v eq 'keep';
  $add_v=$add_v eq 'add';

  #use Data::Dumper; $Data::Dumper::Useqq=1; warn Dumper \%opts, $I->Ostack;
  unless( %opts ) {
    %opts=%{$I->Ostack->[0]} if( @{$I->Ostack} );
  }

  unless( exists $opts{OUTPUT} ) {
    $opts{OUTPUT}=(@{$I->Ostack}
		   ? $I->Ostack->[0]->{OUTPUT}
		   : defined $I->output ? $I->output : \*STDOUT);
  }

  unless( exists $opts{PACKAGE} ) {
    $opts{PACKAGE}=(@{$I->Ostack}
		    ? $I->Ostack->[0]->{PACKAGE}
		    : defined $I->package ? $I->package : __PACKAGE__.'::__');
  }
  #use Data::Dumper; $Data::Dumper::Useqq=1; warn Dumper \%opts;
  unshift @{$I->Ostack}, +{%opts};

  # allow to specify an arbitrary string as OUTPUT to indicate
  # the result is wanted as string.
  my $want_stringoutput;
  unless( ref($opts{OUTPUT}) ) {
    delete $opts{OUTPUT};
    $want_stringoutput=1;
  }

  if( $I->export_include ) {
    no strict 'refs';
    unless( defined &{$opts{PACKAGE}.'::include'} ) {
      *{$opts{PACKAGE}.'::include'}=\&include;
    }
  }

  my $vars;
  if( $keep_v ) {
    $vars=@{$I->Vstack} ? $I->Vstack->[0] : +{};
  } elsif( $add_v ) {
    $vars=+{%{$I->Vstack->[0]}};
    my %x=@_;
    @{$vars}{keys %x}=values %x;
  } else {			# new V
    $vars=+{@_};
  }
  unshift @{$I->Vstack}, $vars;

  if( !@{$I->Lstack} and
      !$I->preserve_G || ref($I->G) ne 'HASH' ) {
    $I->G={};
  }
  unshift @{$I->Lstack}, {};

  my $rc;
  eval {
    no strict 'refs';

    local *{$opts{PACKAGE}.'::V'}=$vars;
    local *{$opts{PACKAGE}.'::G'}=$I->G;
    local *{$opts{PACKAGE}.'::L'}=$I->Lstack->[0];
    if( $want_stringoutput ) {
      $rc=$I->get_template($filename, $module)->fill_in(%opts);
    } elsif( $I->get_template($filename, $module)->fill_in(%opts) ) {
      $rc='';
    } else {
      die "ERROR: Text::Template::Base::fill_in failed: $Text::Template::Base::ERROR\n";
    }
  };
  shift @{$I->Vstack};
  shift @{$I->Ostack};
  shift @{$I->Fstack};
  shift @{$I->Lstack};

  die $@ if( $@ );

  if( @{$I->Fstack} and !defined(wantarray) and length $rc ) {
    # inside a recursive call (called from a template) in void context
    # with non-empty output. Assume the template author has forgotten
    # to say "OUT include ..." but instead said "include ...". So we do
    # it for him.

    no strict 'refs';
    return &{$opts{PACKAGE}.'::OUT'}( $rc );
  }

  return $rc;
}

1;
__END__