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__