File Coverage

blib/lib/Tk/CodeText/Template.pm

Criterion	Covered	Total	%
statement	9	118	7.6
branch	0	26	0.0
condition	0	3	0.0
subroutine	3	24	12.5
pod	18	21	85.7
total	30	192	15.6

package Tk::CodeText::Template;

use vars qw($VERSION);
$VERSION = '0.3';

use strict;
use Data::Dumper;

sub new {
	my ($proto, $rules) = @_;
	my $class = ref($proto) || $proto;
	if (not defined($rules)) {
		$rules =  [];
	};
	my $self = {};
	$self->{'lists'} = {};
	$self->{'out'} = [];
	$self->{'rules'} = $rules,
	$self->{'stack'} = [];
	$self->{'snippet'} = '';
	$self->{'callbacks'} = {};
	$self->{'oneliners'} = [],
	bless ($self, $class);
	return $self;
}

sub callbacks {
	my $hlt = shift;
	if (@_) { $hlt->{'callbacks'} = shift; };
	return $hlt->{'callbacks'};
}

sub highlight {
	my ($hlt, $text) = @_;
	$hlt->snippetParse;
	my $out = $hlt->out;
	@$out = ();
	while ($text) {
#		print "highlighting '$text'\n";
#		print "mode is", $hlt->stackTop, "\n";
		my $sub = $hlt->callbacks->{$hlt->stackTop};
		$text = &$sub($hlt, $text);
	}
	$hlt->snippetParse;
	return @$out;
}

sub lists {
	my $hlt = shift;
	if (@_) { $hlt->{'lists'} = shift; };
	return $hlt->{'lists'};
}

sub listAdd {
	my $hlt = shift;
	my $listname = shift;
#	print "listname $listname\n";
	my $lst = $hlt->lists;
	if (@_) {
		$lst->{$listname} = [@_];
	} else {
		$lst->{$listname} = [];
	}
	my $r = $hlt->lists->{$listname};
#	print "added tokens\n"; foreach my $f (@$r) { print "   $f\n"; };
}

sub rules {
	my $hlt = shift;
	if (@_) { $hlt->{'rules'} = shift;	}
	return $hlt->{'rules'};
}

sub out {
	my $hlt = shift;
	if (@_) { $hlt->{'out'} = shift; }
	return $hlt->{'out'};
}

sub parserError {
	my ($hlt, $text) = @_;
	my $s = $hlt->stack;
	if (@$s eq 1) { #we cannot dump this mode because it's the lowest.
		warn "Parser error\n\tmode: '" . $hlt->stackTop . "'\n" .
			"text: '$text'\nparsing  as plain text";
		$hlt->snippetParse($text);
		$text =''; #Let's call it a day;
	} else {
		warn "Parser error\n\tmode: '" . $hlt->stackTop . "'\n" .
			"text: '$text'\nexiting mode";
		$hlt->stackPull;
	};
	return $text;
}

sub snippet {
	my $hlt = shift;
	if (@_) { $hlt->{'snippet'} = shift; }
	return $hlt->{'snippet'};
}

sub snippetAppend {
	my ($hlt, $ch) = @_;
	$hlt->{'snippet'} = $hlt->{'snippet'} . $ch;
}

sub snippetParse {
	my $hlt = shift;
	my $snip = shift;
	my $attr = shift;
	unless (defined($snip)) { $snip = $hlt->snippet }
	unless (defined($attr)) { $attr = $hlt->stackTop }
	my $out = $hlt->{'out'};
#	print "parsing '$snip' with attribute '$attr'\n";
	if ($snip) {
		push(@$out, length($snip), $attr);
		$hlt->snippet('');
	}
}

sub stack {
	my $hlt = shift;
	return $hlt->{'stack'};
}

sub stackPush {
	my ($hlt, $val) = @_;
#	print "pushing $val\n";
	my $stack = $hlt->stack;
	unshift(@$stack, $val);
}

sub stackPull {
	my ($hlt, $val) = @_;
	my $stack = $hlt->stack;
	return shift(@$stack);
}

sub stackTop {
	my $hlt = shift;
	return $hlt->stack->[0];
}

sub stateCompare {
	my ($hlt, $state) = @_;
	my $h = [ $hlt->stateGet ];
	my $equal = 1;
	if (Dumper($h) ne Dumper($state)) { $equal = 0 };
	return $equal;
}

sub stateGet {
	my $hlt = shift;
	my $s = $hlt->stack;
	return @$s;
}

sub stateSet {
	my $hlt = shift;
	my $s = $hlt->stack;
	@$s = (@_);
}

sub syntax {
	my $hlt = shift;
	my $class = ref $hlt;
	$class =~ /Tk::CodeText::(.*)/;
	return $1;
}

sub tokenParse {
	my $hlt = shift;
	my $tkn = shift;
	$hlt->stackPush($tkn);
	$hlt->snippetParse(@_);
	$hlt->stackPull;
}

sub tokenTest {
	my ($hlt, $test, $list) = @_;
#	print "tokenTest $test\n";
	my $l = $hlt->lists->{$list};
	my @list = reverse sort @$l;
#	return grep { ($test =~ /^$_/)  } @$l;
	my @rl = grep { (substr($test, 0, length($_)) eq $_)  } @list;
#	foreach my $r (@rl) { print "$r\n" }
	if (@rl) {
		return $rl[0]
	} else {
		return undef;
	}
}
1;

__END__