File Coverage

blib/lib/Tk/TextHighlight/Bash.pm

Criterion	Covered	Total	%
statement	12	112	10.7
branch	0	48	0.0
condition	0	3	0.0
subroutine	4	15	26.6
pod	0	11	0.0
total	16	189	8.4

package Tk::TextHighlight::Bash;

use vars qw($VERSION);
$VERSION = '0.1'; # Initial release;

use strict;
use warnings;
use base('Tk::TextHighlight::Template');

my $separators = '\||&|;|(|)|<|>|\s|\'|"|`|#|$';

sub new {
  	my ($proto, $rules) = @_;
  	my $class = ref($proto) || $proto;
	if (not defined($rules)) {
		$rules =  [
			['Text'],
			['Comment', -foreground => 'gray'],
			['Reserved', -foreground => 'brown'],
			['Keyword', -foreground => 'orange'],
			['String', -foreground => 'red'],
			['Backticked', -foreground => 'purple'],
			['String intrapolated', -foreground => 'red'],
			['Escaped character', -foreground => 'magenta'],
			['Operator', -foreground => 'darkblue'],
			['Variable', -foreground => 'blue'],
		];
	};
	my $self = $class->SUPER::new($rules);
	$self->lists({
		'Reserved' => [
			'!', 'case', 'do', 'done', 'elif', 'else', 'esac', 'fi', 'for',
			'function', 'if', 'in', 'select', 'then', 'until', 'while', '{',
			'}', 'time', '[[', ']]',
		],
		'Keyword' => [
			'alias', 'bind', 'bg','builtin', 'break', 'cd', 'command', 'compgen',
			'complete', 'continue', 'cp', 'declare', 'disown', 'dirs', 'echo',
			'enable', 'eval', 'exec', 'exit', 'export', 'false', 'fc', 'fg',
			'function', 'getopts', 'hash', 'help', 'history', 'jobs', 'kill',
			'let', 'local', 'logout', 'mv', 'popd', 'printf', 'pushd','pwd',  'read',
			'readonly', 'return', 'rm', 'select', 'set', 'shift', 'shopt', 'source',
			'suspend', 'test', 'trap', 'true', 'type', 'typeset', 'ulimit',
			'umask', 'unalias', 'unset', 'variables', 'wait',
		],
	});
  	bless ($self, $class);
	$self->callbacks({
		'Backticked' => \&parseBackticked,
		'Comment' => \&parseComment,
		'Escaped character' => \&parseEscaped,
		'Keyword' => \&parseKeyword,
		'Operator' => \&parseOperator,
		'Reserved' => \&parseReserved,
		'String' => \&parseString,
		'String intrapolated' => \&parseIString,
		'Text' => \&parseText,
		'Variable' => \&parseVariable,
	});
	$self->stackPush('Text');
  	return $self;
}

sub parseBackticked {
	my ($self, $text) = @_;
	if ($text =~ s/^(`)//o) { #backtick stop
		$self->snippetParse($1);
		$self->stackPull;
		return $text;
	}
	return $self->parseText($text);
}

sub parseComment {
	my ($self, $text) = @_;
	return $self->parserError($text);
}

sub parseEscaped {
	my ($self, $text) = @_;
	return $self->parserError($text);
}

sub parseIString {
	my ($self, $text) = @_;
	if ($text =~ s/^(\\.)//o) { #escaped character
		$self->snippetParse($1, 'Escaped character');
		return $text;
	}
	if ($text =~ s/^(\$[^$separators]*)//) { #variable
		$self->snippetParse($1, 'Variable');
		return $text;
	}
	if ($text =~ s/^(`)//o) { #backticked
		$self->stackPush('Backticked');
		$self->snippetParse($1);
		return $text;
	}
	if ($text =~ s/^(")//o) { #string stop
		$self->snippetParse($1);
		$self->stackPull;
		return $text;
	}
	if ($text =~ s/^([^"|\$|`]+)//o) { #string content
		$self->snippetParse($1);
		return $text;
	}
	return $self->parserError($text);
}

sub parseKeyword {
	my ($self, $text) = @_;
	return $self->parserError($text);
}

sub parseOperator {
	my ($self, $text) = @_;
	return $self->parserError($text);
}

sub parseReserved {
	my ($self, $text) = @_;
	return $self->parserError($text);
}

sub parseString {
	my ($self, $text) = @_;
	if ($text =~ s/^([^']+)//o) { #string content
		$self->snippetParse($1);
		return $text;
	}
	if ($text =~ s/^(')//o) { #string stop
		$self->snippetParse($1);
		$self->stackPull;
		return $text;
	}
	return $self->parserError($text);
}

sub parseText {
	my ($self, $text) = @_;
	if ($text =~ s/^(^#!\/.*)//o) { #launch line
		$self->snippetParse($1, 'Reserved');
		return $text;
	}
	if ($text =~ s/^(#.*)//o) { #comment
		$self->snippetParse($1, 'Comment');
		return $text;
	}
	if ($text =~ s/^(\s+)//o) { #spaces
		$self->snippetParse($1);
		return $text;
	}
	if ($text =~ s/^(`)//) { #backticked
		$self->stackPush('Backticked');
		$self->snippetParse($1);
		return $text;
	}
	if ($text =~ s/^(")//o) { #string intrapolated
		$self->stackPush('String intrapolated');
		$self->snippetParse($1);
		return $text;
	}
	if ($text =~ s/^('[^']*)//o) { #string start
		$self->snippet($1);
		if ($text) { #if there is still text to be parsed, string ends at same line
			if ($text =~ s/(^')//o) {
				$self->snippetParse($1)
			}
		} else {
			$self->stackPush('String');
		}
		return $text;
	}
	if ($text =~ s/^(\$[^$separators]*)//) { #variable
		$self->snippetParse($1, 'Variable');
		return $text;
	}
	if ($text =~ s/^([\|\||\||&&|&|;;|;|(|)])//o) { #operator
		$self->snippetParse($1, 'Operator');
		return $text
	}
	if ($text =~ s/^([<|>])//o) { #remaining separators
		$self->snippetParse($1);
		return $text
	}
	if ($text =~ s/^(\\.)//o) { #escaped character
		$self->snippet($1, 'Escaped character');
		return $text;
	}
	if ($text =~ s/^([^$separators]+)//) {	#fetching a bare part
		if ($self->tokenTest($1, 'Reserved')) {
			$self->snippetParse($1, 'Reserved');
		} elsif ($self->tokenTest($1, 'Keyword')) {
			$self->snippetParse($1, 'Keyword');
		} else { #unrecognized text
			$self->snippetParse($1);
		}
		return $text
	}
	#It shouldn't have come this far, but it has.
	return $self->parserError($text);
}

sub parseVariable {
	my ($self, $text) = @_;
	return $self->parserError($text);
}

1;

__END__