File Coverage

blib/lib/HTML/Chunks.pm

Criterion	Covered	Total	%
statement	6	128	4.6
branch	0	48	0.0
condition	0	20	0.0
subroutine	2	23	8.7
pod	10	21	47.6
total	18	240	7.5

package HTML::Chunks;

use strict;

our $VERSION = '1.55';

use constant DATA_REGEX => qr/##[\w\.]+##/;

sub new
{
	my $self = bless {}, shift;

	$self->init(@_);
	return $self;
}

sub init
{
	my $self = shift;

	$self->{crush}     = 1;
	$self->{cascade}   = 1;
	$self->{dataStack} = [];
	$self->{chunk}     = {};
	$self->{default}   = undef;

	$self->read(@_) if @_;
}

sub readChunkFile
{
	my $self = shift;

	foreach my $file (@_) {
		if (my $fh = $self->getFilehandle($file)) {
			my @chunkStack;

			while (my $line = <$fh>) {
				$self->parse(\@chunkStack, \$line);
			}
			close $fh;
		}
		else {
			warn "Can't open file [$file]\n";
		}
	}
}

sub readSimpleFile
{
	my $self = shift;

	foreach my $file (@_) {
		if (my $fh = $self->getFilehandle($file)) {
			while (<$fh>) {
				next if /^#/ or !/\S/;

				s/[\r\n]//g;
				s/^\s+|\s+$//g;

				my ($name, $chunk) = split(/\s+/, $_, 2);
				if ($name && $chunk) {
					$self->addNamedChunk($name, $chunk);
				}
			}
			close $fh;
		}
	}
}

sub getFilehandle
{
	my $self = shift;
	my ($file) = @_;

	return $file if ref $file; # already a filehandle
	return open (CHUNKIN, $file) ? \*CHUNKIN : undef;
}

sub addChunk
{
	my $self = shift;

	foreach my $chunk (@_) {
		next unless $chunk;

		# allow a ref to be passed for efficiency
		my $ref = ref $chunk ? $chunk : \$chunk;
		$self->parse([], $ref);
	}
}

sub addNamedChunk
{
	my $self = shift;
	my ($name, $chunk) = @_;

	return unless ($name && $chunk);

	# allow a ref to be passed for efficiency
	my $ref = ref $chunk ? $chunk : \$chunk;
	$self->{chunk}{$name} = undef;
	$self->parse([ \$self->{chunk}{$name} ], $ref);
}

sub parse
{
	my $self = shift;
	my ($chunkStack, $data) = @_;
	my $chunk = $chunkStack->[-1];

	# allow a ref to be passed for efficiency
	my $dataRef = ref $data ? $data : \$data;

	foreach (split(/()/, $$dataRef)) {
		if (//i) {
			$self->{chunk}{$1} = undef;
			push @{$chunkStack}, $chunk = \$self->{chunk}{$1};
		}
		elsif ($chunk && //i) {
			$$chunk =~ s/\s{2,}/\n/sg if $self->{crush}; # crush whitespace
			pop @{$chunkStack};
			$chunk = $chunkStack->[-1];
		}
		elsif ($chunk && ($_ || !$self->{crush})) {
			$$chunk .= $_;
		}
	}
}

sub output
{
	my $self = shift;
	my $name = shift;

	$self->outputAsChunk(\$self->{chunk}{$name}, @_);
}

sub outputAsChunk
{
	my $self  = shift;
	my $chunk = shift;
	my $data  = shift;

	if ($chunk) {
		my $chunkRef = ref $chunk ? $chunk : \$chunk;
		$data ||= {};

		push @{$self->{dataStack}}, $data;
		$self->outputBasicChunk($chunkRef, @_);
		pop @{$self->{dataStack}};
	}
}

# basic chunk output including data substitution, using data already
# on the data stack.
sub outputBasicChunk
{
	my $self = shift;
	my $chunk = shift;
	my $chunkRef = ref $chunk ? $chunk : \$chunk;
	my $data_regex = $self->DATA_REGEX;

	foreach my $piece (split(/(|$data_regex)/, $$chunkRef)) {
		if ($piece =~ /($data_regex)/) {
			$self->outputData(substr($1, 2, -2), @_);
		}
		else {
			print $piece;
		}
	}
}

sub outputData
{
	my $self = shift;
	my $name = shift;
	my $value = $self->getDataValue($name);

	if (ref $value eq 'CODE') {
		&{$value}($self, $name, @_);
	}
	else {
		print $value;
	}
}

sub getDataValue
{
	my ($self, $name) = (shift, shift);
	my $value;
	my $last = $self->{cascade} ? 0 : $#{$self->{dataStack}};

	for (my $ndx = $#{$self->{dataStack}}; $ndx >= $last; $ndx--) {
		if (exists($self->{dataStack}[$ndx]{$name})) {
			$value = $self->{dataStack}[$ndx]{$name};
			last;
		}
	}

	if ($value eq '') {
		return $self->{default};
	}
	else {
		return $value;
	}
}

sub getChunkNames
{
	my $self = shift;
	return keys %{$self->{chunk}};
}

sub getChunk
{
	my $self = shift;
	my ($name) = @_;

	return $self->{chunk}{$name};
}

sub getChunkHash
{
	my $self = shift;
	return { %{$self->{chunk}} };
}

sub setCrush
{
	my $self = shift;
	my $old = $self->{crush};
	($self->{crush}) = (@_);
	return $old;
}

sub setCascade
{
	my $self = shift;
	my $old = $self->{cascade};
	($self->{cascade}) = (@_);
	return $old;
}

sub setDefaultDataValue
{
	my $self = shift;
	($self->{default}) = (@_);
}

# legacy wrappers for backward compatibility

sub crush
{
	my $self = shift;
	return $self->setCrush(@_);
}

sub read
{
	my $self = shift;
	$self->readChunkFile(@_);
}

1;

__END__