File Coverage

blib/lib/HTML/Chunks/Super.pm

Criterion	Covered	Total	%
statement	12	81	14.8
branch	0	36	0.0
condition	0	24	0.0
subroutine	4	9	44.4
pod	1	5	20.0
total	17	155	10.9

package HTML::Chunks::Super;

use Safe;
use IO::Scalar;
use strict;
use base qw(HTML::Chunks);

our $VERSION = "1.01";

sub new
{
	my $class = shift;
	my $self = $class->SUPER::new(@_);

	return $self;
}

# override basic chunk output to support conditionals
sub outputBasicChunk
{
	my $self = shift;
	my $chunk = shift;
	my $chunkRef = ref $chunk ? $chunk : \$chunk;

	my $tree = $self->buildTree($chunkRef);
	$self->outputNode($tree, @_);
}

# parse a chunk into a decision tree.  it might be possible to gain some
# efficiencies by doing this parsing when chunks are loaded, but it would
# be tricky to avoid confusing our parent class.
sub buildTree
{
	my $self = shift;
	my ($chunk) = @_;

	my $chunkRef = ref $chunk ? $chunk : \$chunk;
	my $tree = [];
	my @stack;
	my $pos = 0;

	while ($$chunkRef =~ /\G(.*?)/gs)
	{
		my $beginDepth = @stack;
		my $node = $beginDepth ? $stack[-1]->{current} : $tree;

		if (defined $1 && length $1)
		{
			push @{$node}, $1;
		}

		my $cmd = uc($2);

		if ($cmd eq 'ELSE' || $cmd eq 'ELSIF')
		{
			my $branch = @stack ? $stack[-1] : undef;

			if ($branch && $branch->{current} == $branch->{true})
			{
				$node = $branch->{current} = $branch->{false} = [];
			}
		}

		if ($cmd eq 'ENDIF' || $cmd eq 'ELSIF')
		{
			my $branch = pop @stack;
			delete $branch->{current} if $branch;
		}

		if ($cmd eq 'IF' || ($cmd eq 'ELSIF' && $beginDepth))
		{
			my $branch = {
				test => $3,
				true => []
			};

			push @{$node}, $branch;
			push @stack, $branch;
			$branch->{current} = $branch->{true};
		}

		$pos = pos $$chunkRef;
	}

	my $tail = substr $$chunkRef, $pos;
	push @{$tree}, $tail if (defined $tail && length $tail);

	return $tree;
}

sub outputNode
{
	my $self = shift;
	my $node = shift;

	if (defined $node)
	{
		die "what is this? => ", $node, "\n" unless (ref $node eq 'ARRAY');

		foreach my $thing (@{$node})
		{
			if (ref $thing eq 'HASH')
			{
				if (exists $thing->{test} && $self->testsTrue($thing->{test}, @_))
				{
					$self->outputNode($thing->{true}, @_) if (exists $thing->{true});
				}
				else
				{
					$self->outputNode($thing->{false}, @_) if (exists $thing->{false});
				}
			}
			else
			{
				# call the normal HTML::Chunk output routine when we're down to a
				# basic unadulterated chunk
				$self->SUPER::outputBasicChunk(\$thing, @_);
			}
		}
	}
}

sub testsTrue
{
	my $self = shift;
	my $test = shift;
	our %values;
	local %values;

	# Translate any data tokens into scalars containing the actual data values

	$test =~ s/\#\#([\w\.]+)\#\#/
		my $name = $1;
		my $f = new IO::Scalar \$values{$name};
		my $oldfh = select $f;
		$self->outputData($name, @_);
		select $oldfh;
		close $f;

		"\$values{'$name'}";
	/gex;

	# select STDERR, otherwise a 'print' in the test will blow up apache
	my $oldfh = select STDERR;

	# now safely evaluate the test
	my $safe = new Safe;
	$safe->share('%values');
	my $status = $safe->reval($test);

	# put filehandle things back
	select $oldfh;

	warn $@ if $@;

	return $status;
}

1;

__END__