File Coverage

blib/lib/Syntax/Highlight/Engine/Kate/Template.pm

Criterion	Covered	Total	%
statement	528	578	91.3
branch	192	234	82.0
condition	15	18	83.3
subroutine	73	73	100.0
pod	57	63	90.4
total	865	966	89.5

# Copyright (c) 2006 Hans Jeuken. All rights reserved.
# This program is free software; you can redistribute it and/or
# modify it under the same terms as Perl itself.

package Syntax::Highlight::Engine::Kate::Template;

our $VERSION = '0.12';

use strict;
use Carp qw(cluck);
use Data::Dumper;

#my $regchars = '\\^.$|()[]*+?';

sub new {
	my $proto = shift;
	my $class = ref($proto) || $proto;
	my %args = (@_);

	my $debug = delete $args{'debug'};
	unless (defined($debug)) { $debug = 0 };
	my $substitutions = delete $args{'substitutions'};
	unless (defined($substitutions)) { $substitutions = {} };
	my $formattable = delete $args{'format_table'};
	unless (defined($formattable)) { $formattable = {} };
	my $engine = delete $args{'engine'};

	my $self = {};
	$self->{'attributes'} = {},
	$self->{'captured'} = [];
	$self->{'contextdata'} = {};
	$self->{'basecontext'} = '';
	$self->{'debug'} = $debug;
	$self->{'deliminators'} = '';
	$self->{'engine'} = '';
	$self->{'format_table'} = $formattable;
	$self->{'keywordcase'} = 1;
	$self->{'lastchar'} = '';
	$self->{'linesegment'} = '';
	$self->{'lists'} = {};
	$self->{'linestart'} = 1;
	$self->{'out'} = [];
	$self->{'plugins'} = {};
	$self->{'snippet'} = '';
	$self->{'snippetattribute'} = '';
	$self->{'stack'} = [];
	$self->{'substitutions'} = $substitutions;
	bless ($self, $class);
	unless (defined $engine) { $engine = $self };
	$self->engine($engine);
	$self->initialize;
	return $self;
}

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

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

sub captured {
	my ($self, $c) = @_;
	if (defined($c)) {
		my $t = $self->engine->stackTop;
		my $n = 0;
		my @o = ();
		while (defined($c->[$n])) {
			push @o, $c->[$n];
			$n ++;
		}
		if (@o) {
			$t->[2] = \@o;
		}
	};
}

sub capturedGet {
	my ($self, $num) = @_;
	my $s = $self->engine->stack;
	if (defined($s->[1])) {
		my $c = $s->[1]->[2];
		$num --;
		if (defined($c)) {
			if (defined($c->[$num])) {
				my $r = $c->[$num];
				return $r;
			} else {
				warn "capture number $num not defined";
			}
		} else {
			warn "dynamic substitution is called for but nothing to substitute\n";
			return undef;
		}
	} else {
		warn "no parent context to take captures from";
	}
}

#sub captured {
#	my $self = shift;
#	if (@_) {
#		$self->{'captured'} = shift;
##		print Dumper($self->{'captured'});
#	};
#	return $self->{'captured'}
##	my ($self, $c) = @_;
##	if (defined($c)) {
##		my $t = $self->engine->stackTop;
##		my $n = 0;
##		my @o = ();
##		while (defined($c->[$n])) {
##			push @o, $c->[$n];
##			$n ++;
##		}
##		if (@o) {
##			$t->[2] = \@o;
##		}
##	};
#}
#
#sub capturedGet {
#	my ($self, $num) = @_;
#	my $s = $self->captured;
#	if (defined $s) {
#		$num --;
#		if (defined($s->[$num])) {
#			return $s->[$num];
#		} else {
#			$self->logwarning("capture number $num not defined");
#		}
#	} else {
#		$self->logwarning("dynamic substitution is called for but nothing to substitute");
#		return undef;
#	}
#}

sub capturedParse {
	my ($self, $string, $mode) = @_;
	my $s = '';
	if (defined($mode)) {
		if ($string =~ s/^(\d)//) {
			$s = $self->capturedGet($1);
			if ($string ne '') {
				$self->logwarning("character class is longer then 1 character, ignoring the rest");
			}
		}
	} else {
		while ($string ne '') {
			if ($string =~ s/^([^\%]*)\%(\d)//) {
				my $r = $self->capturedGet($2);
				if ($r ne '') {
					$s = $s . $1 . $r
				} else {
					$s = $s . $1 . '%' . $2;
					$self->logwarning("target is an empty string");
				}
			} else {
				$string =~ s/^(.)//;
				$s = "$s$1";
			}
		}
	}
	return $s;
}

sub column {
	my $self = shift;
	return length($self->linesegment);
}

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

sub contextInfo {
	my ($self, $context, $item) = @_;
	if  (exists $self->contextdata->{$context}) {
		my $c = $self->contextdata->{$context};
		if (exists $c->{$item}) {
			return $c->{$item}
		} else {
			return undef;
		}
	} else {
		$self->logwarning("undefined context '$context'");
		return undef;
	}
}

sub contextParse {
	my ($self, $plug, $context) = @_;
	if ($context =~ /^#pop/i) {
		while ($context =~ s/#pop//i) {
			$self->stackPull;
		}
	} elsif ($context =~ /^#stay/i) {
		#don't do anything
	} elsif ($context =~ /^##(.+)/) {
		my $new = $self->pluginGet($1);
		$self->stackPush([$new, $new->basecontext]);
	} else {
		$self->stackPush([$plug, $context]);
	}
}

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

sub debugTest {
	my $self = shift;
	if (@_) { $self->{'debugtest'} = shift; };
	return $self->{'debugtest'};
}

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

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


sub firstnonspace {
	my ($self, $string) = @_;
	my $line = $self->linesegment;
	if (($line =~ /^\s*$/) and ($string =~ /^[^\s]/)) {
		return 1
	}
	return ''
}

sub formatTable {
	my $self = shift;
	if (@_) { $self->{'format_table'} = shift; };
	return $self->{'format_table'};
}

sub highlight {
	my ($self, $text) = @_;
	$self->snippet('');
	my $out = $self->out;
	@$out = ();
	while ($text ne '') {
		my $top = $self->stackTop;
		if (defined($top)) {
			my ($plug, $context) = @$top;
			if ($text =~ s/^(\n)//) {
				$self->snippetForce;
				my $e = $plug->contextInfo($context, 'lineending');
				if (defined($e)) {
					$self->contextParse($plug, $e)
				}
				my $attr = $plug->attributes->{$plug->contextInfo($context, 'attribute')};
				$self->snippetParse($1, $attr);
				$self->snippetForce;
				$self->linesegment('');
				my $b = $plug->contextInfo($context, 'linebeginning');
				if (defined($b)) {
					$self->contextParse($plug, $b)
				}
			} else {
				my $sub = $plug->contextInfo($context, 'callback');
				my $result = &$sub($plug, \$text);
				unless($result) {
					my $f = $plug->contextInfo($context, 'fallthrough');
					if (defined($f)) {
						$self->contextParse($plug, $f);
					} else {
						$text =~ s/^(.)//;
						my $attr = $plug->attributes->{$plug->contextInfo($context, 'attribute')};
						$self->snippetParse($1, $attr);
					}
				}
			}
		} else {
			push @$out, length($text), 'Normal';
			$text = '';
		}
	}
	$self->snippetForce;
	return @$out;
}

sub highlightText {
	my ($self, $text) = @_;
	my $res = '';
	my @hl = $self->highlight($text);
	while (@hl) {
		my $f = shift @hl;
		my $t = shift @hl;
		unless (defined($t)) { $t = 'Normal' }
		my $s = $self->substitutions;
		my $rr = '';
		while ($f ne '') {
			my $k = substr($f , 0, 1);
			$f = substr($f, 1, length($f) -1);
			if (exists $s->{$k}) {
				 $rr = $rr . $s->{$k}
			} else {
				$rr = $rr . $k;
			}
		}
		my $rt = $self->formatTable;
		if (exists $rt->{$t}) {
			my $o = $rt->{$t};
			$res = $res . $o->[0] . $rr . $o->[1];
		} else {
			$res = $res . $rr;
			$self->logwarning("undefined format tag '$t'");
		}
	}
	return $res;
}

sub includePlugin {
	my ($self, $language, $text) = @_;
	my $eng = $self->engine;
	my $plug = $eng->pluginGet($language);
	if (defined($plug)) {
		my $context = $plug->basecontext;
		my $call = $plug->contextInfo($context, 'callback');
		if (defined($call)) {
			return &$call($plug, $text);
		} else {
			$self->logwarning("cannot find callback for context '$context'");
		}
	}
	return 0;
}

sub includeRules {
	my ($self, $context, $text) = @_;
	my $call = $self->contextInfo($context, 'callback');
	if (defined($call)) {
		return &$call($self, $text);
	} else {
		$self->logwarning("cannot find callback for context '$context'");
	}
	return 0;
}

sub initialize {
	my $self = shift;
	if ($self->engine eq $self) {
		$self->stack([[$self, $self->basecontext]]);
	}
}

sub keywordscase {
	my $self = shift;
	if (@_) { $self->{'keywordcase'} = shift; }
	return $self->{'keywordscase'}
}

sub languagePlug {
	my ($cw, $name) = @_;
	my %numb = (
		'1' => 'One',
		'2' => 'Two',
		'3' => 'Three',
		'4' => 'Four',
		'5' => 'Five',
		'6' => 'Six',
		'7' => 'Seven',
		'8' => 'Eight',
		'9' => 'Nine',
		'0' => 'Zero',
	);
	if ($name =~ s/^(\d)//) {
		$name = $numb{$1} . $name;
	}
	$name =~ s/\.//;
	$name =~ s/\+/plus/g;
	$name =~ s/\-/minus/g;
	$name =~ s/#/dash/g;
	$name =~ s/[^0-9a-zA-Z]/_/g;
	$name =~ s/__/_/g;
	$name =~ s/_$//;
	$name = ucfirst($name);
	return $name;
}

sub lastchar {
	my $self = shift;
	my $l = $self->linesegment;
	if ($l eq '') { return "\n" } #last character was a newline
	return substr($l, length($l) - 1, 1);
}

sub lastcharDeliminator {
	my $self = shift;
	my $deliminators = '\s|\~|\!|\%|\^|\&|\*|\+|\(|\)|-|=|\{|\}|\[|\]|:|;|<|>|,|\\|\||\.|\?|\/';
	if ($self->linestart or ($self->lastchar =~ /$deliminators/))  {
		return 1;
	}
	return '';
}

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

sub linestart {
	my $self = shift;
	if ($self->linesegment eq '') {
		return 1
	}
	return '';
}

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

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

sub listAdd {
	my $self = shift;
	my $listname = shift;
	my $lst = $self->lists;
	if (@_) {
		my @l = reverse sort @_;
		$lst->{$listname} = \@l;
	} else {
		$lst->{$listname} = [];
	}
}

sub logwarning {
	my ($self, $warning) = @_;
	my $top = $self->engine->stackTop;
	if (defined $top) {
		my $lang = $top->[0]->language;
		my $context = $top->[1];
		$warning = "$warning\n  Language => $lang, Context => $context\n";
	} else {
		$warning = "$warning\n  STACK IS EMPTY: PANIC\n"
	}
	cluck($warning);
}

sub parseResult {
	my ($self, $text, $string, $lahead, $column, $fnspace, $context, $attr) = @_;
	my $eng = $self->engine;
	if ($fnspace) {
		unless ($eng->firstnonspace($$text)) {
			return ''
		}
	}
	if (defined($column)) {
		if ($column ne $eng->column) {
			return '';
		}
	}
	unless ($lahead) {
		$$text = substr($$text, length($string));
		my $r;
		unless (defined($attr)) {
			my $t = $eng->stackTop;
			my ($plug, $ctext) = @$t;
			$r = $plug->attributes->{$plug->contextInfo($ctext, 'attribute')};
		} else {
			$r = $self->attributes->{$attr};
		}
		$eng->snippetParse($string, $r);
	}
	$eng->contextParse($self, $context);
	return 1
}

sub pluginGet {
	my ($self, $language) = @_;
	my $plugs = $self->{'plugins'};
	unless (exists($plugs->{$language})) {
                my $lang_plug = $self->languagePlug($language);
		my $modname = 'Syntax::Highlight::Engine::Kate::';
                if (defined $lang_plug) {
	               $modname .= $lang_plug;
                }
		unless (defined($modname)) {
			$self->logwarning("no valid module found for language '$language'");
			return undef;
		}
		my $plug;
		eval "use $modname; \$plug = new $modname(engine => \$self);";
		if (defined($plug)) {
			$plugs->{$language} = $plug;
		} else {
			$self->logwarning("cannot create plugin for language '$language'\n--------------\n$@");
		}
	}
	if (exists($plugs->{$language})) {
		return $plugs->{$language};
	}
	return undef;
}

sub reset {
	my $self = shift;
	$self->stack([[$self, $self->basecontext]]);
	$self->out([]);
	$self->snippet('');
}

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

sub snippetAppend {
	my ($self, $ch) = @_;

	return if not defined $ch;
	$self->{'snippet'} = $self->{'snippet'} . $ch;
	if ($ch ne '') {
		$self->linesegment($self->linesegment . $ch);
	}
	return;
}

sub snippetAttribute {
	my $self = shift;
	if (@_) { $self->{'snippetattribute'} = shift; }
	return $self->{'snippetattribute'};
}

sub snippetForce {
	my $self = shift;
	my $parse = $self->snippet;
	if ($parse ne '') {
		my $out = $self->{'out'};
		push(@$out, $parse, $self->snippetAttribute);
		$self->snippet('');
	}
}

sub snippetParse {
	my $self = shift;
	my $snip = shift;
	my $attr = shift;
	if ((defined $attr) and ($attr ne $self->snippetAttribute)) {
		$self->snippetForce;
		$self->snippetAttribute($attr);
	}
	$self->snippetAppend($snip);
}

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

sub stackPush {
	my ($self, $val) = @_;
	my $stack = $self->stack;
	unshift(@$stack, $val);
}

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

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

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

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

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

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

sub testAnyChar {
	my $self = shift;
	my $text = shift;
	my $string = shift;
	my $insensitive = shift;
	my $test = substr($$text, 0, 1);
	my $bck = $test;
	if ($insensitive) {
		$string = lc($string);
		$test = lc($test);
	}
	if (index($string, $test) > -1) {
		return $self->parseResult($text, $bck, @_);
	}
	return ''
}

sub testDetectChar {
	my $self = shift;
	my $text = shift;
	my $char = shift;
	my $insensitive = shift;
	my $dyn = shift;
	if ($dyn) {
		$char = $self->capturedParse($char, 1);
	}
	my $test = substr($$text, 0, 1);
	my $bck = $test;
	if ($insensitive) {
		$char = lc($char);
		$test = lc($test);
	}
	if ($char eq $test) {
		return $self->parseResult($text, $bck, @_);
	}
	return ''
}

sub testDetect2Chars {
	my $self = shift;
	my $text = shift;
	my $char = shift;
	my $char1 = shift;
	my $insensitive = shift;
	my $dyn = shift;
	if ($dyn) {
		$char = $self->capturedParse($char, 1);
		$char1 = $self->capturedParse($char1, 1);
	}
	my $string = $char . $char1;
	my $test = substr($$text, 0, 2);
	my $bck = $test;
	if ($insensitive) {
		$string = lc($string);
		$test = lc($test);
	}
	if ($string eq $test) {
		return $self->parseResult($text, $bck, @_);
	}
	return ''
}

sub testDetectIdentifier {
	my $self = shift;
	my $text = shift;
	if ($$text =~ /^([a-zA-Z_][a-zA-Z0-9_]+)/) {
		return $self->parseResult($text, $1, @_);
	}
	return ''
}

sub testDetectSpaces {
	my $self = shift;
	my $text = shift;
	if ($$text =~ /^([\\040|\\t]+)/) {
		return $self->parseResult($text, $1, @_);
	}
	return ''
}

sub testFloat {
	my $self = shift;
	my $text = shift;
	if ($self->engine->lastcharDeliminator) {
		if ($$text =~ /^((?=\.?\d)\d*(?:\.\d*)?(?:[Ee][+-]?\d+)?)/) {
			return $self->parseResult($text, $1, @_);
		}
	}
	return ''
}

sub testHlCChar {
	my $self = shift;
	my $text = shift;
	if ($$text =~ /^('.')/) {
		return $self->parseResult($text, $1, @_);
	}
	return ''
}

sub testHlCHex {
	my $self = shift;
	my $text = shift;
	if ($self->engine->lastcharDeliminator) {
		if ($$text =~ /^(0x[0-9a-fA-F]+)/) {
			return $self->parseResult($text, $1, @_);
		}
	}
	return ''
}

sub testHlCOct {
	my $self = shift;
	my $text = shift;
	if ($self->engine->lastcharDeliminator) {
		if ($$text =~ /^(0[0-7]+)/) {
			return $self->parseResult($text, $1, @_);
		}
	}
	return ''
}

sub testHlCStringChar {
	my $self = shift;
	my $text = shift;
	if ($$text =~ /^(\\[a|b|e|f|n|r|t|v|'|"|\?])/) {
		return $self->parseResult($text, $1, @_);
	}
	if ($$text =~ /^(\\x[0-9a-fA-F][0-9a-fA-F]?)/) {
		return $self->parseResult($text, $1, @_);
	}
	if ($$text =~ /^(\\[0-7][0-7]?[0-7]?)/) {
		return $self->parseResult($text, $1, @_);
	}
	return ''
}

sub testInt {
	my $self = shift;
	my $text = shift;
	if ($self->engine->lastcharDeliminator) {
		if ($$text =~ /^([+-]?\d+)/) {
			return $self->parseResult($text, $1, @_);
		}
	}
	return ''
}

sub testKeyword {
	my $self = shift;
	my $text = shift;
	my $list = shift;
	my $eng = $self->engine;
	my $deliminators = $self->deliminators;
	if (($eng->lastcharDeliminator)  and ($$text =~ /^([^$deliminators]+)/)) {
		my $match = $1;
		my $l = $self->lists->{$list};
		if (defined($l)) {
			my @list = @$l;
			my @rl = ();
			unless ($self->keywordscase) {
				@rl = grep { (lc($match) eq lc($_)) } @list;
			} else {
				@rl = grep { ($match eq $_) } @list;
			}
			if (@rl) {
				return $self->parseResult($text, $match, @_);
			}
		} else {
			$self->logwarning("list '$list' is not defined, failing test");
		}
	}
	return ''
}

sub testLineContinue {
	my $self = shift;
	my $text = shift;
	my $lahead = shift;
	if ($lahead) {
		if ($$text =~ /^\\\n/) {
			$self->parseResult($text, "\\", $lahead, @_);
			return 1;
		}
	} else {
		if ($$text =~ s/^(\\)(\n)/$2/) {
			return $self->parseResult($text, "\\", $lahead, @_);
		}
	}
	return ''
}

sub testRangeDetect {
	my $self = shift;
	my $text = shift;
	my $char = shift;
	my $char1 = shift;
	my $insensitive = shift;
	my $string = "$char\[^$char1\]+$char1";
	return $self->testRegExpr($text, $string, $insensitive, 0, @_);
}

sub testRegExpr {
	my $self = shift;
	my $text = shift;
	my $reg = shift;
	my $insensitive = shift;
	my $dynamic = shift;
	if ($dynamic) {
		$reg = $self->capturedParse($reg);
	}
	my $eng = $self->engine;
	if ($reg =~ s/^\^//) {
		unless ($eng->linestart) {
			return '';
		}
	} elsif ($reg =~ s/^\\(b)//i) {
		my $lastchar = $self->engine->lastchar;
		if ($1 eq 'b') {
			if ($lastchar =~ /\w/) { return '' }
		} else {
			if ($lastchar =~ /\W/) { return '' }
		}
	}
#	$reg = "^($reg)";
	$reg = "^$reg";
	my $pos;
#	my @cap = ();
	my $sample = $$text;

	# emergency measurements to avoid exception (szabgab)
	$reg = eval { qr/$reg/ };
	if ($@) {
		warn $@;
		return '';
	}
	if ($insensitive) {
		if ($sample =~ /$reg/ig) {
			$pos = pos($sample);
#			@cap = ($1, $2, $3, $4, $5, $6, $7, $8, $9);
#			my @cap = ();
			if ($#-) {
				no strict 'refs';
				my @cap = map {$$_} 1 .. $#-;
				$self->captured(\@cap)
			}
#			my $r  = 1;
#			my $c  = 1;
#			my @cap = ();
#			while ($r) {
#				eval "if (defined\$$c) { push \@cap, \$$c } else { \$r = 0 }";
#				$c ++;
#			}
#			if (@cap) { $self->captured(\@cap) };
		}
	} else {
		if ($sample =~ /$reg/g) {
			$pos = pos($sample);
#			@cap = ($1, $2, $3, $4, $5, $6, $7, $8, $9);
#			my @cap = ();
			if ($#-) {
				no strict 'refs';
				my @cap = map {$$_} 1 .. $#-;
				$self->captured(\@cap);
			}
#			my $r  = 1;
#			my $c  = 1;
#			my @cap = ();
#			while ($r) {
#				eval "if (defined\$$c) { push \@cap, \$$c } else { \$r = 0 }";
#				$c ++;
#			}
#			if (@cap) { $self->captured(\@cap) };
		}
	}
	if (defined($pos) and ($pos > 0)) {
		my $string = substr($$text, 0, $pos);
		return $self->parseResult($text, $string, @_);
	}
	return ''
}

sub testStringDetect {
	my $self = shift;
	my $text = shift;
	my $string = shift;
	my $insensitive = shift;
	my $dynamic = shift;
	if ($dynamic) {
		$string = $self->capturedParse($string);
	}
	my $test = substr($$text, 0, length($string));
	my $bck = $test;
	if ($insensitive) {
		$string = lc($string);
		$test = lc($test);
	}
	if ($string eq $test) {
		return $self->parseResult($text, $bck, @_);
	}
	return ''
}


1;

__END__