File Coverage

lib/OODoc/Template.pm

Criterion	Covered	Total	%
statement	199	210	94.7
branch	120	154	77.9
condition	24	44	54.5
subroutine	23	24	95.8
pod	13	14	92.8
total	379	446	84.9

# This code is part of Perl distribution OODoc-Template version 0.19.
# The POD got stripped from this file by OODoc version 3.02.
# For contributors see file ChangeLog.

# This software is copyright (c) 2003-2025 by Mark Overmeer.

# This is free software; you can redistribute it and/or modify it under
# the same terms as the Perl 5 programming language system itself.
# SPDX-License-Identifier: Artistic-1.0-Perl OR GPL-1.0-or-later

#oodist: *** DO NOT USE THIS VERSION FOR PRODUCTION ***
#oodist: This file contains OODoc-style documentation which will get stripped
#oodist: during its release in the distribution.  You can use this file for
#oodist: testing, however the code of this development version may be broken!

package OODoc::Template;{
our $VERSION = '0.19';
}


use strict;
use warnings;

use Log::Report  'oodoc-template';

use File::Spec::Functions qw/file_name_is_absolute canonpath catfile rel2abs/;
use Scalar::Util          qw/weaken/;

my @default_markers = ('', '');

#--------------------

sub new(@)
{	my ($class, %args) = @_;
	(bless {}, $class)->init(\%args);
}

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

	$self->{cached}     = {};
	$self->{macros}     = {};

	my $s = $self; weaken $s;   # avoid circular ref
	$args->{template} ||= sub { $s->includeTemplate(@_) };
	$args->{macro}    ||= sub { $s->defineMacro(@_) };

	$args->{search}   ||= '.';
	$args->{markers}  ||= \@default_markers;
	$args->{define}   ||= sub { shift; (1, @_) };

	$self->pushValues($args);
	$self;
}

#--------------------


sub process($)
{	my ($self, $templ) = (shift, shift);
	my $values = @_==1 ? shift : +{ @_ };

	my $tree     # parse with real copy
	 = ref $templ eq 'SCALAR' ? $self->parseTemplate($$templ)
	 : ref $templ eq 'ARRAY'  ? $templ
	 :                          $self->parseTemplate("$templ");

	defined $tree
		or return ();

	$self->pushValues($values)
		if keys %$values;

	my @output;
  NODE:
	foreach my $node (@$tree)
	{	unless(ref $node)
		{	push @output, $node;
			next NODE;
		}

		my ($tag, $attr, $then, $else) = @$node;

		my %attrs;
		while(my($k, $v) = each %$attr)
		{	$attrs{$k} = ref $v ne 'ARRAY' ? $v
			: @$v==1 ? scalar $self->valueFor(@{$v->[0]})
			: join '', map {ref $_ eq 'ARRAY' ? scalar $self->valueFor(@$_) : $_} @$v;
		}

		(my $value, my $attrs, $then, $else) = $self->valueFor($tag, \%attrs, $then, $else);

		unless(defined $then || defined $else)
		{	defined $value or next NODE;

			ref $value ne 'ARRAY' && ref $value ne 'HASH'
				or error __x"value for {tag} is {value}, must be single",
						tag => $tag, value => $value;

			push @output, $value;
			next NODE;
		}

		my $take_else = !defined $value || (ref $value eq 'ARRAY' && @$value==0);
		my $container = $take_else ? $else : $then;

		defined $container
			or next NODE;

		$self->pushValues($attrs) if keys %$attrs;

		if($take_else)
		{	my ($nest_out, $nest_tree) = $self->process($container);
			push @output, $nest_out;
			$node->[3] = $nest_tree;
		}
		elsif(ref $value eq 'HASH')
		{	my ($nest_out, $nest_tree) = $self->process($container, $value);
			push @output, $nest_out;
			$node->[2] = $nest_tree;
		}
		elsif(ref $value eq 'ARRAY')
		{	foreach my $data (@$value)
			{	my ($nest_out, $nest_tree) = $self->process($container, $data);
				push @output, $nest_out;
				$node->[2] = $nest_tree;
			}
		}
		else
		{	my ($nest_out, $nest_tree) = $self->process($container);
			push @output, $nest_out;
			$node->[2] = $nest_tree;
		}

		$self->popValues if keys %$attrs;
	}

	$self->popValues if keys %$values;

	    wantarray         ? (join('', @output), $tree)  # LIST context
	  : defined wantarray ? join('', @output)           # SCALAR context
	  :                     print @output;              # VOID context
}


sub processFile($;@)
{	my ($self, $filename) = (shift, shift);

	my $values = @_==1 ? shift : {@_};
	$values->{source} ||= $filename;

	my $cache  = $self->{cached};

	my ($output, $tree, $template);
	if(exists $cache->{$filename})
	{	$tree   = $cache->{$filename};
		$output = $self->process($tree, $values)
			if defined $tree;
	}
	elsif($template = $self->loadFile($filename))
	{	($output, $tree) = $self->process($template, $values);
		$cache->{$filename} = $tree;
	}
	else
	{	$tree = $cache->{$filename} = undef;
	}

	defined $tree || defined wantarray
		or error __x"cannot find template file {file}", file => $filename;

	    wantarray         ? ($output, $tree)  # LIST context
	  : defined wantarray ? $output           # SCALAR context
	  :                     print $output;    # VOID context
}

#--------------------

sub defineMacro($$$$)
{	my ($self, $tag, $attrs, $then, $else) = @_;
	my $name = delete $attrs->{name}
		or error __x"macro requires a name";

	defined $else
		and error __x"macros cannot have an else part ({macro})",macro => $name;

	my %attrs = %$attrs;   # for closure
	$attrs{markers} = $self->valueFor('markers');

	$self->{macros}{$name}          =
sub {my ($tag, $at) = @_;
			$self->process($then, +{%attrs, %$at});
			};

	();

}


sub valueFor($;$$$)
{	my ($self, $tag, $attrs, $then, $else) = @_;

	for(my $set = $self->{values}; defined $set; $set = $set->{NEXT})
	{	my $v = $set->{$tag};

		if(defined $v)
		{	# HASH  defines container
			# ARRAY defines container loop
			# object or other things can be stored as well, but may get
			# stringified.
			return wantarray ? ($v, $attrs, $then, $else) : $v
				if ref $v ne 'CODE';

			my @w = $v->($tag, $attrs, $then, $else);
			return wantarray ? @w : $w[0];
		}

		return wantarray ? (undef, $attrs, $then, $else) : undef
			if exists $set->{$tag};

		my $code = $set->{DYNAMIC};
		if(defined $code)
		{	my ($value, @other) = $code->($tag, $attrs, $then, $else);
			return wantarray ? ($value, @other) : $value
				if defined $value;
			# and continue the search otherwise
		}
	}

	wantarray ? (undef, $attrs, $then, $else) : undef;
}


sub allValuesFor($;$$$)
{	my ($self, $tag, $attrs, $then, $else) = @_;
	my @values;

	for(my $set = $self->{values}; defined $set; $set = $set->{NEXT})
	{
		if(defined(my $v = $set->{$tag}))
		{	my $t = ref $v eq 'CODE' ? $v->($tag, $attrs, $then, $else) : $v;
			push @values, $t if defined $t;
		}

		if(defined(my $code = $set->{DYNAMIC}))
		{	my $t = $code->($tag, $attrs, $then, $else);
			push @values, $t if defined $t;
		}
	}

	@values;
}


sub pushValues($)
{	my ($self, $attrs) = @_;

	if(my $markers = $attrs->{markers})
	{	my @markers = ref $markers eq 'ARRAY' ? @$markers
		: map {s/\\\,//g; $_} split /(?!<\\)\,\s*/, $markers;

		push @markers, $markers[0] . '/'
			if @markers==2;

		push @markers, $markers[1]
			if @markers==3;

		$attrs->{markers}
		= [ map { ref $_ eq 'Regexp' ? $_ : qr/\Q$_/ } @markers ];
	}

	if(my $search = $attrs->{search})
	{	$attrs->{search} = [ split /\:/, $search ]
			if ref $search ne 'ARRAY';
	}

	$self->{values} = { %$attrs, NEXT => $self->{values} };
}


sub popValues()
{	my $self = shift;
	$self->{values} = $self->{values}{NEXT};
}


sub includeTemplate($$$)
{	my ($self, $tag, $attrs, $then, $else) = @_;

	defined $then || defined $else
		and error __x"template is not a container";

	if(my $fn = $attrs->{file})
	{	my $output = $self->processFile($fn, $attrs);
		$output    = $self->processFile($attrs->{alt}, $attrs)
			if !defined $output && $attrs->{alt};

		defined $output
			or error __x"cannot find template file {file}", file => $fn;

		return ($output);
	}

	if(my $name = $attrs->{macro})
	{	my $macro = $self->{macros}{$name}
			or error __x"cannot find macro {name}", name => $name;

		return $macro->($tag, $attrs, $then, $else);
	}

	error __x"file or macro attribute required for template in {source}", source => $self->valueFor('source') || '??';
}



sub loadFile($)
{	my ($self, $relfn) = @_;
	my $absfn;

	if(file_name_is_absolute $relfn)
	{	my $fn = canonpath $relfn;
		$absfn = $fn if -f $fn;
	}

	unless($absfn)
	{	my @srcs = map @$_, $self->allValuesFor('search');
		foreach my $dir (@srcs)
		{	$absfn = rel2abs $relfn, $dir;
			last if -f $absfn;
			$absfn = undef;
		}
	}

	defined $absfn
		or return undef;

	open my $in, '<:encoding(utf-8)', $absfn;
	unless(defined $in)
	{	my $source = $self->valueFor('source') || '??';
		fault __x"Cannot read from {fn} in {file}", fn => $absfn, file=>$source;
	}

	\(join '', $in->getlines);  # auto-close in
}

#--------------------

sub parse($@)
{	my ($self, $template) = (shift, shift);
	$self->process(\$template, @_);
}


sub parseTemplate($)
{	my ($self, $template) = @_;
	defined $template or return undef;

	my $markers = $self->valueFor('markers');

	# Remove white-space escapes
	$template =~ s! \\ (?: \s* (?: \\ \s*)? \n)+
					(?: \s* (?= $markers->[0] | $markers->[3] ))?
				!!mgx;

	my @frags;

	# NOT_$tag supported for backwards compat
	while( $template =~ s!^(.*?)        # text before container
							$markers->[0] \s*
							(?: IF \s* )?
							(NOT (?:_|\s+) )?
							([\w.-]+) \s*    # tag
							(.*?) \s*    # attributes
							$markers->[1]
						!!xs
		)
	{	push @frags, $1;
		my ($not, $tag, $attr) = ($2, $3, $4);
		my ($then, $else);

		if($template =~ s! (.*?)           # contained
							( $markers->[2]
							\s* \Q$tag\E \s*  # "our" tag
							$markers->[3]
							)
						!!xs)
		{	$then       = $1;
			my $endline = $2;
		}

		if($not) { ($then, $else) = (undef, $then) }
		elsif(!defined $then) { }
		elsif($then =~ s! $markers->[0]
						\s* ELSE (?:_|\s+)
						\Q$tag\E \s*
						$markers->[1]
						(.*)
						!!xs)
		{	# $else_$tag for backwards compat
			$else = $1;
		}

		push @frags, [$tag, $self->parseAttrs($attr), $then, $else];
	}

	push @frags, $template;
	\@frags;
}



sub parseAttrs($)
{	my ($self, $string) = @_;

	my %attrs;
	while( $string =~ s!
			^ \s*
				(?: '([^']+)'     # attribute name (might be quoted)
				|   "([^"]+)"
				|   (\w+)
				)
			\s* (?: \= \>? \s*    # an optional value
				( \"[^"]*\"       # dquoted value
				| \'[^']*\'       # squoted value
				| \$\{ [^}]+ \}   # complex variable
				| [^\s,]+         # unquoted value
				)
			)?
			\s* \,?               # optionally separated by commas
		!!xs)
	{	my ($k, $v) = ($1||$2||$3, $4);
		unless(defined $v)
		{	$attrs{$k} = 1;
			next;
		}

		if($v =~ m/^\'(.*)\'$/)
		{	# Single quoted parameter, no interpolation
			$attrs{$k} = $1;
			next;
		}

		$v =~ s/^\"(.*)\"$/$1/;
		my @v = split /( \$\{[^\}]+\} | \$\w+ )/x, $v;

		if(@v==1 && $v[0] !~ m/^\$/)
		{	$attrs{$k} = $v[0];
			next;
		}

		my @steps;
		foreach (@v)
		{	if( m/^ (?: \$(\w+) | \$\{ (\w+) \s* \} ) $/x )
			{	push @steps, [ $+ ];
			}
			elsif( m/^ \$\{ (\w+) \s* ([^\}]+? \s* ) \} $/x )
			{	push @steps, [ $1, $self->parseAttrs($2) ];
			}
			else
			{	push @steps, $_ if length $_;
			}
		}

		$attrs{$k} = \@steps;
	}

	error __x"attribute error in '{tag}'", tag => $_[1]
		if length $string;

	\%attrs;
}

#--------------------

1;