File Coverage

blib/lib/Text/FillIn.pm

Criterion	Covered	Total	%
statement	110	163	67.4
branch	27	54	50.0
condition	0	3	0.0
subroutine	21	29	72.4
pod	11	17	64.7
total	169	266	63.5

package Text::FillIn;
use Carp;
use FileHandle;
use strict;
use vars qw($VERSION %DEFAULT);
$VERSION = '0.05';

# Set a bunch of defaults
%DEFAULT = (
	'path' => ['.'],
	'$hook' => 'find_value',
	'&hook' => 'run_function',
	'Ldelim' => '[[',
	'Rdelim' => ']]',
	'text' => '',
	'properties' => {},
	'object' => undef,
);

sub new {
	my $package = shift;
	my $text = shift;

	my $self = {
		%DEFAULT,
		'text' => $text,
	};

	# Copy the special structures so we don't share their memory
	$self->{'properties'} = { %{$self->{'properties'}} };
	$self->{'path'} = [ @{$self->{'path'}} ];

	return bless ($self, $package);
}

sub get_file {
	my $self = shift;
	my $file = shift;

	if ($file eq 'null') {
		$self->{'text'} = '';
		return;
	}

	# Find out what file to open:
	my $realfile;
	if ($file =~ /^\//) {
		$realfile = $file;
	} else {
		foreach my $dir ($self->path()) {
			if ( -f "$dir/$file" ) {
				$realfile = "$dir/$file";
				last;
			}
		}
	}

	unless ($realfile  and  -f $realfile) {
		warn ("Can't find file '$file' in (@{[$self->path()]})");
		return 0;
	}

	my $fh = new FileHandle($realfile);
	unless ( defined $fh ) {
		warn ("Can't open $realfile: $!");
		$self->{'text'} = '';
		return 0;
	}

	$self->{'text'} = join('', $fh->getlines );
	return 1;
}

sub Ldelim { my $s = shift; $s->_prop('Ldelim', @_) }
sub Rdelim { my $s = shift; $s->_prop('Rdelim', @_) }
sub text   { my $s = shift; $s->_prop('text',   @_) }
sub object { my $s = shift; $s->_prop('object', @_) }

sub hook {
	my $self = shift;
	my $char = shift;
	return $self->_prop($char.'hook', @_);
}

sub path {
	my $self = shift;
	return @{ (@_ ? $self->_prop('path', [@_]) : $self->_prop('path')) };
}

sub property {
	my $self = shift;
	my $prop = shift;

	# Which SV we should get or set - this object only, or the default
	my $get_set = (ref $self ? \($self->{'properties'}{$prop}) : \($DEFAULT{'properties'}{$prop}));

	if (@_) {
		# Set the property
		$$get_set = shift;
	}
	return $$get_set;
}


sub interpret {
	my $self = shift;
	$self->_interpret_engine('collect');
}

sub interpret_and_print {
	my $self = shift;
	$self->_interpret_engine('print');
}

# Deprecated - use text()
sub set_text {
	my $self = shift;
	my $text = shift;

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

# Deprecated - use text()
sub get_text {
	my $self = shift;

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

# Deprecated - use property()
sub get_property {
	my $self = shift;
	my $prop_name = shift;

	return $self->{'properties'}->{$prop_name};
}

# Deprecated - use property()
sub set_property {
	my $self = shift;
	my $prop_name = shift;
	my $prop_val = shift;

	$self->{'properties'}->{$prop_name} = $prop_val;
}



############################# Private functions

sub _prop {
	my $self = shift;
	my $prop = shift;

	# Which SV we should get or set - this object only, or the default
	my $get_set = (ref $self ? \($self->{$prop}) : \($DEFAULT{$prop}));

	if (@_) {
		# Set the property
		$$get_set = shift;
	}
	return $$get_set;
}

sub _deal_with {
	my ($text, $style, $outref) = @_;
	if ($style eq 'print') {
		print $text;
	} elsif ($style eq 'collect') {
		${$outref} .= $text;
	}
}

sub _interpret_engine {

	my $self = shift;
	my $style = shift;
	my ($first_right, $first_left, $last_left, $out_text, $save);
	my $debug = 0;
	my $text = $self->{'text'};   # Duplicates memory, I'll clean up later

	my ($ld, $rd) = ($self->Ldelim(), $self->Rdelim());
	warn "Delimiters are $ld and $rd" if $debug;

	while (1) {

		warn ("interpreting '$text'") if $debug;
		# Shave off any leading plain text before the first real [[
		my ($prelength, $pretext);
		$first_left = &_real_index($text, $ld);
		warn ("first left is at $first_left") if $debug;
		if ( $first_left == -1 ) {
			# No more to do, just spit out the text
			$self->_unquote(\$text);
			&_deal_with($text, $style, \$out_text);
			last;

		} elsif ($first_left > 0) { # There's a real [[ here
			$pretext = substr($text, 0, $first_left);
			$self->_unquote(\$pretext);
			&_deal_with($pretext, $style, \$out_text);
			substr($text, 0, $first_left) = '';
			next;
		}

		# There's now a real [[ at position 0.
		# Find the first right delimiter and fill in before it:
		$first_right = &_real_index($text, $rd);
		warn ("first right is at $first_right") if $debug;
		$last_left = &_real_index(substr($text, 0, $first_right), $ld, 1);
		warn ("last left is at $last_left") if $debug;

		if ($first_right == -1) { # Something's amiss, abort
			warn ("Problem interpreting text " . substr($text, 0, $first_right));
			&_deal_with($text, $style, \$out_text);
			last;
		}
		# Fill in the text in between the first right delimiter and the last left delimiter before it:
		substr($text, $last_left, $first_right - $last_left + length($rd)) =
		   $self->_do_interpret(substr($text, $last_left, $first_right - $last_left + length($rd)));
	}
	return $out_text;
}

sub _real_index {
	# Finds the first occurrence of $exp in $text before
	# position $before that doesn't follow a backslash

	my $text = shift;
	my $exp = shift;
	my $last = shift;

	if ($last) {
		if ($text =~ /  (.*)(^|[^\\]) \Q$exp/sx) {
			return(length($1) + length($2));
		} else {
			return -1;
		}
	} else {
		if ($text =~ / (.*?)(^|[^\\]) \Q$exp/sx) {
			return (length($1) + length($2));
		} else {
			return -1;
		}
	}
}

sub _unquote {
	my $self = shift;
	my $textref = shift;

	my ($ldx, $rdx) = map {quotemeta} ($self->Ldelim(), $self->Rdelim());
	${$textref} =~ s/ \\( $ldx | $rdx ) /$1/xgs;
}

sub _do_interpret {
	my $self = shift;
	my $string = shift;

	my ($ldx, $rdx) = map {quotemeta} ($self->Ldelim(), $self->Rdelim());

	unless ($string =~ /^ $ldx \s*  ([\W])  (.*?) \s*  $rdx $/sx ) {
		# Looks like we weren't meant to see this - but we can't interpret it again either
		carp ("Can't interpret template chunk '$string'");
		return;
	}
	my ($char, $guts) = ($1, $2);

	my ($hook, $object);
	if (defined ($hook = $self->hook($char))) {
		no strict('refs');  # Allow symbolic name substitution for a little while
		if (defined ($object = $self->object())) {
			return $object->$hook($guts, $char);
		} else {
			return &{$hook}($guts, $char);
		}
	} else {
		croak ("No interpret hook defined for type '$1'");
	}
}


############################ Sample hook functions ##########################


sub find_value { $main::TVars{ $_[0] } }

sub run_function {
   # Usage: $result = &run_function("some_function(param1,param2,param3)");
	my $text = shift;
   my ($function_name, $args) = $text =~ /(\w+)\((.*)\)/
      or die ("Can't understand function call '$text'");
	no strict('refs');  # Allow symbolic name substitution for a little while
   return &{"TExport::$function_name"}( split(/,/, $args) );
}


1;

__END__