#============================================================= -*-Perl-*-
#
# Template::Context
#
# DESCRIPTION
#   Module defining a context in which a template document is processed.
#   This is the runtime processing interface through which templates 
#   can access the functionality of the Template Toolkit.
#
# AUTHOR
#   Andy Wardley   <abw@kfs.org>
#
# COPYRIGHT
#   Copyright (C) 1996-2000 Andy Wardley.  All Rights Reserved.
#   Copyright (C) 1998-2000 Canon Research Centre Europe Ltd.
#
#   This module is free software; you can redistribute it and/or
#   modify it under the same terms as Perl itself.
# 
#----------------------------------------------------------------------------
#
# $Id: Context.pm,v 2.7 2000/12/01 15:29:34 abw Exp $
#
#============================================================================

package Template::Context;

require 5.004;

use strict;
use vars qw( $VERSION $DEBUG $AUTOLOAD );
use base qw( Template::Base );

use Template::Base;
use Template::Config;
use Template::Constants;
use Template::Exception;

$VERSION = sprintf("%d.%02d", q$Revision: 2.7 $ =~ /(\d+)\.(\d+)/);



#========================================================================
#                     -----  PUBLIC METHODS -----
#========================================================================

#------------------------------------------------------------------------
# template($name) 
#
# General purpose method to fetch a template and return it in compiled 
# form.  In the usual case, the $name parameter will be a simple string
# containing the name of a template (e.g. 'header').  It may also be 
# a reference to Template::Document object (or sub-class) or a Perl 
# sub-routine.  These are considered to be compiled templates and are
# returned intact.  Finally, it may be a reference to any other kind 
# of valid input source accepted by Template::Provider (e.g. scalar
# ref, glob, IO handle, etc).
#
# Templates may be cached at one of 3 different levels.  The internal
# BLOCKS member is a local cache which holds references to all
# template blocks used or imported via PROCESS since the context's
# reset() method was last called.  This is checked first and if the
# template is not found, the method then walks down the BLOCKSTACK
# list.  This contains references to the block definition tables in
# any enclosing Template::Documents that we're visiting (e.g. we've
# been called via an INCLUDE and we want to access a BLOCK defined in
# the template that INCLUDE'd us).  If nothing is defined, then we
# iterate through the LOAD_TEMPLATES providers list as a 'chain of 
# responsibility' (see Design Patterns) asking each object to fetch() 
# the template if it can.
#
# Returns the compiled template.  On error, undef is returned and 
# the internal ERROR value (read via error()) is set to contain an
# error message of the form "$name: $error".
#------------------------------------------------------------------------

sub template {
    my ($self, $name) = @_;
    my ($blocks, $defblocks, $provider, $template, $error);

    # references to Template::Document (or sub-class) objects objects, or
    # CODE references are assumed to be pre-compiled templates and are
    # returned intact
    return $name
	if UNIVERSAL::isa($name, 'Template::Document')
	    || ref($name) eq 'CODE';

    unless (ref $name) {
	# we first look in the BLOCKS hash for a BLOCK that may have 
	# been imported from a template (via PROCESS)
	return $template
	    if ($template = $self->{ BLOCKS }->{ $name });

	# the we iterate through the BLKSTACK list to see if any of the
	# Template::Documents we're visiting define this BLOCK
	foreach $blocks (@{ $self->{ BLKSTACK } }) {
	    return $template
		if $blocks && ($template = $blocks->{ $name });
	}
    }

    # finally we try the regular template providers which will 
    # handle references to files, text, etc., as well as templates
    # reference by name
    foreach my $provider (@{ $self->{ LOAD_TEMPLATES } }) {
	($template, $error) = $provider->fetch($name);
	return $template unless $error;
#	return $self->error($template)
	if ($error == Template::Constants::STATUS_ERROR) {
	    $self->throw($template) if ref $template;
	    $self->throw(Template::Constants::ERROR_FILE, $template);
	}
    }

#    return $self->error("$name: not found");
    $self->throw(Template::Constants::ERROR_FILE, "$name: not found");
}


#------------------------------------------------------------------------
# plugin($name, \@args)
#
# Calls on each of the LOAD_PLUGINS providers in turn to fetch() (i.e. load
# and instantiate) a plugin of the specified name.  Additional parameters 
# passed are propagated to the new() constructor for the plugin.  
# Returns a reference to a new plugin object or other reference.  On 
# error, undef is returned and the appropriate error message is set for
# subsequent retrieval via error().
#------------------------------------------------------------------------

sub plugin {
    my ($self, $name, $args) = @_;
    my ($provider, $plugin, $error);

    # request the named plugin from each of the LOAD_PLUGINS providers in turn
    foreach my $provider (@{ $self->{ LOAD_PLUGINS } }) {
	($plugin, $error) = $provider->fetch($name, $args, $self);
	return $plugin unless $error;
	if ($error == Template::Constants::STATUS_ERROR) {
	    $self->throw($plugin) if ref $plugin;
	    $self->throw(Template::Constants::ERROR_PLUGIN, $plugin);
	}
    }

    $self->throw(Template::Constants::ERROR_PLUGIN, "$name: plugin not found");
}


#------------------------------------------------------------------------
# filter($name, \@args, $alias)
#
# Similar to plugin() above, but querying the LOAD_FILTERS providers to 
# return filter instances.  An alias may be provided which is used to
# save the returned filter in a local cache.
#------------------------------------------------------------------------

sub filter {
    my ($self, $name, $args, $alias) = @_;
    my ($provider, $filter, $error);

    # use any cached version of the filter if no params provided
    return $filter 
	if ! $args && ! ref $name
	    && ($filter = $self->{ FILTER_CACHE }->{ $name });

    # request the named filter from each of the FILTERS providers in turn
    foreach my $provider (@{ $self->{ LOAD_FILTERS } }) {
	$filter = $name, last 
	    if ref $name;

	($filter, $error) = $provider->fetch($name, $args, $self);
	last unless $error;
	if ($error == Template::Constants::STATUS_ERROR) {
	    $self->throw($filter) if ref $filter;
	    $self->throw(Template::Constants::ERROR_FILTER, $filter);
	}
	# return $self->error($filter)
	#    if $error == &Template::Constants::STATUS_ERROR;
    }

    return $self->error("$name: filter not found")
	unless $filter;

    # alias defaults to name if undefined
    $alias = $name
	unless defined($alias) or ref($name);

    # cache FILTER if alias is valid
    $self->{ FILTER_CACHE }->{ $alias } = $filter
	if $alias;

    return $filter;
}


#------------------------------------------------------------------------
# process($template, \%params)    [% PROCESS template   var = val, ... %]
#
# Processes the template named or referenced by the first parameter.
# The optional second parameter may reference a hash array of variable
# definitions.  These are set before the template is processed by calling
# update() on the stash.  Note that the context is not localised and 
# these, and any other variables set in the template will retain their
# new values after this method returns.
#
# Returns the output of processing the template.  Errors are thrown
# as Template::Exception objects via die().  
#------------------------------------------------------------------------

sub process {
    my ($self, $template, $params) = @_;
    my ($blocks, $output);
    my $name = $template;

    # request compiled template from cache 
    $template = $self->template($template);
#	|| die Template::Exception->new(&Template::Constants::ERROR_FILE, 
#				$self->{ _ERROR } || "$template: not found");

    # merge any local blocks defined in the Template::Document into our
    # local BLOCKS cache
    @{ $self->{ BLOCKS } }{ keys %$blocks } = values %$blocks
	if UNIVERSAL::isa($template, 'Template::Document')
	    && ($blocks = $template->blocks);

    # update stash with any new parameters passed
    $params ||= { };
    $params->{ component } = ref $template eq 'CODE' 
	? { ref $name ? () : ( name => $name, modtime => time() ) }
        : $template;
    $self->{ STASH }->update($params);
#	if $params;
    
    if (ref $template eq 'CODE') {
	$output = &$template($self);
    }
    elsif (ref $template) {
	$output = $template->process($self);
    }
    else {
	die "invalid template reference: $template\n";
    }

    if ($self->{ TRIM }) {
	for ($output) {
	    s/^\s+//;
	    s/\s+$//;
	}
    }
    
    return $output;
}


#------------------------------------------------------------------------
# include($template, \%params)    [% INCLUDE template   var = val, ... %]
#
# Similar to process() above but processing the template in a local 
# context.  Any variables passed by reference to a hash as the second
# parameter will be set before the template is processed and then 
# revert to their original values before the method returns.  Similarly,
# any changes made to non-global variables within the template will 
# persist only until the template is processed.
#
# Returns the output of processing the template.  Errors are thrown
# as Template::Exception objects via die().  
#------------------------------------------------------------------------

sub include {
    my ($self, $template, $params) = @_;
    my ($error, $blocks);
    my $output = '';
    my $name = $template;

    # request compiled template from cache 
    $template = $self->template($template);
#	|| die Template::Exception->new(&Template::Constants::ERROR_FILE, 
#			       $self->{ _ERROR } || "$template: not found" );

    # localise the variable stash with any parameters passed
    $params ||= { };
    $params->{ component } = ref $template eq 'CODE' 
	? { ref $name ? () : (name => $name, modtime => time()) }
        : $template;
    $self->{ STASH } = $self->{ STASH }->clone($params);

    eval {
	if (ref $template eq 'CODE') {
	    $output = &$template($self);
	}
	elsif (ref $template) {
	    $output = $template->process($self);
	}
	else {
	    die "invalid template reference: $template\n";
	}
    };
    $error = $@;

    $self->{ STASH } = $self->{ STASH }->declone();

    die $error if $error;

    if ($self->{ TRIM }) {
	for ($output) {
	    s/^\s+//;
	    s/\s+$//;
	}
    }

    return $output;
}


#------------------------------------------------------------------------
# insert($file)
#
# Insert the contents of a file without parsing.
#------------------------------------------------------------------------

sub insert {
    my ($self, $file) = @_;
    my ($text, $error);

    foreach my $provider (@{ $self->{ LOAD_TEMPLATES } }) {
	($text, $error) = $provider->load($file);
	return $text unless $error;
	if ($error == Template::Constants::STATUS_ERROR) {
	    $self->throw($text) if ref $text;
	    $self->throw(Template::Constants::ERROR_FILE, $text);
	}
    }

    $self->throw(Template::Constants::ERROR_FILE, "$file: not found");
}


#------------------------------------------------------------------------
# throw($type, $info, \$output)          [% THROW errtype "Error info" %]
#
# Throws a Template::Exception object by calling die().  This method
# may be passed a reference to an existing Template::Exception object;
# a single value containing an error message which is used to
# instantiate a Template::Exception of type 'undef'; or a pair of
# values representing the exception type and info from which a
# Template::Exception object is instantiated.  e.g.
#
#   $context->throw($exception);
#   $context->throw("I'm sorry Dave, I can't do that");
#   $context->throw('denied', "I'm sorry Dave, I can't do that");
#
# An optional third parameter can be supplied in the last case which 
# is a reference to the current output buffer containing the results
# of processing the template up to the point at which the exception 
# was thrown.  The RETURN and STOP directives, for example, use this 
# to propagate output back to the user, but it can safely be ignored
# in most cases.
# 
# This method rides on a one-way ticket to die() oblivion.  It does not 
# return in any real sense of the word, but should get caught by a 
# surrounding eval { } block (e.g. a BLOCK or TRY) and handled 
# accordingly, or returned to the caller as an uncaught exception.
#------------------------------------------------------------------------

sub throw {
    my ($self, $error, $info, $output) = @_;
    local $" = ', ';

    # die! die! die!
    if (UNIVERSAL::isa($error, 'Template::Exception')) {
#	print STDERR "throwing existing exception [@$error]\n";
	die $error;
    }
    elsif (defined $info) {
#	print STDERR "throwing new exception [$error] [$info]\n";
	die Template::Exception->new($error, $info, $output);
    }
    else {
	$error ||= '';
#	print STDERR "throwing an undefined exception [$error]\n";
	die Template::Exception->new('undef', $error, $output);
    }

    # not reached
}


#------------------------------------------------------------------------
# catch($error, \$output)
#
# Called by various directives after catching an error thrown via die()
# from within an eval { } block.  The first parameter contains the errror
# which may be a sanitized reference to a Template::Exception object
# (such as that raised by the throw() method above, a plugin object, 
# and so on) or an error message thrown via die from somewhere in user
# code.  The latter are coerced into 'undef' Template::Exception objects.
# Like throw() above, a reference to a scalar may be passed as an
# additional parameter to represent the current output buffer
# localised within the eval block.  As exceptions are thrown upwards
# and outwards from nested blocks, the catch() method reconstructs the
# correct output buffer from these fragments, storing it in the
# exception object for passing further onwards and upwards.
#
# Returns a reference to a Template::Exception object..
#------------------------------------------------------------------------

sub catch {
    my ($self, $error, $output) = @_;

    if (UNIVERSAL::isa($error, 'Template::Exception')) {
	$error->text($output) if $output;
	return $error;
    }
    else {
	return Template::Exception->new('undef', $error, $output);
    }
}


#------------------------------------------------------------------------
# localise(\%params)
# delocalise()
#
# The localise() method creates a local copy of the current stash,
# allowing the existing state of variables to be saved and later 
# restored via delocalise().
#
# A reference to a hash array may be passed containing local variable 
# definitions which should be added to the cloned namespace.  These 
# values persist until delocalisation.
#------------------------------------------------------------------------

sub localise {
    my $self = shift;
    $self->{ STASH } = $self->{ STASH }->clone(@_);
}

sub delocalise {
    my $self = shift;
    $self->{ STASH } = $self->{ STASH }->declone();
}


#------------------------------------------------------------------------
# visit($blocks)
#
# Each Template::Document calls the visit() method on the context
# before processing itself.  It passes a reference to the hash array
# of named BLOCKs defined within the document, allowing them to be 
# added to the internal BLKSTACK list which is subsequently used by
# template() to resolve templates.
# from a provider.
#------------------------------------------------------------------------

sub visit {
    my ($self, $blocks) = @_;
    unshift(@{ $self->{ BLKSTACK } }, $blocks)
}


#------------------------------------------------------------------------
# leave()
#
# The leave() method is called when the document has finished
# processing itself.  This removes the entry from the BLKSTACK list
# that was added visit() above.  For persistance of BLOCK definitions,
# the process() method (i.e. the PROCESS directive) does some extra
# magic to copy BLOCKs into a shared hash.
#------------------------------------------------------------------------

sub leave {
    my $self = shift;
    shift(@{ $self->{ BLKSTACK } });
}


#------------------------------------------------------------------------
# define_block($name, $block)
#
# Adds a new BLOCK definition to the local BLOCKS cache.  $block may
# be specified as a reference to a sub-routine or Template::Document
# object or as text which is compiled into a template.  Returns a true
# value (the $block reference or compiled block reference) if
# succesful or undef on failure.  Call error() to retrieve the
# relevent error message (i.e. compilation failure).
#------------------------------------------------------------------------

sub define_block {
    my ($self, $name, $block) = @_;
    $block = $self->template(\$block)
	|| return undef
	    unless ref $block;
    $self->{ BLOCKS }->{ $name } = $block;
}


#------------------------------------------------------------------------
# define_filter($name, $filter, $is_dynamic)
#
# Adds a new FILTER definition to the local FILTER_CACHE.
#------------------------------------------------------------------------

sub define_filter {
    my ($self, $name, $filter, $is_dynamic) = @_;
    my ($result, $error);
    $filter = [ $filter, 1 ] if $is_dynamic;

    foreach my $provider (@{ $self->{ LOAD_FILTERS } }) {
	($result, $error) = $provider->store($name, $filter);
	return 1 unless $error;
	$self->throw(&Template::Constants::ERROR_FILTER, $result)
	    if $error == &Template::Constants::STATUS_ERROR;
    }
    $self->throw(&Template::Constants::ERROR_FILTER, 
		 "FILTER providers declined to store filter $name");
}


#------------------------------------------------------------------------
# reset()
# 
# Reset the state of the internal BLOCKS hash to clear any BLOCK 
# definitions imported via the PROCESS directive.  Any original 
# BLOCKS definitions passed to the constructor will be restored.
#------------------------------------------------------------------------

sub reset {
    my ($self, $blocks) = @_;
    $self->{ BLKSTACK } = [ ];
    $self->{ BLOCKS   } = { %{ $self->{ INIT_BLOCKS } } };
}


#------------------------------------------------------------------------
# stash()
#
# Simple accessor methods to return the STASH values.  This is likely
# to be called quite often so we provide a direct method rather than
# relying on the slower AUTOLOAD.
#------------------------------------------------------------------------

sub stash {
    return $_[0]->{ STASH };
}


#------------------------------------------------------------------------
# AUTOLOAD
#
# Provides pseudo-methods for read-only access to various internal 
# members.  For example, templates(), plugins(), filters(),
# eval_perl(), load_perl(), etc.  These aren't called very often, or
# may never be called at all.
#------------------------------------------------------------------------

sub AUTOLOAD {
    my $self   = shift;
    my $method = $AUTOLOAD;
    my $result;

    $method =~ s/.*:://;
    return if $method eq 'DESTROY';

    warn "no such context method/member: $method\n"
	unless defined ($result = $self->{ uc $method });

    return $result;
}


#------------------------------------------------------------------------
# DESTROY
#
# Stash may contain references back to the Context via macro closures,
# etc.  This breaks the circular references. 
#------------------------------------------------------------------------

sub DESTROY {
    my $self = shift;
    undef $self->{ STASH };
}



#========================================================================
#                     -- PRIVATE METHODS --
#========================================================================

#------------------------------------------------------------------------
# _init(\%config)
#
# Initialisation method called by Template::Base::new()
#------------------------------------------------------------------------

sub _init {
    my ($self, $config) = @_;
    my ($name, $item, $method, $block, $blocks);
    my @itemlut = ( 
	LOAD_TEMPLATES => 'provider',
	LOAD_PLUGINS   => 'plugins',
	LOAD_FILTERS   => 'filters' 
    );

    # LOAD_TEMPLATE, LOAD_PLUGINS, LOAD_FILTERS - lists of providers
    while (($name, $method) = splice(@itemlut, 0, 2)) {
	$item = $config->{ $name } 
	     || Template::Config->$method($config)
	     || return $self->error($Template::Config::ERROR);
	$self->{ $name } = ref $item eq 'ARRAY' ? $item : [ $item ];
    }

    # STASH
    $self->{ STASH } = $config->{ STASH } || do {
      	my $predefs  = $config->{ VARIABLES } 
		    || $config->{ PRE_DEFINE } 
		    || { };

	# hack to get stash to know about debug mode
	$predefs->{ _DEBUG } = $config->{ DEBUG } || 0;
	Template::Config->stash($predefs)
	    || return $self->error($Template::Config::ERROR);
    };

    # compile any template BLOCKS specified as text
    $blocks = $config->{ BLOCKS } || { };
    $self->{ INIT_BLOCKS } = $self->{ BLOCKS } = { 
	map {
	    $block = $blocks->{ $_ };
	    $block = $self->template(\$block)
		|| return undef
		    unless ref $block;
	    ($_ => $block);
	} 
	keys %$blocks
    };

    # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
    # RECURSION - flag indicating is recursion into templates is supported
    # EVAL_PERL - flag indicating if PERL blocks should be processed
    # TRIM      - flag to remove leading and trailing whitespace from output
    # BLKSTACK  - list of hashes of BLOCKs defined in current template(s)
    # CONFIG    - original configuration hash

    $self->{ RECURSION } = $config->{ RECURSION } || 0;
    $self->{ EVAL_PERL } = $config->{ EVAL_PERL } || 0;
    $self->{ TRIM      } = $config->{ TRIM } || 0;
    $self->{ BLKSTACK  } = [ ];
    $self->{ CONFIG    } = $config;

    return $self;
}


#------------------------------------------------------------------------
# _dump()
#
# Debug method which returns a string representing the internal state
# of the context object.
#------------------------------------------------------------------------

sub _dump {
    my $self = shift;
    my $output = "$self\n";
    foreach my $pname (qw( LOAD_TEMPLATES LOAD_PLUGINS LOAD_FILTERS )) {
	foreach my $prov (@{ $self->{ $pname } }) {
	    $output .= $prov->_dump();
	}
    }
    return $output;
}


1;
