File Coverage

blib/lib/Parse/Plain.pm

Criterion	Covered	Total	%
statement	332	492	67.4
branch	110	226	48.6
condition	6	12	50.0
subroutine	27	35	77.1
pod	27	27	100.0
total	502	792	63.3

package Parse::Plain;

require 5.005;
use strict;


BEGIN
{
	use Exporter;
	use Carp;
	use vars  qw( $VERSION $lcnt_max $ssec );

	$VERSION = "3.03";
}


# constructor
# [I] $template (mandatory): template filename
#     $lcnt_max (optional) : number of attempts to open file
#     $s_sec    (optional) : number of seconds to sleep between
#                            attemts if file can't be opened
sub new
{
	my $type = shift;
	my ($template, $lcnt, @lines, $line, $block, $block_open,
	    $s_block, @bl_stack, @bl_name_stack);
	my $self = {};

	($template, $lcnt_max, $ssec) = @_;

	$self->{'text'}   = '';    # input
	$self->{'hparse'} = {};    # hash of tags - values
	$self->{'gparse'} = {};    # hash of global tags - values
	$self->{'hblock'} = {};    # hash of blocks
	$self->{'oblock'} = {};    # original values of blocks
	$self->{'cback'}  = {};    # callback references
	$self->{'parsed'} = undef; # output

	if ((defined $lcnt_max) && ($lcnt_max !~ /^\d+$/)) {
		&_my_error('$lcnt_max must be number');
	}
	$lcnt_max = 5 unless ($lcnt_max);

	if ((defined $lcnt_max) && ($lcnt_max !~ /^\d+$/)) {
		&_my_error('$ssec must be number');
	}
	$ssec = 1 unless ($ssec);

	@lines = @{&_load_file($template)};

	$block = \$self->{'text'};
	$block_open = '';
	foreach $line(@lines) {
		if ($line =~ m/^\s*{{\s*([\!\w\d\.-_]+)$/) {
			push @bl_name_stack, $block_open
				if ($block_open);

			if (substr($1, 0, 1) eq '!') {
				$s_block = 1;
				$block_open = substr($1, 1);
			} else {
				$s_block = 0;
				$block_open = $1;
			}

			chomp $$block if ($$block);
			$$block .= ('%%!' . $block_open . '%%')
			    unless ($s_block);
			push @bl_stack, $block;
			$block = \$self->{'hblock'}->{$block_open};
			next;
		}
		if (($line =~ m/^\s*}}(.*)$/) && $block_open) {
			chomp $$block if ((!$1) && ($$block));
			$block = pop @bl_stack;
			$block_open = pop @bl_name_stack;
 			$line = ($1 ? $1 . "\n" : '');
 			redo;
		}
		$$block .= $line;
	}

	if ($block_open) {
		&_my_error("in $template: block not closed");
	}

	foreach (keys(%{$self->{'hblock'}})) {
		$self->{'oblock'}->{$_} = $self->{'hblock'}->{$_};
	}

	$self->{'cback'}->{'INCLUDE'} = \&_include_file;

	return bless $self, $type;
}


# set tags in %hparse
# [I] either ($tag, $val) pair or $hash_ref containing { $tag => $val } pairs
# [O] hash_ref containing { $tagname => $new_value, ... }
sub set_tag
{
 	my $self = shift;
	my ($tag, $val, $res);

	unless ($_[0]) {
		&_my_error('required parameter missed');
	}

	$res = {};

	if (ref($_[0]) eq 'HASH') {
		foreach $tag(keys(%{$_[0]})) {
			$val = $_[0]->{$tag};

			if (UNIVERSAL::isa($val, 'Parse::Plain')) {
				$self->{'hparse'}->{$tag} = $val->parse;
			} else {
				$self->{'hparse'}->{$tag} = $val;
			}
			$res->{$tag} = $self->{'hparse'}->{$tag};
		}
	} elsif (!ref($_[0])) {
		($tag, $val) = @_;

		if (UNIVERSAL::isa($val, 'Parse::Plain')) {
			$self->{'hparse'}->{$tag} = $val->parse;
		} else {
			$self->{'hparse'}->{$tag} = $val;
		}
		$res->{$tag} = $self->{'hparse'}->{$tag};
	} else {
		&_my_error('unsupported argument type: ' . ref($_[0]));
	}

	return $res;
}


# retrieve tags from %hparse
# [I] @tags or [$tag1, $tag2, ...]
# [O] [$val1, $val2, ...]
sub get_tag
{
	my $self = shift;
	my ($res, $key);

	unless ($_[0]) {
		&_my_error('required parameter missed');
	}

	$res = [];

	# to avoid mess I support either arrayref or list not both mixed!
	if (ref($_[0]) eq 'ARRAY') {
		foreach $key(@{$_[0]}) {
			push @$res, $self->{'hparse'}->{$key};
		}
	} elsif (!ref($_[0])) {
		while (@_) {
			$key = shift;
			push @$res, $self->{'hparse'}->{$key};
		}
	} else {
		&_my_error('unsupported argument type: ' . ref($_[0]));
	}

	return $res;
}


# append values to tags
# [I] either ($tag, $val) pair or $hash_ref containing { $tag => $val } pairs
# [O] hash_ref with { $tagname => $new_val, ... }
sub push_tag
{
	my $self = shift;
	my ($tag, $val, $res);

	unless ($_[0]) {
		&_my_error('required parameter missed');
	}

	$res = {};

	if (ref($_[0]) eq 'HASH') {
		foreach $tag(keys(%{$_[0]})) {
			$val = $_[0]->{$tag};

			if (UNIVERSAL::isa($val, 'Parse::Plain')) {
				$self->{'hparse'}->{$tag} .= $val->parse;
			} else {
				$self->{'hparse'}->{$tag} .= $val;
			}

			$res->{$tag} = $self->{'hparse'}->{$tag};
		}
	} elsif (!ref($_[0])) {
		($tag, $val) = @_;

		if (UNIVERSAL::isa($val, 'Parse::Plain')) {
			$self->{'hparse'}->{$tag} .= $val->parse;
		} else {
			$self->{'hparse'}->{$tag} .= $val;
		}

		$res->{$tag} = $self->{'hparse'}->{$tag};
	} else {
		&_my_error('unsupported argument type: ' . ref($_[0]));
	}

	return $res;
}


# append tags to passed values and store result in tags
# [I] either ($tag, $val) pair or $hash_ref containing { $tag => $val } pairs
# [O] hash_ref of new values
sub unshift_tag
{
	my $self = shift;
	my ($tag, $val, $res);

	unless ($_[0]) {
		&_my_error('required parameter missed');
	}

	$res = {};

	if (ref($_[0]) eq 'HASH') {
		foreach $tag(keys(%{$_[0]})) {
			$val = $_[0]->{$tag};

			if (UNIVERSAL::isa($val, 'Parse::Plain')) {
				$self->{'hparse'}->{$tag} =
				    $val->parse . $self->{'hparse'}->{$tag};
			} else {
				$self->{'hparse'}->{$tag} =
				    $val . $self->{'hparse'}->{$tag};
			}

			$res->{$tag} = $self->{'hparse'}->{$tag};
		}
	} elsif (!ref($_[0])) {
		($tag, $val) = @_;

		if (UNIVERSAL::isa($val, 'Parse::Plain')) {
			$self->{'hparse'}->{$tag} =
			    $val->parse . $self->{'hparse'}->{$tag};
		} else {
			$self->{'hparse'}->{$tag} =
			    $val . $self->{'hparse'}->{$tag};
		}

		$res->{$tag} = $self->{'hparse'}->{$tag};
	} else {
		&_my_error('unsupported argument type: ' . ref($_[0]));
	}

	return $res;
}


# block src/res accessor, required for backwards compatibility with 2.x
# if block hasn't been parse()'d yet or has been unparse()'d then
# block_src() used else block_res()
# [I] scalar blockname to get or list (blockname, val) to set value
# [O] same as block_src() / block_res()
sub block
{
	my $self = shift;
	my ($bl);

	$bl = $_[0];
	unless ($bl) {
		&_my_error('required parameter missed');
	}

	if (defined $self->{'hparse'}->{'!' . $bl}) {
		return $self->block_res(@_);
	} else {
		return $self->block_src(@_);
	}

	&_my_error('control flow must never reach here');
}


# block source accessor
# [I] either block name (to get block value)
#     or array_ref of block names to get their values
#     or ($block, $val) to set $val to $block
#     or hash_ref of { $block => $val, ... } pairs
# [O] hash_ref with (new) values of blocks
sub block_src
{
	my $self = shift;
	my ($bl, $val, $res, @arr);

	@arr = @_;
	unless ($arr[0]) {
		&_my_error('required parameter missed');
	}

	$res = {};
	if (ref($arr[0]) eq 'ARRAY') { # get block vals from arr_ref
		foreach $bl(@{$arr[0]}) {
			$res->{$bl} = $self->{'hblock'}->{$bl};
		}
	} elsif (ref($arr[0]) eq 'HASH') { # set block val from hash_ref
		foreach $bl(keys(%{$arr[0]})) {
			$val = $arr[0]->{$bl};

			if (UNIVERSAL::isa($val, 'Parse::Plain')) {
				$self->{'hblock'}->{$bl} = $val->parse;
			} else {
				$self->{'hblock'}->{$bl} = $val;
			}

			$res->{$bl} = $self->{'hblock'}->{$bl};
		}
	} elsif (!ref($arr[0])) { # no refs, for backwards-compatibility
		($bl, $val) = @arr;

		if ($val) {
			if (UNIVERSAL::isa($val, 'Parse::Plain')) {
				$self->{'hblock'}->{$bl} = $val->parse;
			} else {
				$self->{'hblock'}->{$bl} = $val;
			}
		}

		$res->{$bl} = $self->{'hblock'}->{$bl};
	} else {
		&_my_error('unsupported argument type: ' . ref($arr[0]));
	}

	return $res;
}


# block result accessor
# [I] either block name (to get block value)
#     or array_ref of block names to get their values
#     or ($block, $val) to set $val to $block
#     or hash_ref of { $block => $val, ... } pairs
# [O] hash_ref with (new) values of blocks
sub block_res
{
	my $self = shift;
	my ($bl, $blf, $val, $res, @arr);

	@arr = @_;
	unless ($arr[0]) {
		&_my_error('required parameter missed');
	}

	$res = {};

	if (ref($arr[0]) eq 'ARRAY') { # get block vals from arr_ref
		foreach $bl(@{$arr[0]}) {
			$blf = '!' . $bl;

			if (defined $self->{'hparse'}->{$blf}) {
				$res->{$bl} = $self->{'hparse'}->{$blf};
			} else {
				$res->{$bl} = undef;
			}
		}
	} elsif (ref($arr[0]) eq 'HASH') { # set block val from hash_ref
		foreach $bl(keys(%{$arr[0]})) {
			$val = $arr[0]->{$bl};
			$blf = '!' . $bl;

			if (UNIVERSAL::isa($val, 'Parse::Plain')) {
				$self->{'hparse'}->{$blf} = $val->parse;
			} else {
				$self->{'hparse'}->{$blf} = $val;
			}

			$res->{$bl} = $self->{'hparse'}->{$blf};
		}
	} elsif (!ref($arr[0])) { # no refs, for backwards-compatibility
		($bl, $val) = @arr;
		$blf = '!' . $bl;

		if ($val) {
			if (UNIVERSAL::isa($val, 'Parse::Plain')) {
				$self->{'hparse'}->{$blf} = $val->parse;
			} else {
				$self->{'hparse'}->{$blf} = $val;
			}
		}

		if (defined $self->{'hparse'}->{$blf}) {
			$res->{$bl} = $self->{'hparse'}->{$blf};
		} else {
			$res->{$bl} = undef;
		}
	} else {
		&_my_error('unsupported argument type: ' . ref($arr[0]));
	}

	return $res;
}


# append values to src / res blocks
# required for backwards compatibility with 2.x
# if block hasn't been parse()'d yet or has been unparse()'d then
# push_block_src() used else push_block_res()
# [I] list (blockname, val)
# [O] same as push_block_src() / push_block_res()
sub push_block
{
	my $self = shift;
	my ($bl);

	$bl = $_[0];
	unless ($bl) {
		&_my_error('required parameter missed');
	}

	if (defined $self->{'hparse'}->{'!' . $bl}) {
		return $self->push_block_res(@_);
	} else {
		return $self->push_block_src(@_);
	}

	&_my_error('control flow must never reach here');
}


# append values to blocks sources
# [I] either ($block, $val) or $hash_ref with { $block => $val, ... } pairs
# [O] hash_ref of new values
sub push_block_src
{
	my $self = shift;
	my ($block, $val, $res);

	unless ($_[0]) {
		&_my_error('required parameter missed');
	}

	$res = {};

	if (ref($_[0]) eq 'HASH') {
		foreach $block(keys(%{$_[0]})) {
			$val = $_[0]->{$block};

			if (UNIVERSAL::isa($val, 'Parse::Plain')) {
				$self->{'hblock'}->{$block} .= $val->parse;
			} else {
				$self->{'hblock'}->{$block} .= $val;
			}

			$res->{$block} = $self->{'hblock'}->{$block};
		}
	} elsif (!ref($_[0])) {
		($block, $val) = @_;

		if (UNIVERSAL::isa($val, 'Parse::Plain')) {
			$self->{'hblock'}->{$block} .= $val->parse;
		} else {
			$self->{'hblock'}->{$block} .= $val;
		}

		$res->{$block} = $self->{'hblock'}->{$block};
	} else {
		&_my_error('unsupported argument type: ' . ref($_[0]));
	}

	return $res;
}


# append values to blocks results
# [I] either ($block, $val) or $hash_ref with { $block => $val, ... } pairs
# [O] hash_ref of new values
sub push_block_res
{
	my $self = shift;
	my ($block, $blockf, $val, $res);

	unless ($_[0]) {
		&_my_error('required parameter missed');
	}

	$res = {};

	if (ref($_[0]) eq 'HASH') {
		foreach $block(keys(%{$_[0]})) {
			$val = $_[0]->{$block};
			$blockf = '!' . $block;

			if (UNIVERSAL::isa($val, 'Parse::Plain')) {
				$self->{'hparse'}->{$blockf} .= $val->parse;
			} else {
				$self->{'hparse'}->{$blockf} .= $val;
			}

			$res->{$block} = $self->{'hparse'}->{$blockf};
		}
	} elsif (!ref($_[0])) {
		($block, $val) = @_;
		$blockf = '!' . $block;

		if (UNIVERSAL::isa($val, 'Parse::Plain')) {
			$self->{'hparse'}->{$blockf} .= $val->parse;
		} else {
			$self->{'hparse'}->{$blockf} .= $val;
		}

		$res->{$block} = $self->{'hparse'}->{$blockf};
	} else {
		&_my_error('unsupported argument type: ' . ref($_[0]));
	}

	return $res;
}


# push values to src / res blocks
# required for backwards compatibility with 2.x
# if block hasn't been parse()'d yet or has been unparse()'d then
# unshift_block_src() used else unshift_block_res()
# [I] list (blockname, val)
# [O] same as unshift_block_src() / unshift_block_res()
sub unshift_block
{
	my $self = shift;
	my ($bl);

	$bl = $_[0];
	unless ($bl) {
		&_my_error('required parameter missed');
	}

	if (defined $self->{'hparse'}->{'!' . $bl}) {
		return $self->unshift_block_res(@_);
	} else {
		return $self->unshift_block_src(@_);
	}

	&_my_error('control flow must never reach here');
}


# append block(s) sources to passed values and store
# result back into blocks sources
# [I] either ($block, $val) or $hash_ref with { $block => $val, ... } pairs
# [O] if hash_ref was passed then hash_ref of new values else just new value
sub unshift_block_src
{
	my $self = shift;
	my ($block, $val, $res);

	unless ($_[0]) {
		&_my_error('required parameter missed');
	}

	$res = {};

	if (ref($_[0]) eq 'HASH') {
		foreach $block(keys(%{$_[0]})) {
			$val = $_[0]->{$block};

			if (UNIVERSAL::isa($val, 'Parse::Plain')) {
				$self->{'hblock'}->{$block} =
				    $val->parse . $self->{'hblock'}->{$block};
			} else {
				$self->{'hblock'}->{$block} =
				    $val . $self->{'hblock'}->{$block};
			}

			$res->{$block} = $self->{'hblock'}->{$block};
		}
	} elsif (!ref($_[0])) {
		($block, $val) = @_;

		if (UNIVERSAL::isa($val, 'Parse::Plain')) {
			$self->{'hblock'}->{$block} =
			    $val->parse . $self->{'hblock'}->{$block};
		} else {
			$self->{'hblock'}->{$block} =
			    $val . $self->{'hblock'}->{$block};
		}

		$res->{$block} = $self->{'hblock'}->{$block};
	} else {
		&_my_error('unsupported argument type: ' . ref($_[0]));
	}

	return $res;
}


# append blocks results to passed values and
# store block results back into blocks
# [I] either ($block, $val) or $hash_ref with { $block => $val, ... } pairs
# [O] if hash_ref was passed then hash_ref of new values else just new value
sub unshift_block_res
{
	my $self = shift;
	my ($block, $blockf, $val, $res);

	unless ($_[0]) {
		&_my_error('required parameter missed');
	}

	$res = {};

	if (ref($_[0]) eq 'HASH') {
		foreach $block(keys(%{$_[0]})) {
			$val = $_[0]->{$block};
			$blockf = '!' . $block;

			if (UNIVERSAL::isa($val, 'Parse::Plain')) {
				$self->{'hparse'}->{$blockf} =
				    $val->parse . $self->{'hparse'}->{$blockf};
			} else {
				$self->{'hparse'}->{$blockf} =
				    $val . $self->{'hparse'}->{$blockf};
			}

			$res->{$block} = $self->{'hparse'}->{$blockf};
		}
	} elsif (!ref($_[0])) {
		($block, $val) = @_;
		$blockf = '!' . $block;

		if (UNIVERSAL::isa($val, 'Parse::Plain')) {
			$self->{'hparse'}->{$blockf} =
			    $val->parse . $self->{'hparse'}->{$blockf};
		} else {
			$self->{'hparse'}->{$blockf} =
			    $val . $self->{'hparse'}->{$blockf};
		}

		$res->{$block} = $self->{'hparse'}->{$blockf};
	} else {
		&_my_error('unsupported argument type: ' . ref($_[0]));
	}

	return $res;
}


# resets blocks sources to it's original values (as in template)
# [I] array_ref or list with block names
# [O] hash_ref of original block values
sub reset_block_src
{
	my $self = shift;
	my ($res, $block, @arr);

	@arr = @_;
	$block = shift @arr;
	unless ($block) {
		&_my_error('required parameter missed');
	}

	$res = {};

	if (ref($block) eq 'ARRAY') {
		foreach (@$block) {
			$self->{'hblock'}->{$_} = $self->{'oblock'}->{$_};
			$res->{$_} = $self->{'hblock'}->{$_};
		}
	} elsif (!ref($block)) {
		while ($block) {
			$self->{'hblock'}->{$block} =
			    $self->{'oblock'}->{$block};
			$res->{$block} = $self->{'hblock'}->{$block};
			$block = shift @arr;
		}
	} else {
		&_my_error('unsupported argument type: ' . ref($arr[0]));
	}

	return $res;
}


# reset source values for all blocks
# [I] none
# [O] hash_ref of original block values
sub reset_block_src_all
{
	my $self = shift;

	return $self->reset_block_src($self->enum_blocks());
}


# get original block values (as in the source template)
# [I] either list or array_ref of block names
# [O] hash_ref of original block values
sub get_oblock
{
	my $self = shift;
	my (@arr) = @_;
	my ($res);

	$res = {};

	unless ($arr[0]) {
		&_my_error('required parameter missed');
	}

	if (ref($arr[0]) eq 'ARRAY') {
		foreach (@{$arr[0]}) {
			$res->{$_} = $self->{'oblock'}->{$_};
		}
	} elsif (!ref($arr[0])) {
		foreach (@arr) {
			$res->{$_} = $self->{'oblock'}->{$_};
		}
	} else {
		&_my_error('unsupported argument type: ' . ref($arr[0]));
	}

	return $res;
}


# enumarate all blocks in template
# [I] none
# [O] array_ref with block names
sub enum_blocks
{
	my $self = shift;
	my ($res);

	$res = [];

	foreach (keys %{$self->{'oblock'}}) {
		push @$res, $_;
	}

	return $res;
}


# set self->{'text'}, don't use unless absolutely sure
# about what you are doing
# [I] new value to set
# [O] new value
sub set_text
{
	my ($self, $val) = @_;

	if (UNIVERSAL::isa($val, 'Parse::Plain')) {
		$self->{'text'} = $val->parse;
	} else {
		$self->{'text'} = $val;
	}

	return $self->{'text'};
}


# return self->{'text'}
# [I] none
# [O] $self->{'text'}
sub get_text
{
	my $self = shift;

	return $self->{'text'};
}


# set parsing result to specified value; DON'T use unless you are
# absolutely sure about what you're doing
# [I] new value for result
# [O] new value for result
sub set_parsed
{
	my ($self, $val) = @_;

	if (UNIVERSAL::isa($val, 'Parse::Plain')) {
		$self->{'parsed'} = $val->parse;
	} else {
		$self->{'parsed'} = $val;
	}

	return $self->{'parsed'};
}


# global tags accessor, sets or gets tags that are global for any block
# [I] either ($gtag, $val) pair or
#     $hash_ref containing { $gtag => $val } pairs or
#     scalar $gtag to get it's value or
#     arrayref [ $gtag1, $gtag2, ... ] to get their values
# [O] hash_ref containing { $gtag => $new_value, ... }
sub gtag
{
	my $self = shift;
	my ($gtag, $val, $res, @arr);

	@arr = @_;
	unless ($arr[0]) {
		&_my_error('required parameter missed');
	}

	$res = {};

	if (ref($arr[0]) eq 'ARRAY') { # get gtag values
		foreach $gtag(@{$arr[0]}) {
			$res->{$gtag} = $self->{'gparse'}->{$gtag};
		}
	} elsif (ref($arr[0]) eq 'HASH') { # set gtags from hash_ref
		foreach $gtag(keys(%{$arr[0]})) {
			$val = $arr[0]->{$gtag};

			if (UNIVERSAL::isa($val, 'Parse::Plain')) {
				$self->{'gparse'}->{$gtag} = $val->parse;
			} else {
				$self->{'gparse'}->{$gtag} = $val;
			}

			$res->{$gtag} = $self->{'gparse'}->{$gtag};
		}
	} elsif (!ref($arr[0])) { # no refs, for backwards-compatibility
		($gtag, $val) = @arr;

		if ($val) {
			if (UNIVERSAL::isa($val, 'Parse::Plain')) {
				$self->{'gparse'}->{$gtag} = $val->parse;
			} else {
				$self->{'gparse'}->{$gtag} = $val;
			}
		}

		$res->{$gtag} = $self->{'gparse'}->{$gtag};
	} else {
		&_my_error('unsupported argument type: ' . ref($arr[0]));
	}

	return $res;
}


# set callbacks
# [I] either hashref of { 'name' => {coderef}, ... }
#     or pair name, coderef to callback
# [O] none
sub callback
{
	my $self = shift;
	my (@arr, $tmp);

	@arr = @_;

	if (ref($arr[0]) eq 'HASH') { # hashref
		foreach $tmp(keys(%{$arr[0]})) {
			&_my_error('colons not allowed in callback tagnames: '
			    . $tmp) if ($tmp =~ /:/);

			$self->{'cback'}->{$tmp} = $arr[0]->{$tmp};
		}
	} elsif (!ref($arr[0])) { # no refs
			&_my_error('colons not allowed in callback tagname: '
			    . $arr[0]) if ($arr[0] =~ /:/);

			$self->{'cback'}->{$arr[0]} = $arr[1];
	} else {
		&_my_error('unsupported argument type: ' . ref($arr[0]));
	}

	return;
}


# parse template or block
# [I] if none parses outermost block, if $block param is specified then
#     block is parsed and $hparse{$block} is appended with result; if also
#     $href hash reference is specified the block is parsed using $href; if
#     also $usehparse is TRUE, then block will be parsed using
#     'hparse' hash as well.
# [O] parsing results
sub parse
{
	my ($self, $block, $href, $usehparse) = @_;
	my ($res, $lref, $cback, $W);

	$lref = {};

	if ($href) {
		foreach (keys %$href) {
			if (UNIVERSAL::isa($href->{$_}, 'Parse::Plain')) {
				$lref->{$_} = $href->{$_}->parse;
			} else {
				$lref->{$_} = $href->{$_};
			}
		}
	}

	if (!$href) {
		foreach (keys %{$self->{'hparse'}}) {
			$lref->{$_} = $self->{'hparse'}->{$_};
		}
	} elsif ($usehparse) {
		foreach (keys %{$self->{'hparse'}}) {
			$lref->{$_} = $self->{'hparse'}->{$_}
				unless (defined $lref->{$_});
		}
	}

	foreach (keys %{$self->{'gparse'}}) {
		$lref->{$_} = $self->{'gparse'}->{$_}
			unless (defined $lref->{$_});
		# gparse has least priority
	}

	$W = $^W;
	$^W = 0;
	if ($block) {
		$res = $self->{'hblock'}->{$block};
		foreach $cback(keys %{$self->{'cback'}}) {
			$res =~ s/%{2}($cback)\:([\w\d\.\(\)\*\&\^\$\\\/:;,_-]*)%{2}/&{$self->{'cback'}->{$1}}($2)/ge
				if (ref($self->{'cback'}->{$cback}) eq 'CODE');		}
		$res =~ s/%{2}([\w\d\.\(\)\*\&\^\$\\\/:;,_-]+)%{2}/$lref->{$1}/g;
		$res =~ s/%{2}(\![\w\d\.\(\)\*\&\^\$\\\/:;,_-]+)%{2}/$self->{'hparse'}->{$1}/g;
		$self->{'hparse'}->{'!' . $block} .= $res;
	} else {
		if (defined $self->{'parsed'}) {
			$^W = $W;
			return $self->{'parsed'};
		}
		$self->{'parsed'} = $self->{'text'};
		foreach $cback(keys %{$self->{'cback'}}) {
			$self->{'parsed'} =~ s/%{2}($cback)\:([\w\d\.\(\)\*\&\^\$\\\/:;,_-]*)%{2}/&{$self->{'cback'}->{$1}}($2)/ge
				if (ref($self->{'cback'}->{$cback}) eq 'CODE');
		}
		$self->{'parsed'} =~ s/%{2}([\w\d\.\(\)\*\&\^\$\\\/:;,_-]+)%{2}/$lref->{$1}/g;
		$self->{'parsed'} =~ s/%{2}(\![\w\d\.\(\)\*\&\^\$\\\/:;,_-]+)%{2}/$self->{'hparse'}->{$1}/g;
		$res = $self->{'parsed'};
	}
	$^W = $W;

	return $res;
}


# reset parsed blocks
# [I] none to reset outermost block
#     array or arrayref of block names to reset blocks
#     to current values of block sources
# [O] previous value of text or hash_ref with previous
#     values of blocks
sub unparse
{
	my $self = shift;
	my ($tmp, $key, $keyf);

	if ($#_ == -1) {
		$tmp = $self->{'parsed'};
		$self->{'parsed'} = undef;
	} else {
		$tmp = {};

		if (ref($_[0]) eq 'ARRAY') {
			foreach $key(@{$_[0]}) {
				$keyf = '!' . $key;

				if (defined $self->{'hparse'}->{$keyf}) {
					$tmp->{$key} =
					    $self->{'hparse'}->{$keyf};
					$self->{'hparse'}->{$keyf} = undef;
				}
			}
		} elsif (!ref($_[0])) {
			while (@_) {
				$key = shift;
				$keyf = '!' . $key;

				if (defined $self->{'hparse'}->{$keyf}) {
					$tmp->{$key} =
					    $self->{'hparse'}->{$keyf};
					$self->{'hparse'}->{$keyf} = undef;
				}
			}
		} else {
			&_my_error('unsupported argument type: ' . ref($_[0]));
		}
	}

	return $tmp;
}


# unparse() all blocks including outermost
# [I] none
# [O] hash_ref with previous values of blocks except outermost (text)
sub unparse_all
{
	my $self = shift;

	$self->unparse();
	return $self->unparse($self->enum_blocks());
}


# print parsing results, if template already parsed prints it
# otherwise parse template first
# [I] none
# [O] parsing results
sub output
{
	my $self = shift;

	print $self->parse;

	return $self->{'parsed'};
}


# callback for including templates recursively via %%include:filename.tmpl%%
# not method, not exported
# [I] filename
# [O] file contents as scalar
sub _include_file
{
	my $arg = shift;
	my ($cnt);

	return '' unless ($arg);

	$cnt = join('', @{&_load_file($arg)});
	$cnt =~ s/%{2}INCLUDE:([\w\d\.\(\)\&\^\$\\\/;,_-]+)%{2}/&_include_file($1)/ge;

	return $cnt;
}


# read file from disk, not method, not exported
# [I] filename
# [O] reference to array of lines
sub _load_file
{
	my $filename = shift;
	my ($lcnt, @lines);

	unless (-f $filename) {
		&_my_error("template not found: $filename");
	}

	unless (-r $filename) {
		&_my_error("template not readable: $filename");
	}

	$lcnt = 0;
	while (1) {
		if (open(TMPL, '<' . $filename)) {
			@lines = ;
			close(TMPL);
			last;
		} elsif ($lcnt >= $lcnt_max) {
			&_my_error("loop counter ($lcnt_max) exceeded " .
			           "while opening file $filename");
		} else {
			$lcnt++;
			sleep $ssec if ($ssec);
		}
	}

	return \@lines;
}


# die with specified message.
# [I] error_message
# [O] none
sub _my_error
{
	my $msg = shift;
	my @caller;

	@caller = caller(0);

	croak "Parse::Plain $caller[1]:$caller[2] in $caller[3]: $msg";

	return;
}


1;


__END__