File Coverage

lib/Template/Plugin/TwoStage.pm

Criterion	Covered	Total	%
statement	213	230	92.6
branch	42	58	72.4
condition	43	62	69.3
subroutine	37	38	97.3
pod	7	11	63.6
total	342	399	85.7

#
# This file is part of Template-Plugin-TwoStage
#
# This software is copyright (c) 2014 by Alexander Kühne.
#
# This is free software; you can redistribute it and/or modify it under
# the same terms as the Perl 5 programming language system itself.
#
package Template::Plugin::TwoStage;
# ABSTRACT: two stage processing of template blocks with first stage caching
$Template::Plugin::TwoStage::VERSION = '0.07'; # TRIAL

use warnings;
use strict;

use base qw( Template::Plugin Class::Data::Inheritable );
use Template 2.01 ();
use Template::Plugin ();
use Template::Parser ();
use Template::Exception ();
use Template::Provider ();

use File::Path qw( rmtree mkpath );
use File::Spec ();
use Digest::SHA1 qw( sha1_hex );
use Encode ();

# declare constants one by one - as opposed to a multiple constants declaration -
# in order to be compatible with constant.pm version 1.02 shipped with perl 5.6
use constant DEBUG => $ENV{TWOSTAGE_DEBUG} || 0;
use constant UNSAFE => '^A-Za-z0-9_';
use constant CACHE_DIR_NAME => 'TT_P_TwoStage';

BEGIN  {
	eval {
		require URI::Escape::XS;
		URI::Escape::XS->import( qw( uri_escape ) );
	};

	if ($@) {
		print STDERR "URI::Escape::XS not available ($@)...\n" if DEBUG;
		require URI::Escape;
		URI::Escape->import( qw( uri_escape ) );
	} else {
		print STDERR "URI::Escape::XS available ...\n" if DEBUG;
	}
};

my $TAG_STYLE_unquotemeta = {
	map {
		my @tags = @{$Template::Parser::TAG_STYLE->{$_}};
		( $_, [ map { $_ =~ s/\\([^A-Za-z_0-9]{1})/$1/g; $_ } @tags ] )
	} keys %$Template::Parser::TAG_STYLE
};

# declare options here
my @options = qw( caching_dir dev_mode namespace ttl dir_keys runtime_tag_style tt_cache_size );



__PACKAGE__->mk_classdata( caching_dir => File::Spec->tmpdir );


__PACKAGE__->mk_classdata( dev_mode => 0 );


__PACKAGE__->mk_classdata( ttl => 0 );


__PACKAGE__->mk_classdata( dir_keys => undef );


__PACKAGE__->mk_classdata( namespace => undef );


__PACKAGE__->mk_classdata( runtime_tag_style => 'star' );

__PACKAGE__->mk_classdata( precompile_tag_style => undef ); # is always the configured tag style of the Template object


__PACKAGE__->mk_classdata( tt_cache_size => undef );


sub extend_keys {
    my $self = shift;
    my $context = $self->{CONTEXT};
    my $stash = $context->stash();

    # hook method for adding standard keys - return the keys => value -hash by reference!
    {};
}



# TT2 PLUGIN HOOK METHODS

sub load {
    my ($class, $context) = @_;

    my $config = $class->compile_options( $context );

    my $caching_dir = $config->{ caching_dir };
    eval { mkpath( $caching_dir, 0, 0700 ) };
    $class->error( "Couldn't create directory: $caching_dir. Error message: $@" ) if $@;

    # We choose to have a specific provider for the plugin, because we do not want
    # to make any assumptions about which provider class is used by the user.

    # make include path

    my ($volume, $directories, $file) = File::Spec->splitpath( $caching_dir, 1 );
    # Strip off the class name from the caching directory
    # (which itself contains the class name as the last directory).
    # The class name will be part of the template's relative path when calling process().

    my $inc_path =
    File::Spec->catpath(
    	$volume,
	File::Spec->catdir(
		do { my @dirs = File::Spec->splitdir( $directories ); pop @dirs; @dirs }
	),
	$file
    );

    my $p = Template::Provider->new(
  	{ 	%{$context->{ CONFIG }},
		INCLUDE_PATH => $inc_path,
		CACHE_SIZE => $config->{ tt_cache_size },
		COMPILE_EXT => '.ttc',
		COMPILE_DIR => _concat_path( $inc_path, 'tt_compiled' )
	}
    );
    push @{$context->{ LOAD_TEMPLATES }}, $p;

    $context->{ PREFIX_MAP }->{ twostage } = [ $p ];

    print STDERR "$class:\nwe use caching dir: $caching_dir\n" if DEBUG;

    $class;
}


sub new {
    my ($class, $context, @params) = @_;

    print STDERR "new $class\n" if DEBUG;
    $class->create($context, @params);
}

sub error {
    my $proto = shift;
    die( ref( $_[0] ) ? @_ : do { $proto->SUPER::error(@_); Template::Exception->new( 'TwoStage', $proto->SUPER::error ) } );
}

sub create {
    my ($class, $context, $params) = @_;

    print STDERR "create \n" if DEBUG;

    # let parameters overwrite a selected set of the compiled options
    bless {
 	CONTEXT => $context,
	CONFIG => {
		%{$class->compiled_options( $context )},
		precompile_tag_style => ( $class->precompile_tag_style || $context->{CONFIG}->{TAG_STYLE} || 'default' ),
		( 	defined $params ?
			# specify invalid options for plugin construction
			do { delete @$params{ qw( caching_dir tt_cache_size ) }; %$params } :
			()
		)
	}
    }, $class;
}

sub compile_options {
    my ($class, $context) = @_;

    my %config;
    @config{ @options } = map { $class->$_ } @options;

    $config{ extend_keys } = \&Template::Plugin::TwoStage::extend_keys;

    if ( $class eq __PACKAGE__ && ( my $c = $context->{ CONFIG }->{ TwoStage } ) ) {

    	my @ack_opts = grep { scalar grep /^$_$/, @options } keys %$c;
	# slurp in all options from TT2 main configuration hash
	@config{ @ack_opts } = @$c{ @ack_opts };
	my $xk = $c->{ extend_keys };
	if ( defined $xk && ref $xk eq 'CODE' ) {
		# xk() as configuration option in TT2 main configuration hash
		$config{ extend_keys } = $xk;
	}

    } elsif ( $class ne __PACKAGE__ ) {

    	no strict 'refs';
	my $meth_name = "${class}::extend_keys";
    	if ( defined &{$meth_name} ) {
		# xk() as redefined callback method in derived class
		$config{ extend_keys } = \&{$meth_name};
	}

    }

    $config{ caching_dir } =
    &_concat_path( $config{ caching_dir }, [ CACHE_DIR_NAME, do { uri_escape( $class, UNSAFE ) } ] );

    print STDERR join( ', ', ( %config ) )."\n" if DEBUG;

    $context->{ CONFIG }->{ _TwoStage }->{ compiled_options }->{ $class } = \%config;
}

sub compiled_options {
    my $proto = shift;
    my $class = ref $proto || $proto;
    my $context = ref $proto ? $proto->{ CONTEXT } : shift;
    my $name = shift;

    my $c = $context->{ CONFIG }->{ _TwoStage }->{ compiled_options }->{ $class };
    defined $name ? $c->{ $name } : $c;
}

sub dump_options {
    my $self = shift;

    my $options_dump = '';
    map {
	if ( $_ ne 'extend_keys' ) {
		$options_dump.= "$_: ".( defined $self->{CONFIG}->{$_} ? $self->{CONFIG}->{$_} : '' )."\n"
	}
    } sort keys %{$self->{CONFIG}};

    $options_dump;
}


sub process {
    my( $self, $params, $localize ) = @_;
    $localize ||= 0;
    my $context = $self->{CONTEXT};
    my $stash = $context->stash();

    exists( $params->{template} ) || $self->error( "Pass template => \$name !" );
    $self->{prec_template} = {}; # store for properties of current template processed
    $self->{params} = $params; # parameters handed to process()
    $self->{params}->{keys} = $self->_complement_keys( $params->{keys} || {} );

    # make the config options local to this call
    local $self->{CONFIG} =
    {
    	%{$self->{CONFIG}},
	do {
	    	my %p = %$params;
		# specify invalid options as parameters to process()/include()
		delete @p{ qw( caching_dir tt_cache_size ) };
	    	%p
	}
    };

    if ( $stash->get( 'TwoStage_precompile_mode') ) {

    	# don't do runtime phase processing if the template is called in precompilation mode
    	print STDERR "$params->{template}: precompile_mode ack..." if DEBUG;
	return $context->process( $params->{template}, {}, 1 );
    }


    print STDERR
    "try using cached version of component ($params->{template}) ".$self->_signature."\n"
    ."dev_mode: ".$self->{CONFIG}->{dev_mode}."\n"
    ."INCLUDE_PATH: ".join( ' : ', @{$context->{CONFIG}->{INCLUDE_PATH}} )."\n"
    ."keys: \n".( join "\n", map { "$_ -> $self->{params}->{keys}->{$_}" } keys %{$self->{params}->{keys}} )."\n\n"
    	if DEBUG;

    # stat() the cached precompiled version to play safely with negative
    # caching of TT2 introduced in recent versions!
    # Else requesting for a not yet existing precompiled version
    # would lead to an immediate decline of a future request for the same precompiled template without
    # further stat() checks by the provider - even if it has been created on disk in the meantime.

    my @stat = stat( $self->_file_path );

    print STDERR "template.modtime: ".$stash->get( 'template.modtime' )." - ttl: $self->{CONFIG}->{ttl} ".time()." <= ".( $stat[9] + $self->{CONFIG}->{ttl})."\n"
	if DEBUG && scalar( @stat );

    if ( scalar( @stat )
     	 &&
	 $stash->get( 'template.modtime' ) <= $stat[9] # cached version outdated?
    	 &&
    	 !$self->{CONFIG}->{dev_mode} # forces in cases of nested TwoStage processed templates a refresh also for modified inner templates
    	 &&
	 ( !$self->{CONFIG}->{ttl} || time() <= ($stat[9] + $self->{CONFIG}->{ttl}) )

    ) {

	print STDERR "file ".$self->_file_path." successfully stat()ed\n" if DEBUG;

	my $output;
	eval {
		$output =
		$context->process(
			'twostage:' # prefix for provider selection
				.uri_escape( ref($self), UNSAFE ).'/'
				.( do { my $dirs = join( '/', @{$self->_dynamic_dir_segments} ); $dirs ? $dirs.'/' : '' } )
				.$self->_signature,
			{},
			$localize
		);
	};

	$self->error( "Retrieval though stat()'ed successfully (".$self->_file_path."): FAILED ($@)\n" ) if $@;
	print STDERR "Using cached output:\n\n $output\n\n" if DEBUG;

	return $output;
    }

    # process precompiled component
    $context->process( $self->_precompile, {}, $localize );
}

sub include {
    (shift)->process( @_, 1 );
}


sub purge {
    my $self = shift;
    my $class = ref($self);

    my $CACHE_DIR_NAME = CACHE_DIR_NAME;
    my $caching_dir = $self->compiled_options( 'caching_dir' );

    if (
	do { my $class_ue = uri_escape($class, UNSAFE ); $caching_dir =~ /$class_ue/; } &&
	$caching_dir =~ /${CACHE_DIR_NAME}/ &&
	-e $caching_dir &&
	-d $caching_dir # kind of paranoia
    ) {
	eval { rmtree( $caching_dir, 0, 1 ) };
	if ( $@ ) {
    		$class->error( "Couldn't remove directory tree: $caching_dir. Error message: $@" );
	}
    }

    '';
}


sub _complement_keys {
    my $self = shift;
    my $keys = shift;

    my $callers = $self->{CONTEXT}->stash->get( 'component.callers' );

    +{
	%{ $self->{CONFIG}->{extend_keys}->( $self ) },
	%{$keys},
	'_file_scope' =>
	( ref($callers) ? join( '\\', @{$callers} ) : '' )
	.$self->{CONTEXT}->stash->get( 'component.name' )
		# For making BLOCK name in template file scoped we need a unique identifier:
		# component.callers + component.name
		# This approach introduces the drawback that a BLOCK defined in a template being
		# included in different other templates as an "intra" is cached for each call stack
		# path seperately! But it is a feasable workaround as we don't know how to figure
		# out the name of the template the BLOCK was defined in.
    };
}

sub _precompile {
    my $self = shift;
    my $context = $self->{CONTEXT};
    my $stash = $context->stash();

    my $TAGS_tag =
    $TAG_STYLE_unquotemeta->{ $self->{CONFIG}->{precompile_tag_style}  }->[0]
    .' TAGS '.$self->{CONFIG}->{runtime_tag_style}.' '
    .$TAG_STYLE_unquotemeta->{ $self->{CONFIG}->{precompile_tag_style} }->[1]."\n";

    print STDERR "We are using tag style: $self->{CONFIG}->{precompile_tag_style}\n" if DEBUG;

    my $template;
    eval {
	$template = $context->process( $self->{params}->{template}, { TwoStage_precompile_mode => 1 }, 1 );
    };

    if ( $@ ) {
	print STDERR "\tFAILED ($@)\n"  if DEBUG;
	$self->error( ref($@) ? $@ : "Precompilation of module $self->{params}->{template}: $@ \n" );
    }

    print STDERR "storing ".$self->_signature."\n\n" if DEBUG;

    eval { mkpath( $self->_file_dir, 0, 0700 ) };
    if ($@) {
    	$self->error( "Couldn't create ".$self->_file_dir.": $@" );
    }

    open( my $fh, "> ", $self->_file_path ) || $self->error( "Could not get a filehandle! Error: $!" );

    my $out =
    $TAGS_tag
    .( 	$self->{CONFIG}->{dev_mode}
    	&&
    	$TAG_STYLE_unquotemeta->{ $self->{CONFIG}->{runtime_tag_style} }->[0]
	."# This precompiled template ( $self->{params}->{template} ) is stored together with the following keys:\n\t"
	.join( "\n\t", map { "$_ => ".( defined $self->{params}->{keys}->{$_} ? $self->{params}->{keys}->{$_} : 'undef' ) } keys %{$self->{params}->{keys}} )."\n "
	.$TAG_STYLE_unquotemeta->{ $self->{CONFIG}->{runtime_tag_style} }->[1]."\n"
	||
	''
    )
    .$template;


    if ( Encode::is_utf8( $template ) ) {

    	print STDERR "_precompile: encode\n" if DEBUG;
    	$out = Encode::decode_utf8( "\x{ef}\x{bb}\x{bf}" ).$out; # utf8 bom is stripped off again on load by Template::Provider
	binmode( $fh ); # turn off crlf io layer!?
	binmode( $fh, ':encoding(utf8)' );

    } else {

    	print STDERR "_precompile: octets\n" if DEBUG;
	binmode( $fh );
    }

    print $fh $out;
    close $fh;

    return \($TAGS_tag.$template);
}

sub _signature {
    my $self = shift;
    # produce signature

    $self->{prec_template}->{signature}
    ||=
    sha1_hex(
    	join(
        	':',
            	(
                	$self->{params}->{template},
                	map { "$_=".( $self->{params}->{keys}->{$_} || '' ) } sort keys %{$self->{params}->{keys}}
            	)
    	)
    ).'.tt';
}

sub _dynamic_dir_segments {
    my $self = shift;

    $self->{prec_template}->{dynamic_dir_segments}
    ||=
    [
	# include a possible namespace
	( $self->{CONFIG}->{namespace} ? $self->{CONFIG}->{namespace} : () ),
	# include dir_keys - we offer this feature only in testing mode!
	( 	$self->{CONFIG}->{dev_mode} && $self->{CONFIG}->{dir_keys}
 		?
  		(
			$self->{params}->{template},
			map { 	uri_escape( $_, UNSAFE ),
		      		uri_escape( 'value-'.$self->{params}->{keys}->{$_}, UNSAFE )
			}
			( ref( $self->{CONFIG}->{dir_keys} )
			  ?
			  grep( { exists $self->{params}->{keys}->{$_} } @{$self->{CONFIG}->{dir_keys}} )
			  :
			  keys %{$self->{params}->{keys}}
			)
		)
  		:
	  	()
	)
    ];
}

sub _rel_file_path {
    my $self = shift;

    $self->{prec_template}->{rel_file_path} ||= &_concat_path( $self->_rel_file_dir, $self->_signature );
}

sub _file_path {
    my $self = shift;

    $self->{prec_template}->{file_path} ||= &_concat_path( $self->compiled_options( 'caching_dir' ), $self->_rel_file_path );
}

sub _rel_file_dir {
    my $self = shift;

    $self->{prec_template}->{rel_file_dir} ||= File::Spec->catdir( @{$self->_dynamic_dir_segments} );
}

sub _file_dir {
    my $self = shift;

    $self->{prec_template}->{file_dir} ||= &_concat_path( $self->compiled_options( 'caching_dir' ), $self->_rel_file_dir );
}

# helpers

sub _concat_path {
    my ( $base_path, $append_dirs ) = @_;
    # $base_dir: base path (no filename) as string
    # $append_dirs: directories to append as string or an array reference

    my ($base_volume, $base_directories, $base_file) = File::Spec->splitpath( $base_path, 1 );
    File::Spec->catpath(
    	$base_volume,
		File::Spec->catdir(
			File::Spec->splitdir( $base_directories ),
			( ref($append_dirs) ? @{$append_dirs} : File::Spec->splitdir( $append_dirs ) )
		)
    	,
	$base_file
    );
}


1; # End of Template::Plugin::TwoStage

__END__