File Coverage

blib/lib/Text/TemplateFill.pm

Criterion	Covered	Total	%
statement	242	305	79.3
branch	67	126	53.1
condition	20	45	44.4
subroutine	23	28	82.1
pod	9	21	42.8
total	361	525	68.7

# This module generates text output from template files, filling in value fields.
#      /\
#     /  \              (C) Copyright 2002-2003 Parliament Hill Computers Ltd.
#     \  /              All rights reserved.
#      \/
#       .               Author: Alain Williams, July 2002
#       .               [e-mail]
#        .
#          .
#
#	SCCS: @(#)TemplateFill.pm 1.7 03/27/03 10:27:28
# Alain D D Williams , July 2002
#
# This module is free software; you can redistribute it and/or modify
# it under the same terms as Perl itself. You must preserve this entire copyright
# notice in any use or distribution.
# The author makes no warranty what so ever that this code works or is fit
# for purpose: you are free to use this code on the understanding that any problems
# are your responsibility.

# Permission to use, copy, modify, and distribute this software and its documentation for any purpose and without fee is
# hereby granted, provided that the above copyright notice appear in all copies and that both that copyright notice and
# this permission notice appear in supporting documentation.

use strict;

package Text::TemplateFill;

use Exporter;
use POSIX;
use Math::Expression;

# What local variables - visible elsewhere
use vars qw/
	@ISA @EXPORT
	/;

@ISA = ('Exporter');

@EXPORT = qw(
	$VERSION
	);

our $VERSION = "1.7";

# This contains the current (and probably only) template instance.
# It is used where we can't guess it, this relies on only being invoked for one
# instance at a time:
my $globalself;
my $globaltag;	# And for current tag

my $ArithIdent;	# Identification string for arithmetic - in case of errors

# Nothing at startup
BEGIN {
	;
}

# Nothing at end
END {
	;
}

# Default error output function
sub PrintError {
	printf STDERR @_;
	print STDERR "\n";
}

# Called when something is wrong.
# Args: $self, fprintf style args
# The point is that the error function is called.
# Nasty bit to avoid reporting functions in this module.
# Take care to switch back to the calling locale - if we set one.
sub Error {
	my $self = shift @_;
	my ($pack,$file,$line,$sub,$hargs,undef,$eval,$require);
	my $i = 1;
	do {
		($pack,$file,$line,$sub,$hargs,undef,$eval,$require) = caller($i++);
	} while($pack eq 'Text::TemplateFill');

	my $fmt = shift @_;
	my $OldLocale;

	if($self->{OldLocale} ne '') {
		$OldLocale = setlocale(LC_CTYPE);
		setlocale(LC_ALL, $self->{OldLocale});
	}

	$self->{ErrorFunction}($fmt . ". Called from $file line $line fn: $pack ", @_);

	setlocale(LC_ALL, $OldLocale) if(defined($OldLocale));

	$self->{Errors}++;
}

# Print errors from arithmetic, rely on $globalself
# Prepend the offending statement at the start of the error message, makes it a bit long I am afraid:
sub ArithError {
	my $fmt = shift @_;
	&Error($globalself, "Calc '%s' " . $fmt, $ArithIdent, @_);
}

# Return the value of a variable - return an array
# 0	Magic value to Math::Expression
# 1	Variable name
# NB: Math::Expression holds vars as arrays, this uses simple scalars.
sub ArithVarGet {
	my ($self, $name) = @_;

	my $varref = &Value($globalself, $globaltag, $name, 0);
	my @v = ( );
	push @v, ${$varref} if(defined($varref));

	return @v;
}

# Is a variable is defined - return 1 or 0
# 0	Magic value to Math::Expression
# 1	Variable name
sub ArithVarIsDef {
	my ($self, $name) = @_;

	my $varref = &Value($globalself, $globaltag, $name, 0);

	return defined($varref) ? 1 : 0;
}

# Set the value of a variable - return the array
# 0	Magic value to Math::Expression
# 1	Variable name
# 2	Value - array
sub ArithVarSet {
	my ($self, $name, @val) = @_;

	my $varref = &Value($globalself, $globaltag, $name, 1);

	${$varref} = $val[$#val];

	return @val;
}

# Create a new template object.
# Initialise default options.
sub new {
	my $class = shift;

	my $PageNo = 0;					# Not started yet. The first to print is page 1
	my $PageLineNo = 0;
	my $Now = time;

	# Program variables
	my %ProgVars = (
	);

	# Calculated & auto vars
	my %CalcVars = (
		'PageNo'	=>	\$PageNo,	# Current page number
		'PageLineNo'	=>	\$PageLineNo,	# Current line number in page (0 if page not started)
		'Now'		=>	\$Now,		# Current time - actually time of 'new'.
	);

	my $CalcHandle = new Math::Expression;
	$CalcHandle->SetOpt(	'VarGetFun' => \&ArithVarGet,
				'VarSetFun' => \&ArithVarSet,
				'VarIsDefFun' => \&ArithVarIsDef,
				'PrintErrFunc' => \&ArithError);

	# References to all the paragraphs for this template
	# This contains references to hashes keyed on the paragraph tag.
	my %Paragraphs = (
	);

	my %template = (
		'Errors'	=>	0,		# Error count
		'ErrorFunction'	=>	\&PrintError,	# What to call on error
		'Initialised'	=>	0,		# True when post-read file initialisation done
		'Locale'	=>	'',		# May be something like 'fr_CA.ISO8859-1'
		'OldLocale'	=>	'',		# On entry to GeneratePara
		'BaseDir'	=>	'.',		# What to add if no '/' at start of file name
		'LineTerminator'=>	"\n",		# What to put at the end of each line
		'EndPageSeq'	=>	'',		# Probably \f, else use many empty lines
		'PageLen'	=>	66,		# Length of output page
		'Variables'	=>	\%ProgVars,	# Hash of all program variables
		'CalcVars'	=>	\%CalcVars,	# Hash of all calculated variables
		'Paragraphs'	=>	\%Paragraphs,	# Hash of all paragraphs
		'StartPageTag'	=>	' ',		# Which tag to use to auto start a page, undef doesn't work - space is dodge
		'EndPageTag'	=>	' ',		# Which tag to use to auto end a page
		'CalcHandle'	=>	$CalcHandle,	# For calculations
	);

	return bless \%template => $class;
}

# Set an option in the %template.
sub SetOpt {
	my $self = shift @_;

	while($#_ > 0) {
		&Error($self, "Unknown option '$_[0]'") unless(defined($self->{$_[0]}));
		&Error($self, "No value to option '$_[0]'") unless(defined($_[1]));
		$self->{$_[0]} = $_[1];
		shift;shift;
	}
}

# Read a file in. The user arguments are:
# * a tag name that is used to identify/obtain this paragraph in the future
# * a file name that will be read, if this is not given, use tag.
# Return true on error.
sub ReadPara {
	my ($self, $tag, $fname) = @_;

	$globalself = $self;

	$self->{Initialised} = 0;	# Need to reassess what is what

	$fname = $tag unless(defined($fname));	# no $fname ?

	my @Lines = ();
	my ($ParaOnPage, $ParaTotal) = (0, 0);
	my @Calc = ();
	my @CalcStr = ();
	my @LineNoMap = ();

	my %ParaDescript = (
		'Lines'		=>	\@Lines,
		'LineNoMap'	=>	\@LineNoMap,	# For error messages - else removed comments cause bad reporting of errors
		'Calc'		=>	\@Calc,		# Calculations - parsed trees
		'CalcStr'	=>	\@CalcStr,	# Calculations - uncompiled
		'EndPage'	=>	0,		# True if paragaph ends a page
		'StartPage'	=>	0,		# True if paragaph starts a page
		'BlanksAfter'	=>	0,		# True blanks to page botton when EndPage come after paragraph
		'ParaOnPage'	=>	\$ParaOnPage,	# Paragraph usage count this page
		'ParaTotal'	=>	\$ParaTotal,	# Paragraph usage count total
	);

	# Get the file to open, prepend the base dir if not absolute:
	my $fn = (($fname =~ /^\//) ? '' : $self->{BaseDir}) . '/' . $fname;

	unless(open(TMPL, "<$fn")) {
		&Error($self, "Cannot open '%s' as: $!", $fn);
		return(1);
	}

	while() {
		chop;		# Basic line tidy:
		s/\s*\r?$//;
		next if(/^\$\{#\}/);

		# If it is a calculation, extract it & save
		if(/^\$\{Calc\s+(.*)\}$/) {
			push @CalcStr, "$fn:$. '$1'";
			push @Calc, $self->{CalcHandle}->Parse("$1");
			next;
		}

		# If not an option, append to template lines:
		unless(/^\$\{Opt\s/) {
			push @Lines, $_;
			push @LineNoMap, $.;
			next;
		}

		# Process options:
		unless(/^\$\{Opt\s+(\w+)\s*([^\s]+)?\s*\}/) {
			&Error($self, "Bad option line $. in '%s'", $fn);
			next;
		}

		my ($optkey, $optval) = ($1, $2);

		# The option will be held as a member of a hash, find which hash
		my $href;
		$href = \%ParaDescript if(defined($ParaDescript{$optkey}));
		$href = $self if(defined($self->{$optkey}));
		unless(defined($href)) {
			&Error($self, "Unknown option '$optkey' line $. in '%s'", $fn);
			next;
		}

		# No validation on the value, if none just set to true
		$href->{$optkey} = defined($optval) ? ($optval eq "''" ? '' : $optval) : 1;
	}

	close(TMPL);

	$self->{Paragraphs}{$tag} = \%ParaDescript;

	return(0);
}

# This checks what has been read & deduces:
# * What tag to use at the start of a page
# * What tag to use to end a page
sub CompleteInit {
	my $self = $_[0];

	foreach my $para (keys %{$self->{Paragraphs}}) {

		my $parh = ${$self->{Paragraphs}}{$para};

		# NB: there is an important difference between the tag having a space value & having the empty value.
		# The space value is a dodge to say that it is unset - ugh, empty means deliberately no tag.
		$self->{StartPageTag} = $para if($self->{StartPageTag} eq ' ' and
			${$parh}{'StartPage'} != 0);
		$self->{EndPageTag} = $para if($self->{EndPageTag} eq ' ' and
			${$parh}{'EndPage'} != 0);
	}

	$self->{Initialised} = 1;
}

# Reset all page/line counters to zero.
sub Reset {
	my $self = $_[0];

	${$self->{CalcVars}{PageLineNo}} = 0;
	${$self->{CalcVars}{PageNo}} = 0;

	# Reset paragraph usage on this page to 0
	foreach my $para (keys %{$self->{Paragraphs}}) {
		${$self->{Paragraphs}{$para}{ParaOnPage}} = 0;
		${$self->{Paragraphs}{$para}{ParaTotal}} = 0;
	}
}

# This is called to start a page.
# Args: $self, optional tag to start the page with - else the defined start tag - if there is one
# This assumes that any previous page is complete.
# Return something to print
sub StartPage {
	my ($self, $tag) = @_;

	# Need this in case called before a GeneratePara
	&CompleteInit($self) unless($self->{Initialised});

	$tag = $self->{StartPageTag} unless(defined($tag));

	${$self->{CalcVars}{PageLineNo}} = 1;	# Line number of first line to print
	${$self->{CalcVars}{PageNo}}++;

	# Reset paragraph usage on this page to 0
	foreach my $para (keys %{$self->{Paragraphs}}) {
		${$self->{Paragraphs}{$para}{ParaOnPage}} = 0;
	}

	# If there is a start page tag, output it:
	return(&GeneratePara($self, $tag)) if($tag ne ' ' and $tag ne '');
	return('');
}

# End the current page.
# Args: $self, optional tag to end the page with - else the defined end tag - if there is one
# If there is nothing on the page, print an empty page with a footer.
sub EndPage {
	my ($self, $tag) = @_;

	my $text = '';
	# Page not started ? Get it going but don't print a header:
	$text = &StartPage($self, '') if(${$self->{CalcVars}{PageLineNo}} < 1);

	$tag = $self->{EndPageTag} unless(defined($tag));

	# Work out how empty many lines we must generate to put the footer in the right place.
	my $lines = $self->{PageLen} - ${$self->{CalcVars}{PageLineNo}};

	# If end of page tag: blank line down to it (or after), else o/p a formfeed or blank down to end of page:
	if($tag ne '') {
		my $blanksafter = $self->{Paragraphs}{$tag}{BlanksAfter};
		my $blanklines = $self->{LineTerminator} x ($lines - $#{$self->{Paragraphs}{$tag}{Lines}});
		$text .= $blanklines unless($blanksafter);
		$text .= &GeneratePara($self, $tag) if($tag ne ' ' and $tag ne '');
		$text .= $blanklines if($blanksafter);
	} else {
		$text .= ($self->{EndPageSeq} ne '') ? $self->{EndPageSeq} : ($self->{LineTerminator} x $lines);
	}

	${$self->{CalcVars}{PageLineNo}} = 0;	# Next page not started

	return $text;
}

# Print an end page if there is something on the current page.
# Args: $self, optional tag to end the page with - else the defined end tag - if there is one
# Don't print anything if the current page has not been started - should only be at start of file.
# If a tag is specified and it is not the default end page tag, a check will be made to see if the
# specified paragraph will fit on the page, if not a standard endpage/startpage is first done.
sub CompletePage {
	my ($self, $tag) = @_;

	return '' if(${$self->{CalcVars}{PageLineNo}} < 1);

	my $text = '';

	# Won't fit
	$text = &EndPage($self) if(defined($tag) and $tag ne $self->{EndPageTag} and $self->{PageLen} > 0 and
		${$self->{CalcVars}{PageLineNo}} + $#{${$self->{Paragraphs}{$tag}}{Lines}} >= $self->{PageLen});

	return $text . &EndPage($self, $tag);
}

# Evaluate the paragraph and return an array that can be printed.
# Return the empty string
sub GeneratePara {
	my ($self, $tag) = @_;
	my $para = $self->{Paragraphs}{$tag};
	my $text = '';

	$self->{OldLocale} = '';

	# print "GeneratePara '$tag' self='$self'\n";
	unless(defined($para)) {
		&Error($self, "Tag '%s' is not known", $tag);
		return('');
	}
	my $lines = ${$para}{Lines};

	&CompleteInit($self) unless($self->{Initialised});	# Once off after files read

	# Need to end the page if the current paragraph will not fit on the page - NOT if printing EOP para
	# Count lines left, lines this para, lines in EndPage. Not if Line/page < 1
	$text .= &EndPage($self) if($para->{EndPage} == 0 and $self->{PageLen} > 0 and
		${$self->{CalcVars}{PageLineNo}} + $#{$lines} +
		($self->{EndPageTag} ne '' ? $#{${$self->{Paragraphs}{$self->{EndPageTag}}}{Lines}} : 0) >= $self->{PageLen});

	# Need to start a page and this paragraph is not a start of page paragraph ?
	# Even if $tag is a StartPage we need to call &StartPage to get page # increment, etc.
	if(${$self->{CalcVars}{PageLineNo}} <= 0) {
		$text .= &StartPage($self, ($para->{StartPage} == 0 ? undef : $tag));
		return $text if($para->{StartPage});	# Else we get the start page text twice
	}

	${$para->{ParaOnPage}}++;
	${$para->{ParaTotal}}++;

	# Perform any calculations first:
	$globalself = $self;	# For arithmetic
	$globaltag = $tag;
	my $calc = $para->{Calc};
	&Calculate($self, $tag, $calc, $para->{CalcStr}) if($#{$calc} >= 0);

	# Change locale if one is defined
	if($self->{Locale} ne '') {
		$self->{OldLocale} = setlocale(LC_CTYPE);
		setlocale(LC_ALL, $self->{Locale});
	}

	my $lineno = 0;	# For error messages
	foreach my $line (@{$lines}) {
		my $exp_line = &Expand($self, $para, $line, $tag, ${$para}{LineNoMap}[$lineno]);
		$text .= $exp_line . $self->{LineTerminator};
		${$self->{CalcVars}{PageLineNo}}++;
		$lineno++;
	}

	# Change locale back
	setlocale(LC_ALL, $self->{OldLocale}) if($self->{OldLocale} ne '');
	$self->{OldLocale} = '';

	return $text;
}

# Perform calculations for a paragraph
sub Calculate {
	my ($self, $tag, $calc, $calcstr) = @_;
	my $para = $self->{Paragraphs}{$tag};

	for(my $i = 0; $i <= $#{$calc}; $i++) {
		my $tree = ${$calc}[$i];
		$ArithIdent = ${$calcstr}[$i];	# For errors
		$self->{CalcHandle}->EvalToScalar($tree);
	}
}

# Return the value of a variable or constant.
# This is for use in expression evaluation.
# NB: $self is for Math::Expression, so rely on $globalself.
# undefOK is set if we are assigning.
sub Value {
	my ($self, $tag, $val, $undefOK) = @_;
	my $para = $globalself->{Paragraphs}{$tag};

	my ($tn, $vn);
	if($val =~ /^\$(\w+)\.?(\w+)?/) {
		($tn, $vn) = ($1, $2);
	} else {
		($tn, $vn) = ($val, undef);
	}

	my ($varref, $varname) = &GetVarDets($globalself, $tag, $tn, $vn, "Bad expression value in paragraph '$tag'", $undefOK);

	return $varref;
}

# Expand a line - internal function.
sub Expand {
	my ($self, $para, $line, $tag, $lineno) = @_;
	my $newline = '';

	# print "expand '$line'\n";
	# Extract ${value@conversion%format}

	# This is nasty:
	while($line =~ s/^
			([^\$]*)			# Any non dollar
			\$\{(\w+)\.?(\w+)?		# ${Variable or ${Tag.Variable
			(@(\w+)\s*(<([^>]+)>)?)?	# Opt: @conversion
			(%[-+ #]*\d*.?\d*\w+)?		# %PrintfFormat
			\}//x) {
		$newline .= $1;
		my $tn = $2;
		my $vn = $3;
		my $conv = $5;
		my $conv_opt = $7;
		my $format = $8;

		my ($substv, $varname) = &GetVarDets($self, $tag, $tn, $vn, "Line $lineno of paragraph '$tag'", 0);

		unless(defined($substv)) {
			$newline .= $varname;	# Couldn't get a value for variable
			next;
		}

		# Special conversions:
		if(defined($conv) and $conv ne '') {
			if($conv eq 'time') {
				# Convert using a date style format string
				$conv_opt = '%c' unless(defined($conv_opt));	# Locale preferred conversion

				my $newval = strftime($conv_opt, localtime ${$substv});
				$substv = \$newval;
			} elsif($conv eq 'center') {
				# Center a field in a specified width
				$conv_opt = 1 unless(defined($conv_opt) and ($conv_opt =~ /^\d+/));
				my $len = length(${$substv});

				if($len < $conv_opt) {
					my $newval = (' ' x (($conv_opt - $len) / 2)) . ${$substv} . (' ' x (($conv_opt - $len + 1) / 2));
					$substv = \$newval;
				}
			} else {
				&Error($self, "Line $lineno of  paragraph '%s' uses unknown conversion '%s'", $tag, $conv);
				$newline .= '${' . $vn . '@' . $conv . '}';
				next;
			}
		}

		# print "substv='$substv' vn='$vn' format='$format'\n";
		# Format
		if(defined($format) and $format ne '') {
			# If numeric avoid barf on unassigned var:
			if(${$substv} eq '' and ($format =~ /[duoxegfXEGiDUOF]$/)) {
				my $z = 0;
				$substv = \$z;
			}
			$newline .= sprintf $format, ${$substv};
		} else {
			$newline .= ${$substv};
		}
	}

	return $newline . $line;
}

# Find out things about a variable and return:
# *	the reference to the variable, undefined on error
# *	the variable name, in a form suitable for error display
# Args:
# 0	$self
# 1	Paragraph tag
# 2	tagname  -- extracted from tagname.varname
# 3	varname
# 4	Error message prefix
# 5	True if undefined value is OK (in which case set the empty string) (must be a calc var)
sub GetVarDets {
	my ($self, $tag, $tn, $vn, $msg, $undefOK) = @_;
	my $para = $self->{Paragraphs}{$tag};

	my $varref;
	my $varname;

	# If no Variable, the Tag is the variable
	if(defined($vn)) {
		$varname = $tn . '.' . $vn;

		unless(defined($self->{Paragraphs}{$tn})) {
			&Error($self, "%s uses unknown tag '%s' in template variable '%s'", $msg, $tag, $varname);
		} else {
			unless(defined($varref = $self->{Paragraphs}{$tn}{$vn})) {
				if($undefOK) {
					my $empty = '';
					$varref = $self->{Paragraphs}{CalcVars}{$vn} = \$empty;
				} else {
					&Error($self, "%s uses unknown template variable '%s'", $msg, $varname);
				}
			}
		}
	} else {
		# Get ref to value - page's own, calculated or global:
		$varref = $self->{Variables}{$tn};
		$varref = $self->{CalcVars}{$tn} if(defined($self->{CalcVars}{$tn}));
		$varref = $para->{$tn} if(defined($para->{$tn}));
		if(!defined($varref) and $undefOK) {
			my $empty = '';
			$varref = $self->{CalcVars}{$tn} = \$empty;
		}
		$varname = $tn;
		&Error($self, "%s uses unknown template variable '%s'", $msg, $varname)
			unless(defined($varref));
	}

	# Is the value of the variable defined ?
	unless(defined(${$varref})) {
		&Error($self, "%s uses variable '%s' which does not have a value", $msg, $varname);
		undef $varref;
	}

	return ($varref, ('${' . $varname . '}'));
}

# Set variable_name/variable association.
# The argument is an array of name => variable_reference
# Because we take a reference, this only needs to be called once in a program.
# A warning will be made if a name is reused.
sub BindVars {
	my $self = shift @_;

	my $varp = $self->{Variables};

	while((my $name = shift @_) and (my $val = shift @_)) {
		# print "name='$name' val='${$val}'\n";
		if(defined($varp->{$name})) {
			&Error($self, "Reusing variable name '%s'", $name);
			$self->{Errors}--;	# Only warning
		}
		$varp->{$name} = $val;
	}
}

# Remove variable_name/variable association.
# The argument is an array of names
sub UnbindVars {
	my $self = shift @_;

	my $varp = $self->{Variables};

	while((my $name = shift @_)) {
		# print "name='$name' val='${$val}'\n";
		if(defined($varp->{$name})) {
			delete($varp->{$name});
		} else {
			&Error($self, "Ubinding unknown variable name '%s'", $name);
			$self->{Errors}--;	# Only warning
		}
	}
}

1;

__END__