samples/PerlCool.test - metacpan.org

package Tk::TextHighlight;

use vars qw($VERSION);
$VERSION = '0.3.2_pre_2';
use base qw(Tk::Derived Tk::TextUndo);
use strict;
use Storable;
use File::Basename;

Construct Tk::Widget 'TextHighlight';

sub Populate {
	my ($cw,$args) = @_;
	$cw->SUPER::Populate($args);
	$cw->ConfigSpecs(
		-autoindent => [qw/PASSIVE autoindent Autoindent/, 0],
		-match => [qw/PASSIVE match Match/, '[]{}()'],
		-matchoptions	=> [qw/METHOD matchoptions Matchoptions/, 
			[-background => 'red', -foreground => 'yellow']],
		-indentchar => [qw/PASSIVE indentchar Indentchar/, "\t"],
		-disablemenu => [qw/PASSIVE disablemenu Disablemenu/, 0],
		-commentchar => [qw/PASSIVE commentchar Commentchar/, "#"],
		-colorinf => [qw/PASSIVE undef undef/, []],
		-colored => [qw/PASSIVE undef undef/, 0],
		-syntax	=> [qw/PASSIVE syntax Syntax/, 'None'],
		-rules	=> [qw/PASSIVE undef undef/, undef],
		-rulesdir	=> [qw/PASSIVE rulesdir Rulesdir/, ''],
		-updatecall	=> [qw/PASSIVE undef undef/, sub {}],
		DEFAULT => [ 'SELF' ],
	);
	$cw->bind('<Configure>', sub { $cw->highlightVisual });
	$cw->bind('<Return>', sub { $cw->doAutoIndent });
	$cw->markSet('match', '0.0');
}

sub clipboardCopy {
	my $cw = shift;
	my @ranges = $cw->tagRanges('sel');
	if (@ranges) {
		$cw->SUPER::clipboardCopy(@_);
	}
}

sub clipboardCut {
	my $cw = shift;
	my @ranges = $cw->tagRanges('sel');
	if (@ranges) {
		$cw->SUPER::clipboardCut(@_);
	}
}

sub clipboardPaste {
	my $cw = shift;
	my @ranges = $cw->tagRanges('sel');
	if (@ranges) {
		$cw->tagRemove('sel', '1.0', 'end');
		return;
	}
	$cw->SUPER::clipboardPaste(@_);
}

sub delete {
	my $cw = shift;
	my $begin = $_[0];
	if (defined($begin)) {
		$begin = $cw->linenumber($begin);
	} else { 
		$begin = $cw->linenumber('insert');
	};
	my $end = $_[1];
	if (defined($end)) {
		$end = $cw->linenumber($end);
	} else { 
		$end = $begin;
	};
	$cw->SUPER::delete(@_);
	$cw->highlightCheck($begin, $end);
}

sub doAutoIndent {
	my $cw = shift;
	if ($cw->cget('-autoindent')) {
		my $i = $cw->index('insert linestart');
		if ($cw->compare($i, ">", '0.0')) {
			my $s = $cw->get("$i - 1 lines", "$i - 1 lines lineend");
			$s =~ /^(\s+)/;
			if ($1) {
				$cw->insert('insert', $1);
			}
		}
	}
}

sub EditMenuItems {
	my $cw = shift;
	return [
		@{$cw->SUPER::EditMenuItems},
		"-",
		["command"=>'Comment', -command => [$cw => 'selectionComment']],
		["command"=>'Uncomment', -command => [$cw => 'selectionUnComment']],
		"-",
		["command"=>'Indent', -command => [$cw => 'selectionIndent']],
		["command"=>'Unindent', -command => [$cw => 'selectionUnIndent']],
	];
}

sub EmptyDocument {
	my $cw = shift;
	my @r = $cw->SUPER::EmptyDocument(@_);
	$cw->highlightPurge(1);
	return @r
}

sub highlight {
	my ($cw, $begin, $end) = @_;
	if (not defined($end)) { $end = $begin + 1};
	#save selection and cursor position
	my @sel = $cw->tagRanges('sel');
#	my $cursor = $cw->index('insert'); 
	#go over the source code line by line.
	while ($begin < $end) {
		$cw->highlightLine($begin);
		$begin++; #move on to next line.
	};
	#restore original cursor and selection
#	$cw->markSet('insert', $cursor);
	if ($sel[0]) {
		$cw->tagRaise('sel');
	};
	return $begin;
}

sub highlightCheck {
	my ($cw, $begin, $end) = @_;
	my $col = $cw->cget('-colored');
	my $cli = $cw->cget('-colorinf');
	if ($begin <= $col) {
		#The operation occurred in an area that was highlighted already
		if ($begin < $end) {
			#it was a multiline operation, so highlighting is not reliable anymore
			#restart hightlighting from the beginning of the operation.
			$cw->highlightPurge($begin);
		} else {
			#just re-highlight the modified line.
			my $hlt = $cw->highlightPlug;
			my $i = $cli->[$begin];
			$cw->highlight($begin);
			if (($col < $cw->linenumber('end')) and (not $hlt->stateCompare($i))) {
			#the proces ended inside a multiline token. try to fix it.
				$cw->highlightPurge($begin);
			}
		};
		$cw->matchCheck;
	} else {
		$cw->highlightVisual;
	}
}

sub highlightLine {
	my ($cw, $num) = @_;
	my $hlt = $cw->highlightPlug;
	my $cli = $cw->cget('-colorinf');
	my $k = $cli->[$num - 1];
	$hlt->stateSet(@$k);
#	remove all existing tags in this line
	my $begin = "$num.0"; my $end = $cw->index("$num.0 lineend");
	my $rl = $hlt->rules;
	foreach my $tn (@$rl) {
		$cw->tagRemove($tn->[0], $begin, $end);
	}	
	my $txt = $cw->get($begin, $end); #get the text to be highlighted
	if ($txt) { #if the line is not empty
		my $pos = 0;
		my $start = 0;
		my @h = $hlt->highlight($txt);
		while (@h ne 0) {
			$start = $pos;
			$pos += shift @h;
			my $tag = shift@h;
			$cw->tagAdd($tag, "$num.$start", "$num.$pos");
		};
	};
	$cli->[$num] = [ $hlt->stateGet ];
}

sub highlightPlug {
	my $cw = shift;
	my $plug = $cw->Subwidget('formatter');
	my $syntax = $cw->cget('-syntax');
	my $rules = $cw->cget('-rules');
	if (not defined($plug)) {
		$plug = $cw->highlightPlugInit;
	} elsif (ref($syntax)) {
		if ($syntax ne $plug) {
			$plug = $cw->highlightPlugInit;
		}
	} elsif ($syntax ne $plug->syntax) {
		$cw->rulesDelete;
		$plug = $cw->highlightPlugInit;
		$cw->highlightPurge(1);
	} elsif (defined($rules)) {
		if ($rules ne $plug->rules) {
			$cw->rulesDelete;
			$plug->rules($rules);
			$cw->rulesConfigure;
			$cw->highlightPurge(1);
		}
	};
	return $plug
}

sub highlightPlugInit {
	my $cw = shift;
	my $syntax = $cw->cget('-syntax');
	if (not defined($cw->cget('-rules'))) { $cw->rulesFetch };
	my $plug;
	if (ref($syntax)) {
		$plug = $syntax;
	} else {
		my @opt = ();
		if (my $rules = $cw->cget('-rules')) {
			push(@opt, $rules);
		}
		eval ("require Tk::TextHighlight::$syntax; \$plug = new Tk::TextHighlight::$syntax(\@opt);");
	}
	$cw->Advertise('formatter', $plug);
	$cw->rulesConfigure;
	return $plug;
}

sub highlightPlugList {
	my $cw = shift;
	my @ml = ();
	foreach my $d (@INC) {
		my @fl = <$d/Tk/TextHighlight/*.pm>;
		foreach my $file (@fl) {
			my ($name, $path, $suffix) = fileparse($file, "\.pm");
			if (($name ne 'None') and ($name ne 'Template')) {
				#avoid duplicates
				unless (grep { ($name eq $_) } @ml) { push(@ml, $name); };
			}
		}
	}
	return sort @ml;
}

sub highlightPurge {
	my ($cw, $line) = @_;
#	print "purging from $line\n";
	$cw->configure('-colored' => $line);
	my $cli = $cw->cget('-colorinf');
	if (@$cli) { splice(@$cli, $line) };
	$cw->highlightVisual;
}

sub highlightVisual {
	my $cw = shift;
#	print "checking coloring\n";
	my $end = $cw->visualend;
#	print "\tvisual $end\n";
	my $col = $cw->cget('-colored');
#	print "\tcolored to $col\n";
	if ($col < $end) {
		$col = $cw->highlight($col, $end);
		$cw->configure(-colored => $col);
	};
	$cw->matchCheck;
}

sub insert {
	my $cw = shift;
	my $pos = shift;
	$pos = $cw->index($pos);
	my $begin = $cw->linenumber("$pos - 1 chars");
	$cw->SUPER::insert($pos, @_);
	$cw->highlightCheck($begin, $cw->linenumber("insert lineend"));
}

sub Insert {
	my $cw = shift;
	$cw->SUPER::Insert(@_);
	$cw->see('insert');
}

sub InsertKeypress {
	my ($cw,$char) = @_;
#	print "calling InsertKeypress\n";
	if ($char ne '') {
		my $index = $cw->index('insert');
		my $line = $cw->linenumber($index);
		if ($char =~ /^\S$/ and !$cw->OverstrikeMode and !$cw->tagRanges('sel')) {
			my $undo_item = $cw->getUndoAtIndex(-1);
			if (defined($undo_item) &&
				($undo_item->[0] eq 'delete') &&
				($undo_item->[2] == $index)
			) {
				$cw->Tk::Text::insert($index,$char);
				$undo_item->[2] = $cw->index('insert');
				$cw->highlightCheck($line, $line);
				return;
			}
		}
		$cw->addGlobStart;
		$cw->Tk::Text::InsertKeypress($char);
		$cw->addGlobEnd;
	}
}

sub linenumber {
	my ($cw, $index) = @_;
	if (not defined($index)) { $index = 'insert'; }
	my $id = $cw->index($index);
	my ($line, $pos ) = split(/\./, $id);
#	print "linenumber $line\n";
	return $line;
}

sub Load {
	my $cw = shift;
	my @r = $cw->SUPER::Load(@_);
	$cw->highlightVisual;
	return @r;
}

sub matchCheck {
	my $cw = shift;
	my $c = $cw->get('insert - 1 chars', 'insert');
	my $p = $cw->index('match');
	if ($p ne '0.0') {
		$cw->tagRemove('Match', $p, "$p + 1 chars");
		$cw->markSet('match', '0.0');
	}
	if ($c) {
		my $v = $cw->cget('-match');
		my $p = index($v, $c);
#		print "character $c number $p\n";
		if ($p ne -1) { #a character in '-match' has been detected.
			my $count = 0;
			my $found = 0;
			if ($p % 2) {
				my $m = substr($v, $p - 1, 1);
#				print "searching -backwards $c $m\n";
				$cw->matchFind('-backwards', $c, $m, 
					$cw->index('insert - 1 chars'),
					$cw->index('@0,0'),
				);
			} else {
				my $m = substr($v, $p + 1, 1);
#				print "searching -forwards, $c, $m\n";
				$cw->matchFind('-forwards', $c, $m,
					$cw->index('insert'),
					$cw->index($cw->visualend . '.0 lineend'),
				);
			}
		}
	}
	$cw->updateCall;
}

sub matchFind {
	my ($cw, $dir, $char, $ochar, $start, $stop) = @_;
	#first of all remove a previous match highlight;
	my $pattern = "\\$char|\\$ochar";
	my $found = 0;
	my $count = 0;
	while ((not $found) and (my $i = $cw->search(
		$dir, '-regexp', '-nocase', '--', $pattern, $start, $stop
	))) {
		my $k = $cw->get($i, "$i + 1 chars");
#		print "found $k at $i and count is $count\n";
		if ($k eq $ochar) {
			if ($count > 0) {
#				print "decrementing count\n";
				$count--;
				if ($dir eq '-forwards') {
					$start = $cw->index("$i + 1 chars");
				} else {
					$start = $i;
				}
			} else {
#				print "Found !!!\n";
				$cw->markSet('match', $i);
				$cw->tagAdd('Match', $i, "$i + 1 chars");
				$cw->tagRaise('Match');
				$found = 1;
			}
		} elsif ($k eq $char) {
#			print "incrementing count\n";
			$count++;
			if ($dir eq '-forwards') {
				$start = $cw->index("$i + 1 chars");
			} else {
				$start = $i;
			}
		} elsif ($i eq $start) {
			$found = 1;
		}
	}
}

sub matchoptions {
	my $cw = shift;
	if (my $o = shift) {
		my @op = ();
		if (ref($o)) {
			@op = @$o;
		} else {
			@op = split(/\s+/, $o);
		}
		$cw->tagConfigure('Match', @op);
	}
}


sub PostPopupMenu {
	my $cw = shift;
	my @r;
	if (not $cw->cget('-disablemenu')) {
		@r = $cw->SUPER::PostPopupMenu(@_);		
	}
}

sub rulesConfigure {
	my $cw = shift;
	if (my $plug = $cw->Subwidget('formatter')) {
		my $rules = $plug->rules;
		my @r = @$rules;
		foreach my $k (@r) {
			$cw->tagConfigure(@$k);
		};
		$cw->configure(-colored => 1, -colorinf => [[ $plug->stateGet]]);
	}
}

sub rulesDelete {
	my $cw = shift;
	if (my $plug = $cw->Subwidget('formatter')) {
		my $rules = $plug->rules;
		foreach my $r (@$rules) {
			$cw->tagDelete($r->[0]);
		}
	}
}


sub rulesEdit {
	my $cw = shift;
	require Tk::RulesEditor;
	$cw->RulesEditor(
		-class => 'Toplevel',
	);
}

sub rulesFetch {
	my $cw = shift;
	my $dir = $cw->cget('-rulesdir');
	my $syntax = $cw->cget('-syntax');
	$cw->configure(-rules => undef);
#	print "rulesFetch called\n";
	my $result = 0;
	if ($dir and (-e "$dir/$syntax.rules")) {
		my $file = "$dir/$syntax.rules";
#		print "getting $file\n";
		if (my $rl = retrieve("$dir/$syntax.rules")) {
#			print "configuring\n";
			$cw->configure(-rules => $rl);
			$result = 1;
		}
	}
	return $result;
}

sub rulesSave {
	my $cw = shift;
	my $dir = $cw->cget('-rulesdir');
#	print "rulesSave called\n";
	if ($dir) {
		my $syntax = $cw->cget('-syntax');
		my $file = "$dir/$syntax.rules";
		store($cw->cget('-rules'), $file);
	}
}

sub scan {
	my $cw = shift;
	my @r = $cw->SUPER::scan(@_);
	$cw->highlightVisual;
	return @r;
}

sub selectionModify {
	my ($cw, $char, $mode) = @_;
	my @ranges = $cw->tagRanges('sel');
	if (@ranges eq 2) {
		my $start = $cw->index($ranges[0]);
		my $end = $cw->index($ranges[1]);
#		print "doing from $start to $end\n";
		while ($cw->compare($start, "<", $end)) {
#			print "going to do something\n";
			if ($mode) {
				if ($cw->get("$start linestart", "$start linestart + 1 chars") eq $char) {
					$cw->delete("$start linestart", "$start linestart + 1 chars");
				}
			} else {
				$cw->insert("$start linestart", $char)
			}
			$start = $cw->index("$start + 1 lines");
		}
		$cw->tagAdd('sel', @ranges);
	}
}

sub selectionComment {
	my $cw = shift;
	$cw->selectionModify($cw->cget('-commentchar'), 0);
}

sub selectionIndent {
	my $cw = shift;
	$cw->selectionModify($cw->cget('-indentchar'), 0);
}

sub selectionUnComment {
	my $cw = shift;
	$cw->selectionModify($cw->cget('-commentchar'), 1);
}

sub selectionUnIndent {
	my $cw = shift;
	$cw->selectionModify($cw->cget('-indentchar'), 1);
}

sub syntax {
	my $cw = shift;
	if (@_) {
		my $name = shift;
		my $fm;
		eval ("require Tk::TextHighlight::$name;	\$fm = new Tk::TextHighlight::$name(\$cw);");
		$cw->Advertise('formatter', $fm);
		$cw->configure('-langname' => $name);
	}
	return $cw->cget('-langname');
}

sub yview {
	my $cw = shift;
	my @r = ();
	if (@_) {
		@r = $cw->SUPER::yview(@_);
		$cw->highlightVisual;
	} else {
		@r = $cw->SUPER::yview;
	}
	return @r;
}

sub see {
	my $cw = shift;
	my @r = $cw->SUPER::see(@_);
	$cw->highlightVisual;
	return @r
}

sub updateCall {
	my $cw = shift;
	my $call = $cw->cget('-updatecall');
	&$call;
}

sub ViewMenuItems {
	my $cw = shift;
	my $s;
	tie $s,'Tk::Configure',$cw,'-syntax';
	my @stx = ('None', $cw->highlightPlugList);
	my @rad = ();
	foreach my $n (@stx) {
		push(@rad, [
			'radiobutton' => $n,
			-variable => \$s,
			-value => $n,
			-command => sub {
				$cw->configure('-rules' => undef);
				$cw->highlightPlug;
			}
		]);
	}
	return [
		@{$cw->SUPER::ViewMenuItems},
		['cascade'=>'Syntax',
			-menuitems => [@rad],
		],
		['command'=>'Rules Editor',
			-command => sub { $cw->rulesEdit },
		],
	];
}

sub visualend {
	my $cw = shift;
	my $end = $cw->linenumber('end - 1 chars');
	my ($first, $last) = $cw->Tk::Text::yview;
	my $vend = int($last * $end) + 2;
	if ($vend > $end) {
		$vend = $end;
	}
	return $vend;
}

=cut

1;

__END__
	Global
`s`	Focus search bar
`?`	Bring up this help dialog
	GitHub
`g` `p`	Go to pull requests
`g` `i`	go to github issues (only if github is preferred repository)
	POD
`g` `a`	Go to author
`g` `c`	Go to changes
`g` `i`	Go to issues
`g` `d`	Go to dist
`g` `r`	Go to repository/SCM
`g` `s`	Go to source
`g` `b`	Go to file browse
	Search terms
module: (e.g. module:Plugin)
distribution: (e.g. distribution:Dancer auth)
author: (e.g. author:SONGMU Redis)
version: (e.g. version:1.00)