File Coverage

blib/lib/Tk/TextHighlight/Perl.pm

Criterion	Covered	Total	%
statement	15	69	21.7
branch	1	8	12.5
condition	0	3	0.0
subroutine	5	12	41.6
pod	6	7	85.7
total	27	99	27.2

package Tk::TextHighlight::Perl;

use vars qw($VERSION);
$VERSION = '0.4';
#use Syntax::Highlight::Perl;
#use base 'Syntax::Highlight::Perl::Improved';
BEGIN
{
	my $havePerlImproved = 0;
	eval 'use base "Syntax::Highlight::Perl::Improved"; $havePerlImproved = 1; 1';
	unless ($havePerlImproved) {
		eval 'use base "Syntax::Highlight::Perl"; 1';
	}
}

use strict;
use Data::Dumper;

sub new {
	my ($proto, $rules) = @_;
	my $class = ref($proto) || $proto;
	my $self = $class->SUPER::new;
	if (not defined($rules)) {
		$rules =  [
			['DEFAULT', -foreground => 'black'],
			['Comment_Normal', -foreground => 'lightblue'],
			['Comment_Pod', -foreground => 'lightblue'],
			['Directive', -foreground => 'brown'],
			['Label', -foreground => 'black'],
			['Quote', -foreground => 'red'],
			['String', -foreground => 'red'],
			['Variable_Scalar', -foreground => 'blue'],
			['Variable_Array', -foreground => 'blue'],
			['Variable_Hash', -foreground => 'blue'],
			['Subroutine', -foreground => 'orange'],
			['Character', -foreground => 'magenta'],
			['Keyword', -foreground => 'brown'],
			['Builtin_Operator', -foreground => 'darkgreen'],
			['Operator', -foreground => 'brown'],
			['Number', -foreground => 'darkblue'],
		];
	};
	$self->{'rules'} = [];
	bless ($self, $class);
	$self->rules($rules);
	$self->unstable(1);
	return $self;
}

sub highlight {
	my $hlt = shift;
	my $txt =  $hlt->format_string(shift);
	my @target = ();
	my @lst = split /\e\e\e/o, $txt; #start to retrieve the color info tags.
	while (@lst) { #set up the insert command options.
		push(@target, length(shift @lst), shift @lst);
	};
	return @target;
}

sub rules {
	my $hlt = shift;
	if (@_) {
		my $r = shift;
		my %format = ();
		foreach my $k (@$r) {
			$format{$k->[0]} = ["", "\e\e\e" . $k->[0] . "\e\e\e"];
		}
		$hlt->set_format(%format);
		$hlt->reset;
		$hlt->{'rules'} = $r;
	}
	return $hlt->{'rules'};
}

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;
	return (
		$hlt->in_heredoc,
		$hlt->in_string,
		$hlt->in_pod,
		$hlt->was_pod,
		$hlt->in_data,
		$hlt->{'quote_instigator'},
		$hlt->{'quote_terminator'},
		$hlt->{'quote_type'},
		$hlt->{'found_multi'},
		$hlt->{'awaiting_multi'},
		$hlt->{'awaiting_variable'},
		$hlt->{'awaiting_class'},
		$hlt->{'last_token'},
		$hlt->{'last_token_type'},
		$hlt->{'reentrant'},
	);
}

sub stateSet {
	my $hlt = shift;
	$hlt->{'in_heredoc'} = shift;
	$hlt->{'in_string'} = shift;
	$hlt->{'in_pod'} = shift;
	$hlt->{'was_pod'} = shift;
	$hlt->{'in_data'} = shift;
	$hlt->{'quote_instigator'} = shift;
	$hlt->{'quote_terminator'} = shift;
	$hlt->{'quote_type'} = shift;
	$hlt->{'found_multi'} = shift;
	$hlt->{'awaiting_multi'} = shift;
	$hlt->{'awaiting_variable'} = shift;
	$hlt->{'awaiting_class'} = shift;
	$hlt->{'last_token'} = shift;
	$hlt->{'last_token_type'} = shift;
	$hlt->{'reentrant'} = shift;
}

sub syntax {
	my $hlt = shift;
	return 'Perl',
}

1;

__END__