Tk-CodeText-0.3.4/0040755000076400001440000000000010032317766012454 5ustar hajeusersTk-CodeText-0.3.4/t/0040755000076400001440000000000010032317766012717 5ustar hajeusersTk-CodeText-0.3.4/t/Tk_CodeText_HTML.t0100644000076400001440000000072510006543227016100 0ustar hajeusers# Before `make install' is performed this script should be runnable with # `make test'. After `make install' it should work as `perl 1.t' ######################### # change 'tests => 1' to 'tests => last_test_to_print'; use Test::More tests => 1; BEGIN { use_ok('Tk::CodeText::HTML') }; ######################### # Insert your test code below, the Test::More module is use()ed here so read # its man page ( perldoc Test::More ) for help writing this test script. Tk-CodeText-0.3.4/t/Tk_CodeText_None.t0100644000076400001440000000072510006543433016232 0ustar hajeusers# Before `make install' is performed this script should be runnable with # `make test'. After `make install' it should work as `perl 1.t' ######################### # change 'tests => 1' to 'tests => last_test_to_print'; use Test::More tests => 1; BEGIN { use_ok('Tk::CodeText::None') }; ######################### # Insert your test code below, the Test::More module is use()ed here so read # its man page ( perldoc Test::More ) for help writing this test script. Tk-CodeText-0.3.4/t/Tk_CodeText_Perl.t0100644000076400001440000000072510006543552016237 0ustar hajeusers# Before `make install' is performed this script should be runnable with # `make test'. After `make install' it should work as `perl 1.t' ######################### # change 'tests => 1' to 'tests => last_test_to_print'; use Test::More tests => 1; BEGIN { use_ok('Tk::CodeText::Perl') }; ######################### # Insert your test code below, the Test::More module is use()ed here so read # its man page ( perldoc Test::More ) for help writing this test script. Tk-CodeText-0.3.4/t/Tk_CodeText_Pod.t0100644000076400001440000000072410006543637016062 0ustar hajeusers# Before `make install' is performed this script should be runnable with # `make test'. After `make install' it should work as `perl 1.t' ######################### # change 'tests => 1' to 'tests => last_test_to_print'; use Test::More tests => 1; BEGIN { use_ok('Tk::CodeText::Pod') }; ######################### # Insert your test code below, the Test::More module is use()ed here so read # its man page ( perldoc Test::More ) for help writing this test script. Tk-CodeText-0.3.4/t/Tk_CodeText_Xresources.t0100644000076400001440000000073310006543743017500 0ustar hajeusers# Before `make install' is performed this script should be runnable with # `make test'. After `make install' it should work as `perl 1.t' ######################### # change 'tests => 1' to 'tests => last_test_to_print'; use Test::More tests => 1; BEGIN { use_ok('Tk::CodeText::Xresources') }; ######################### # Insert your test code below, the Test::More module is use()ed here so read # its man page ( perldoc Test::More ) for help writing this test script. Tk-CodeText-0.3.4/t/Tk_CodeText.t0100644000076400001440000000071710012245026015246 0ustar hajeusers# Before `make install' is performed this script should be runnable with # `make test'. After `make install' it should work as `perl 1.t' ######################### # change 'tests => 1' to 'tests => last_test_to_print'; use Test::More tests => 1; BEGIN { use_ok('Tk::CodeText') }; ######################### # Insert your test code below, the Test::More module is use()ed here so read # its man page ( perldoc Test::More ) for help writing this test script. Tk-CodeText-0.3.4/t/Tk_CodeText_Template.t0100644000076400001440000000073110006543707017107 0ustar hajeusers# Before `make install' is performed this script should be runnable with # `make test'. After `make install' it should work as `perl 1.t' ######################### # change 'tests => 1' to 'tests => last_test_to_print'; use Test::More tests => 1; BEGIN { use_ok('Tk::CodeText::Template') }; ######################### # Insert your test code below, the Test::More module is use()ed here so read # its man page ( perldoc Test::More ) for help writing this test script. Tk-CodeText-0.3.4/t/Tk_RulesEditor.t0100644000076400001440000000072210012245103015760 0ustar hajeusers# Before `make install' is performed this script should be runnable with # `make test'. After `make install' it should work as `perl 1.t' ######################### # change 'tests => 1' to 'tests => last_test_to_print'; use Test::More tests => 1; BEGIN { use_ok('Tk::RulesEditor') }; ######################### # Insert your test code below, the Test::More module is use()ed here so read # its man page ( perldoc Test::More ) for help writing this test script. Tk-CodeText-0.3.4/t/Tk_CodeText_Bash.t0100644000076400001440000000072510013656612016212 0ustar hajeusers# Before `make install' is performed this script should be runnable with # `make test'. After `make install' it should work as `perl 1.t' ######################### # change 'tests => 1' to 'tests => last_test_to_print'; use Test::More tests => 1; BEGIN { use_ok('Tk::CodeText::Bash') }; ######################### # Insert your test code below, the Test::More module is use()ed here so read # its man page ( perldoc Test::More ) for help writing this test script. Tk-CodeText-0.3.4/CodeText/0040755000076400001440000000000010032317766014173 5ustar hajeusersTk-CodeText-0.3.4/CodeText/Bash.pm0100755000076400001440000001350010026035156015376 0ustar hajeuserspackage Tk::CodeText::Bash; use vars qw($VERSION); $VERSION = '0.1'; # Initial release; use strict; use warnings; use base('Tk::CodeText::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/^(`)//) { #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/^(\\.)//) { #escaped character $self->snippetParse($1, 'Escaped character'); return $text; } if ($text =~ s/^(\$[^$separators]*)//) { #variable $self->snippetParse($1, 'Variable'); return $text; } if ($text =~ s/^(`)//) { #backticked $self->stackPush('Backticked'); $self->snippetParse($1); return $text; } if ($text =~ s/^(")//) { #string stop $self->snippetParse($1); $self->stackPull; return $text; } if ($text =~ s/^([^"|\$|`]+)//) { #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/^([^']+)//) { #string content $self->snippetParse($1); return $text; } if ($text =~ s/^(')//) { #string stop $self->snippetParse($1); $self->stackPull; return $text; } return $self->parserError($text); } sub parseText { my ($self, $text) = @_; if ($text =~ s/^(^#!\/.*)//) { #launch line $self->snippetParse($1, 'Reserved'); return $text; } if ($text =~ s/^(#.*)//) { #comment $self->snippetParse($1, 'Comment'); return $text; } if ($text =~ s/^(\s+)//) { #spaces $self->snippetParse($1); return $text; } if ($text =~ s/^(`)//) { #backticked $self->stackPush('Backticked'); $self->snippetParse($1); return $text; } if ($text =~ s/^(")//) { #string intrapolated $self->stackPush('String intrapolated'); $self->snippetParse($1); return $text; } if ($text =~ s/^('[^']*)//) { #string start $self->snippet($1); if ($text) { #if there is still text to be parsed, string ends at same line if ($text =~ s/(^')//) { $self->snippetParse($1) } } else { $self->stackPush('String'); } return $text; } if ($text =~ s/^(\$[^$separators]*)//) { #variable $self->snippetParse($1, 'Variable'); return $text; } if ($text =~ s/^([\|\||\||&&|&|;;|;|(|)])//) { #operator $self->snippetParse($1, 'Operator'); return $text } if ($text =~ s/^([<|>])//) { #remaining separators $self->snippetParse($1); return $text } if ($text =~ s/^(\\.)//) { #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__ =head1 NAME Tk::CodeText::Bash - a Plugin for HTML syntax highlighting =head1 SYNOPSIS require Tk::CodeText::Bash; my $sh = new Tk::CodeText::Bash( [ ['Text'], ['Tag', -foreground => 'brown'], ['Attr', -foreground => 'darkblue'], ['Comment', -foreground => 'lightblue'], ['Value', -foreground => 'orange'], ['String', -foreground => 'red'], ['SpChar', -foreground => 'magenta'], ]); =head1 DESCRIPTION Tk::CodeText::Bash is a plugin module that provides syntax highlighting for Bash to a Tk::CodeText text widget. It inherits Tk::CodeText::Template. See also there. =head1 AUTHOR Hans Jeuken (haje@toneel.demon.nl) =cut =head1 BUGS Unknown =cut Tk-CodeText-0.3.4/CodeText/Template.pm0100644000076400001440000001425710025720272016302 0ustar hajeuserspackage Tk::CodeText::Template; use vars qw($VERSION); $VERSION = '0.3'; use strict; use Data::Dumper; sub new { my ($proto, $rules) = @_; my $class = ref($proto) || $proto; if (not defined($rules)) { $rules = []; }; my $self = {}; $self->{'lists'} = {}; $self->{'out'} = []; $self->{'rules'} = $rules, $self->{'stack'} = []; $self->{'snippet'} = ''; $self->{'callbacks'} = {}; $self->{'oneliners'} = [], bless ($self, $class); return $self; } sub callbacks { my $hlt = shift; if (@_) { $hlt->{'callbacks'} = shift; }; return $hlt->{'callbacks'}; } sub highlight { my ($hlt, $text) = @_; $hlt->snippetParse; my $out = $hlt->out; @$out = (); while ($text) { # print "highlighting '$text'\n"; # print "mode is", $hlt->stackTop, "\n"; my $sub = $hlt->callbacks->{$hlt->stackTop}; $text = &$sub($hlt, $text); } $hlt->snippetParse; return @$out; } sub lists { my $hlt = shift; if (@_) { $hlt->{'lists'} = shift; }; return $hlt->{'lists'}; } sub listAdd { my $hlt = shift; my $listname = shift; # print "listname $listname\n"; my $lst = $hlt->lists; if (@_) { $lst->{$listname} = [@_]; } else { $lst->{$listname} = []; } my $r = $hlt->lists->{$listname}; # print "added tokens\n"; foreach my $f (@$r) { print " $f\n"; }; } sub rules { my $hlt = shift; if (@_) { $hlt->{'rules'} = shift; } return $hlt->{'rules'}; } sub out { my $hlt = shift; if (@_) { $hlt->{'out'} = shift; } return $hlt->{'out'}; } sub parserError { my ($hlt, $text) = @_; my $s = $hlt->stack; if (@$s eq 1) { #we cannot dump this mode because it's the lowest. warn "Parser error\n\tmode: '" . $hlt->stackTop . "'\n" . "text: '$text'\nparsing as plain text"; $hlt->snippetParse($text); $text =''; #Let's call it a day; } else { warn "Parser error\n\tmode: '" . $hlt->stackTop . "'\n" . "text: '$text'\nexiting mode"; $hlt->stackPull; }; return $text; } sub snippet { my $hlt = shift; if (@_) { $hlt->{'snippet'} = shift; } return $hlt->{'snippet'}; } sub snippetAppend { my ($hlt, $ch) = @_; $hlt->{'snippet'} = $hlt->{'snippet'} . $ch; } sub snippetParse { my $hlt = shift; my $snip = shift; my $attr = shift; unless (defined($snip)) { $snip = $hlt->snippet } unless (defined($attr)) { $attr = $hlt->stackTop } my $out = $hlt->{'out'}; # print "parsing '$snip' with attribute '$attr'\n"; if ($snip) { push(@$out, length($snip), $attr); $hlt->snippet(''); } } sub stack { my $hlt = shift; return $hlt->{'stack'}; } sub stackPush { my ($hlt, $val) = @_; # print "pushing $val\n"; my $stack = $hlt->stack; unshift(@$stack, $val); } sub stackPull { my ($hlt, $val) = @_; my $stack = $hlt->stack; return shift(@$stack); } sub stackTop { my $hlt = shift; return $hlt->stack->[0]; } 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; my $s = $hlt->stack; return @$s; } sub stateSet { my $hlt = shift; my $s = $hlt->stack; @$s = (@_); } sub syntax { my $hlt = shift; my $class = ref $hlt; $class =~ /Tk::CodeText::(.*)/; return $1; } sub tokenParse { my $hlt = shift; my $tkn = shift; $hlt->stackPush($tkn); $hlt->snippetParse(@_); $hlt->stackPull; } sub tokenTest { my ($hlt, $test, $list) = @_; # print "tokenTest $test\n"; my $l = $hlt->lists->{$list}; my @list = reverse sort @$l; # return grep { ($test =~ /^$_/) } @$l; my @rl = grep { (substr($test, 0, length($_)) eq $_) } @list; # foreach my $r (@rl) { print "$r\n" } if (@rl) { return $rl[0] } else { return undef; } } 1; __END__ =head1 NAME Tk::CodeText::Template - a template for syntax highlighting plugins =head1 SYNOPSIS =head1 DESCRIPTION Tk::CodeText::Template is a framework to assist authors of plugin modules. All methods to provide highlighting in a Tk::CodeText widget are there, Just no syntax definitions and callbacks. An instance of Tk::CodeText::Template should never be created, it's meant to be sub classed only. =head1 METHODS =over 4 =item B({I<'Tagname'> => I<\&callback>, ...}); sets and returns the instance variable 'callbacks' =item B(I<$text>); highlights I<$text>. It does so by selecting the proper callback from the B hash and invoke it. It will do so untill $text has been reduced to an empty string. =item B(I<'listname'>, I<$item1>, I<$item2> ...); Adds a list to the 'lists' hash. =item B(I); sets and returns the instance variable 'lists'. =item B(I); sets and returns the instance variable 'out'. =item B(I<'text'>); Error trapping method. Tries to escape the current mode. If that is not possible, it will parse the text with the default tag. Furthermore it complains about being called at all. Usefull for debugging when writing a new plugin. =item B(I) sets and returns a reference to a list of tagnames and options. By default it is set to []. =item B(I<$string>) appends I<$string> to the current snippet. =item B(I, I) parses $text to the 'out' list, and assigns $tagname to it. If $tagname is not specified it will look for the tagname by calling B. If I<$text> is also not specified it will look for text by calling B. =item B sets and returns the instance variable 'stack', a reference to an array. =item B retrieves the element that is on top of the stack, decrements stacksize by 1. =item B(I<$tagname>) puts I<$tagname> on top of the stack, increments stacksize by 1 =item B retrieves the element that is on top of the stack. =item B(I<\@state>); Compares two lists, \@state and the stack. returns true if they match. =item B Returns a list containing the entire stack. =item B(I<@list>) Accepts I<@list> as the current stack. =item B(I<'Tagname'>); Parses the currently build snippet and tags it with 'Tagname' =item B(I<$value>, I<'Listname'>); returns true if $value is and element of 'Listname' in the 'lists' hash =back =cut =head1 AUTHOR Hans Jeuken (haje@toneel.demon.nl) =cut =head1 BUGS Unknown. =cut Tk-CodeText-0.3.4/CodeText/Perl.pm0100644000076400001440000001113210026035456015422 0ustar hajeuserspackage Tk::CodeText::Perl; use vars qw($VERSION); $VERSION = '0.4'; use Syntax::Highlight::Perl; use base 'Syntax::Highlight::Perl'; 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/, $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__ =head1 NAME Tk::CodeText::Perl - a Plugin for Perl syntax highlighting =head1 SYNOPSIS Tk::CodeText::Perl inherits Syntax::Highlight::Perl; For its limitations see also there. This module provides extra methods to provide syntax highlighting for the Perl programming language. =head1 METHODS =over 4 =item B(I<$string>); returns a list of string snippets and tags that can be inserted in a Tk::Text like widget instantly. =item B(I<$txtwidget>,I<\@list>) sets and returns a reference to a list of tagnames and options. By default it is set to: [ ['Comment_Normal', -foreground => 'lightblue'], ['Comment_Pod', -foreground => 'lightblue'], ['Directive', -foreground => 'black'], ['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 => 'darkgreen'], ['Builtin_Operator', -foreground => 'darkgreen'], ['Operator', -foreground => 'brown'], ['Number', -foreground => 'darkblue'], ] =item B(I<$txtwidget>,I<\@list>) Used internally. Don't call it yourself. =item B(I<$txtwidget>,I<\@list>) =item B(\@state); Compares @state to the current state of the formatter. returns true when equal. =item B Returns a list of the current state of the formatter. Called by the highlighting routines in Tk::CodeText. =item B(I<@list>) Sets the state of the formatter. Called by the highlighting routines in Tk::CodeText. =back =cut =head1 AUTHOR Hans Jeuken (haje@toneel.demon.nl) =cut =head1 BUGS Propably plenty =cut Tk-CodeText-0.3.4/CodeText/Pod.pm0100644000076400001440000000626610026035161015247 0ustar hajeuserspackage Tk::CodeText::Pod; use vars qw($VERSION); $VERSION = '0.2'; use strict; use base 'Tk::CodeText::Template'; sub new { my ($proto, $rules) = @_; my $class = ref($proto) || $proto; if (not defined($rules)) { $rules = [ ['Text'], ['Bold', -foreground => 'purple'], ['Italic', -foreground => 'purple'], ['Exact', -foreground => 'brown'], ['Command', -foreground => 'orange'], ['Space', -background => 'beige'], ['Tab', -background => 'pale green'], ]; }; my $self = $class->SUPER::new($rules); bless ($self, $class); $self->listAdd('specchars', 'B', 'I'); $self->listAdd('specmodes', 'Bold', 'Italic'); $self->stackPush('Text'); return $self; } sub highlight { my ($hlt, $in) = @_; $hlt->snippetParse; my $out = $hlt->out; @$out = (); my $first = substr($in, 0, 1); if (substr($in, 0, 5) eq '=head') { #head mode $hlt->snippet($in); $hlt->tokenParse('Command'); } elsif ($first eq '=') { #command mode $in =~ /(=[^\s]+)/g; $hlt->snippet($1); $hlt->tokenParse('Command'); $hlt->parseText(substr($in, length($1), length($in) - length($1))); } elsif (($first eq "\t") or ($first eq ' ')) { #exact mode $in =~ /(^[^\S]+)/g; my @sp = split //, $1; while (@sp) { my $k = shift @sp; if ($k eq " ") { $hlt->snippet($k); $hlt->tokenParse('Space'); } elsif ($k eq "\t") { $hlt->snippet($k); $hlt->tokenParse('Tab'); } } $hlt->tokenParse('Command'); $hlt->snippet(substr($in, length($1), length($in) - length($1))); $hlt->tokenParse('Exact'); } else { #text mode $hlt->parseText($in); } return @$out; } sub parseText { my $hlt = shift; my @c = split //, shift; while (@c) { my $t = shift @c; if ($hlt->tokenTest($t, 'specchars')) { if ((@c) and ($c[0] eq '<')) { if ($t eq 'B') { $hlt->snippetParse; $hlt->snippetAppend($t); $hlt->stackPush('Bold'); } elsif ($t eq 'I') { $hlt->snippetParse; $hlt->snippetAppend($t); $hlt->stackPush('Italic'); } else { $hlt->snippetAppend($t); } } else { $hlt->snippetAppend($t); } } elsif ($t eq '>') { if ($hlt->tokenTest($hlt->stackTop, 'specmodes')) { $hlt->snippetAppend($t); $hlt->snippetParse; $hlt->stackPull; } } else { $hlt->snippetAppend($t); } }; $hlt->snippetParse; } 1; __END__ =head1 NAME Tk::CodeText::Pod - a Plugin for syntax highlighting of pod files. =head1 SYNOPSIS require Tk::CodeText::Pod; my $sh = new Tk::CodeText::Pod([ ['Text'], ['Bold', -font => [-weight => 'bold']], ['Italic', -font => [-slant => 'italic']], ['Exact', -foreground => 'brown'], ['Command', -foreground => 'orange'], ['Space', -background => 'beige'], ['Tab', -background => 'pale green'], ]); =head1 DESCRIPTION Tk::CodeText::Pod is a plugin module that provides syntax highlighting for pod files to a Tk::CodeText text widget. It inherits Tk::CodeText::Template. See also there. =head1 METHODS =over 4 =item B(I<$string>); returns a list of string snippets and tags that can be inserted in a Tk::Text like widget instantly. =item B returns 'Pod'. =back =cut =head1 AUTHOR Hans Jeuken (haje@toneel.demon.nl) =cut =head1 BUGS Unknown =cut Tk-CodeText-0.3.4/CodeText/Xresources.pm0100644000076400001440000000403510026035162016660 0ustar hajeuserspackage Tk::CodeText::Xresources; use vars qw($VERSION); $VERSION = '0.2'; use strict; use base('Tk::CodeText::Template'); sub new { my ($proto, $rules) = @_; my $class = ref($proto) || $proto; if (not defined($rules)) { $rules = [ ['Comment', -foreground => 'lightblue'], ['Path', -foreground => 'brown'], ['Command', -foreground => 'blue'], ['Separator', -foreground => 'darkblue'], ['Value', -foreground => 'orange'], ['False', -foreground => 'red'], ]; }; my $self = $class->SUPER::new($rules); bless ($self, $class); return $self; } sub highlight { my ($hlt, $in) = @_; $hlt->snippet(''); my $out = $hlt->out; @$out = (); if ($in =~ /^(\s+!|!)/g) { $hlt->snippet($in); $hlt->tokenParse('Comment'); } elsif ($in =~ /^(\s+#|#)/g) { $hlt->snippet($in); $hlt->tokenParse('Command'); } elsif ($in =~ /([^:]+)(:)([^:]+)/g) { $hlt->snippet($1); $hlt->tokenParse('Path'); $hlt->snippet($2); $hlt->tokenParse('Separator'); $hlt->snippet($3); $hlt->tokenParse('Value'); } else { $hlt->snippet($in); $hlt->tokenParse('False'); } return @$out; } sub syntax { my $hlt = shift; return 'Xresources'; } 1; __END__ =head1 NAME Tk::CodeText::Xresources - a Plugin for xresources files syntax highlighting =head1 SYNOPSIS require Tk::CodeText::Xresources; my $sh = new Tk::CodeText::Xresources([ ['Comment', -foreground => 'lightblue'], ['Path', -foreground => 'brown'], ['Command', -foreground => 'blue'], ['Separator', -foreground => 'darkblue'], ['Value', -foreground => 'orange'], ['False', -foreground => 'red'], ]); =head1 DESCRIPTION Tk::CodeText::Xresources is a plugin module that provides syntax highlighting for xresources files to a Tk::CodeText text widget. It inherits Tk::CodeText::Template. See also there. =head1 METHODS =over 4 =item B(I<$string>); returns a list of string snippets and tags that can be inserted in a Tk::Text like widget instantly. =cut =head1 AUTHOR Hans Jeuken (haje@toneel.demon.nl) =cut =head1 BUGS Unknown =cut Tk-CodeText-0.3.4/CodeText/HTML.pm0100644000076400001440000001025710026035164015267 0ustar hajeuserspackage Tk::CodeText::HTML; use vars qw($VERSION); $VERSION = '0.2'; use strict; use base('Tk::CodeText::Template'); sub new { my ($proto, $rules) = @_; my $class = ref($proto) || $proto; if (not defined($rules)) { $rules = [ ['Text'], ['Tag', -foreground => 'brown'], ['Attr', -foreground => 'darkblue'], ['Comment', -foreground => 'lightblue'], ['Value', -foreground => 'orange'], ['String', -foreground => 'red'], ['SpChar', -foreground => 'magenta'], ]; }; my $self = $class->SUPER::new($rules); $self->stackPush('Text'); bless ($self, $class); return $self; } sub highlight { my $hlt = shift; my @in = split //, shift; $hlt->snippetParse; my $out = $hlt->out; @$out = (); foreach my $c (@in) { if ($c eq '<') { if ($hlt->stackTop eq 'Text') { # print "opening Tag\n"; $hlt->snippetParse; $hlt->snippetAppend($c); $hlt->stackPush('Tag'); } else { $hlt->snippetAppend($c) } } elsif ($c eq '>') { if ($hlt->stackTop eq 'Tag') { # print "closing Tag\n"; $hlt->snippetAppend($c); $hlt->snippetParse; $hlt->stackPull; } elsif (($hlt->stackTop eq 'Value') or ($hlt->stackTop eq 'Attr') or ($hlt->stackTop eq 'Comment')) { # print "closing Tag\n"; $hlt->snippetParse; $hlt->stackPull; $hlt->snippetAppend($c); $hlt->snippetParse; $hlt->stackPull; } else { $hlt->snippetAppend($c); } } elsif ($c eq '"') { if (($hlt->stackTop eq 'Value') or ($hlt->stackTop eq 'Comment')) { # print "opening String\n"; $hlt->snippetParse; $hlt->snippetAppend($c); $hlt->stackPush('String'); } elsif ($hlt->stackTop eq 'String') { # print "closing String\n"; $hlt->snippetAppend($c); $hlt->snippetParse; $hlt->stackPull; } else { $hlt->snippetAppend($c); } } elsif ($c eq '!') { if ($hlt->stackTop eq 'Tag') { # print "opening Comment\n"; $hlt->snippetParse; $hlt->snippetAppend($c); $hlt->stackPush('Comment'); } else { $hlt->snippetAppend($c); } } elsif ($c eq '&') { if ($hlt->stackTop eq 'Text') { # print "opening SpChar\n"; $hlt->snippetParse; $hlt->snippetAppend($c); $hlt->stackPush('SpChar'); } else { $hlt->snippetAppend($c); } } elsif ($c eq ';') { if ($hlt->stackTop eq 'SpChar') { # print "closing SpChar\n"; $hlt->snippetAppend($c); $hlt->snippetParse; $hlt->stackPull; } else { $hlt->snippetAppend($c); } } elsif ($c eq '=') { if ($hlt->stackTop eq 'Attr') { # print "opening Value\n"; $hlt->snippetParse; $hlt->stackPull; $hlt->snippetAppend($c); $hlt->snippetParse; $hlt->stackPush('Value'); } else { $hlt->snippetAppend($c); } } elsif ($c =~ /\s/) { if ($hlt->stackTop eq 'Tag') { # print "opening Attr\n"; $hlt->snippetParse; $hlt->snippetAppend($c); $hlt->stackPush('Attr'); } elsif ($hlt->stackTop eq 'Value') { $hlt->snippetParse; $hlt->snippetAppend($c); $hlt->stackPull; $hlt->stackPush('Attr'); } elsif ($hlt->stackTop eq 'SpChar') { $hlt->snippetParse; $hlt->snippetAppend($c); $hlt->stackPull; } else { $hlt->snippetAppend($c); } } else { $hlt->snippetAppend($c); } } $hlt->snippetParse; return @$out; } 1; __END__ =head1 NAME Tk::CodeText::HTML - a Plugin for HTML syntax highlighting =head1 SYNOPSIS require Tk::CodeText::HTML; my $sh = new Tk::CodeText::HTML($textwidget, [ ['Text'], ['Tag', -foreground => 'brown'], ['Attr', -foreground => 'darkblue'], ['Comment', -foreground => 'lightblue'], ['Value', -foreground => 'orange'], ['String', -foreground => 'red'], ['SpChar', -foreground => 'magenta'], ]); =head1 DESCRIPTION Tk::CodeText::HTML is a plugin module that provides syntax highlighting for HTML to a Tk::CodeText text widget. It works quite fine, but can use refinement and optimization. It inherits Tk::CodeText::None. See also there. =head1 METHODS =over 4 =item B(I<$string>); returns a list of string snippets and tags that can be inserted in a Tk::Text like widget instantly. =item B returns 'HTML'. =back =cut =head1 AUTHOR Hans Jeuken (haje@toneel.demon.nl) =cut =head1 BUGS Unknown =cut Tk-CodeText-0.3.4/CodeText/None.pm0100644000076400001440000000330610025721175015422 0ustar hajeuserspackage Tk::CodeText::None; use vars qw($VERSION); $VERSION = '0.3'; use strict; use Data::Dumper; sub new { my ($proto, $rules) = @_; my $class = ref($proto) || $proto; my $self = {}; bless ($self, $class); return $self; } sub highlight { my $hlt = shift; return (); } sub rules { my $hlt = shift; return []; } sub stateCompare { return 1; } sub stateGet { my $hlt = shift; return () } sub stateSet { my $hlt = shift; } sub syntax { my $hlt = shift; return 'None' } 1; __END__ =head1 NAME Tk::CodeText::None - a Plugin for No syntax highlighting =head1 SYNOPSIS require Tk::CodeText::None; my $hl = new Tk::CodeText::None; my @line = $hl->highlight($line); =head1 DESCRIPTION Tk::CodeText::None is some kind of a dummy plugin module. All methods to provide highlighting in a Tk::CodeText widget are there, ready to do nothing. It only provides those methods, that Tk::CodeText is going to call upon. =head1 METHODS =over 4 =item B(I<$string>); returns an empty list. =back The description of the remaining methods is more a description of what they are supposed to do if you write your own plugin. These methods actually do as little as possible. =over 4 =item B(I<$txtwidget>,I<\@rules>) sets and returns a reference to a list of tagnames and options. By default it is set to [ ]. =item B(\@state); Compares two lists, \@state and the stack. returns true if they match. =item B Returns a list containing the entire stack. =item B(I<@list>) Accepts I<@list> as the current stack. =item B returns B =back =cut =head1 AUTHOR Hans Jeuken (haje@toneel.demon.nl) =cut =head1 BUGS Unknown. =cut Tk-CodeText-0.3.4/demo.pl0100644000076400001440000000124110026044063013716 0ustar hajeusers#!/usr/bin/perl use strict; use blib; use Tk; require Tk::MainWindow; require Tk::HList; require Tk::CodeText; my $main = new MainWindow; my $ed; my $pl = $main->Scrolled('HList', -scrollbars => 'osoe', -browsecmd => sub { my $stx = shift; $ed->configure(-syntax => $stx); $ed->Load("samples/$stx.test"); }, )->pack( -side => 'left', -fill => 'y' ); $ed = $main->Scrolled('CodeText', -wrap => 'none', -syntax => 'Bash', -scrollbars => 'se', )->pack( -side => 'left', -expand => 1, -fill => 'both', ); my @plugs = $ed->highlightPlugList; foreach my $p (@plugs) { $pl->add($p, -text => $p, ); } $main->configure(-menu => $ed->menu); $main->MainLoop; Tk-CodeText-0.3.4/README0100644000076400001440000000163407621020716013331 0ustar hajeusersThis package is free software; you can redistribute it and/or modify it under the same terms as Perl itself. Tk::CodeText.pm is a Tk::TextUndo widget with capabilities of syntax highlighting. At this moment only the Perl language is supported. The highlight mechanism however, is of a plugin-type. Adding additional languages should be a matter of writing Tk::CodeText::MyLanguage modules. The perl syntax module is based on and requires Syntax::Highlight::Perl; This is the initial release. It has been written and tested on a linux machine. It is untested for microsoft based machines or mac. Please try it out on those machines and report your findings back to me. Not that you didn't know, but you install it like this: perl Makefile.PL make and then as root make install This software comes with no warranty whatsoever. If it breaks you own both parts. February 2003, Hans Jeuken (haje@toneel.demon.nl) Tk-CodeText-0.3.4/samples/0040755000076400001440000000000010032317766014120 5ustar hajeusersTk-CodeText-0.3.4/samples/HTML.test0100644000076400001440000004532007654535431015575 0ustar hajeusers Tk::CodeText - a TextUndo widget with syntax highlighting capabilities

NAME

Tk::CodeText - a TextUndo widget with syntax highlighting capabilities

SYNOPSIS

 use Tk;
 require Tk::CodeText;
 my $m = new MainWindow;
 my $e = $m->Scrolled('CodeText',
        -disablemenu => 1,
        -syntax => 'Perl',
        -scrollbars => 'se',
 )->pack(-expand => 1, -fill => 'both');
 $m->configure(-menu => $e->menu);
 $m->MainLoop;

DESCRIPTION

Tk::CodeText inherits Tk::TextUndo and all its options and methods. Besides syntax highlighting, methods are provided for commenting and uncommenting as well as indenting and unindenting a selected area, matching pairs of braces, brackets and brackets and curlies and automatic indenting of new lines.

Syntax highlighting is done through a plugin approach. Currently there is support for Perl, Pod, HTML and Xresources. Adding languages is a matter of writing plugin modules. Theoretically this is not limited to programming languages. The plugin approach could also provide the possibility for grammar or spell checking in spoken languages.

OPTIONS

Name: autoindent
Class: Autoindent
Switch: -autoindent
Boolean, when you press the enter button, should the next line begin at the same position as the current line or not. By default false.

Name: commentchar
Class: Commentchar
Switch: -commentchar
By default ``#''.

Name: disablemenu
Class: Disablemenu
Switch: -disablemenu
Boolean, by default 0. In case you don't want the menu under the right mouse button to pop up.

Name: indentchar
Class: Indentchar
Switch: -indentchar
By default ``\t''.

Name: match
Class: Match
Switch: -match
string of pairs for brace/bracket/curlie etc matching. If this description doesn't make anything clear, don't worry, the default setting will: 
 '[]{}()'

if you don't want matching to be available, simply set it to ''.

Name: matchoptions
Class: Matchoptions
Switch: -matchoptions
Options list for the tag 'Match'. By default: 
 [-background => 'red', -foreground => 'yellow']

You can also specify this option as a space separated string. Might come in handy for your Xresource files.

 "-background red -foreground yellow"

Name: not available
Class: not available
Switch -rules
Specify the color and font options for highlighting. You specify a list looking a bit like this. 
 [
     ['Tagname1', @options1],
     ['Tagname2', @options2],
 ]

The names of the tags are depending on the syntax that is highlighted. See the language modules for more information about this data structure.

Name: rulesdir
Class: Rulesdir
Switch -rulesdir
Specify the directory where this widget stores its coloring defenitions. Files in this directory are stored as ``HTML.rules'', ``Perl.rules'' etc. By default it is set to '', which means that when you switch syntax the highlighting rules are not loaded or stored. The hard coded defaults in the language modules will be used.

Name: syntax
Class: Syntax
Switch: -syntax
Specifies the language for highlighting. At this moment the possible values are None, HTML, Perl, Pod and Xresources. By default None

Alternatively it is possible to specify a reference to your independent plugin.

Name: Not available
Class: Not available
Switch: -updatecall
Here you can specify a callback that will be executed whenever the insert cursor has moved or text has been modified, so your application can keep track of position etc. Don't make this callback to heavy, the widget will get sluggish quickly.

There are some undocumented options. They are used internally. It is propably best to leave them alone.

METHODS

doAutoIndent
highlight
highlightCheck
highlightLine
highlightPlug
highlightPlugInit
highlightPurge
highlightVisual
linenumber
matchCheck
matchFind
rulesEdit
Pops up a window that enables the user the set the color and font options for the current syntax.

rulesFetch
rulesSave
selectionComment
selectionIndent
selectionModify
selectionUnComment
selectionUnIndent

SYNTAX HIGHLIGHTING

This section is a brief description of how the syntax highlighting process works.

Initiating plugin

The highlighting plugin is only then initiated when it is needed. When some highlighting needs to be done, the widget calls highlightPlug to retrieve a reference to the plugin.

highlightPlug checks wether a plugin is present. Next it will check whether the -rules option has been specified or whter the -rules option has changed. If no rules are specified in -rules, it will look for a pathname in the -rulesdir option. If that is found it will try to load a file called '*.rules', where * is the value of -syntax.

If no plugin is present, or the -syntax option has changed value, highlightPlug loads the plugin. and constructs optionally giving it a reference to the found rules as parameter. if no rules are specified, the plugin will use its internal hardcoded defaults.

Changing the rules

A set of rules is a list, containing lists of tagnames, followed by options. If you want to see what they look like, you can have a look at the constructors of each plugin module. Every plugin has a fixed set of tagnames it can handle.

There are two ways to change the rules.

You can invoke the rulesEdit method, which is also available through the View menu. The result is a popup in which you can specify color and font options for each tagname. After pressing 'Ok', the edited rules will be applied. If -rulesdir is specified, the rules will be saved on disk as rulesdir/syntax.rules.

You can also use configure to specify a new set of rules. In this you have ofcause more freedom to use all available tag options. For more details about those there is a nice section about tag options in the Tk::Text documentation. After the call to configure it is wise to call highlightPlug.

Highlighting text

Syntax highlighting is done in a lazy manor. Only that piece of text is highlighted that is needed to present the user a pretty picture. This is done to minimize use of system resources. Highlighting is running on the foreground. Jumping directly to the end of a long fresh loaded textfile may very well take a couple of seconds.

Highlighting is done on a line to line basis. At the end of each line the highlighting status is saved in the list in -colorinf, so when highlighting the next line, the highlight method of CodeText will know how to begin.

The line that needs highlighting is offered to the highlight method of the plugin. This method returns a list of offset and tagname pairs. Take for example the following line of perl code.

 my $mother = 'older than i am';

The highlight method of the Perl plugin will return the following list;

 (2 => 'Reserved',    #'my' is a reserved word
  1 => 'DEFAULT',     #Space
  7 => 'Variable',    #$mother
  1 => 'DEFAULT',     #Space
  1 => 'Operator',    #'='
  1 => 'DEFAULT',     #Space
  17 => 'String',     #'older than i am'
  1 => 'DEFAULT',)    #;

The highlight method of CodeText will then mark positions 0 to 2 as 'Reserved', positions 2 to 3 as 'DEFAULT', positions 3 to 10 as 'Variable', etcetera.

WRITING PLUGINS

After writing a couple of plugins myself i have come to a couple of guidelines about how to set them up. If you are interested in adding support for your own syntax highlighting problem or language this section is of interest to you.

From scratch

If you choose to build a plugin completely from scratch, your module needs to meet the following requirements.

 - If you want to write a formal addition to Tk::CodeText, 
   your plugin must be in the namespace 
   Tk::CodeText::YourSyntax.
 - The constructor is called 'new', and it should accept 
   a reference a reference to a list of rules as parameters.
 - The following methods will be called upon by Tk::CodeText: 
     highlight, stateCompare, rules, setSate, 
     getState, syntax.

More information about those methods is available in the documentation of Tk::CodeText::None and Tk::CodeText::Template. Good luck, you're on your own now.

Inheriting Tk::CodeText::Template

For many not too complicated highlighting problems Tk::CodeText::Template provides a nice basis to start from. I have been able to write to easily write support for HTML, Pod and Xresources files. Anyway, your code should look like this:

 package Tk::CodeText::MySyntax;
 
 use strict;
 use base('Tk::CodeText::Template');
 
 sub new {
    my ($proto, $wdg, $rules) = @_;
    my $class = ref($proto) || $proto;

Next, specify the set of hardcoded rules.

    if (not defined($rules)) {
       $rules =  [
          ['Tagname1', -foreground => 'red'],
          ['Tagname1', -foreground => 'red'],
       ];
    };

Call the constructor of Tk::CodeText::Template and bless your object.

    my $self = $class->SUPER::new($wdg, $rules);
    bless ($self, $class);

Perhaps do a couple of other things

    #$self->listAdd('listname', value1, value2 ....)
    return $self;
 }

Then you need a highlight method. This method will be given a line of text as parameter by CodeText.

 sub highlight {
    my ($self $txt) = @_;

Reset everything so that there is a clean beginning;

    $cw->snippet('');
    my $out = $self->out;
    @$out = ();

Here comes the difficult part, where you are on your own. Perhaps you can draw some inspiration from existing highlighting plugins. The trick is to repeatedly build a text snippet using the snippet and/or snippetAppend methods of Tk::CodeText::Template. Whenever you have a snippet, you want to assign a tag to, you call snippetParse. The methods stack, stackPush, and stackPush are used to keep track of the current, possibly nested, tag. snippetParse pushes the length of the snippet and the tagname that is on top of the stack to the @$out array. For more information read the documentation of Tk::CodeText::Template.

After you're done highlighting, you still have to return your result;

    return @$out;
 }

And then, last but not least, you need a syntax method.

 sub syntax {
    my $self = shift;
    return 'MySyntax'
 }
 1;

Using another module as basis

An example of this approach is the Perl syntax module.

Also with this approach you will have to meet the minimum criteria as set out in the From scratch section.

AUTHOR

Hans Jeuken (haje@toneel.demon.nl)

BUGS

Unknown.

TODO

Find and eliminate bugs.
Improve documentation.
Add additional language modules. I am going to need help on this one.
Optimize highlighting methods.
Syntax highlighting consumes a lot of system resources. Squeezing every bit of performance out of it might make it less sluggish on slow systems, like a pentium at 100Mhz.

If you're interested in this module, please have a look at the code and point out to me where I might have overlooked something. Of special interest are the CodeText methods highlight and highlightLine as well as the code of the language modules.

Add variable options for linenumber, position, filename etc.
Make the rules editor fail safe.

SEE ALSO

Tk::Text, Tk::TextUndo, Tk::CodeText::None, Tk::CodeText::Perl Tk::CodeText::HTML
Tk-CodeText-0.3.4/samples/Bash.test0100644000076400001440000000554610026043304015670 0ustar hajeusers#!/bin/bash # # Sample .xinitrc for SuSE Linux # This script is called from 'startx' when you start an X session # # # In case everything goes wrong, we at least fall back to a plain xterm # failsafe="xterm -ls -T Failsave -geometry 80x24-0-0" trap "exec $failsafe" EXIT SIGHUP SIGINT SIGPIPE SIGTERM SIGIO # # Some bash (1 and 2) settings to avoid trouble on a # failed program call. # test -n "$BASH" && set +o posix no_exit_on_failed_exec=1 type shopt > /dev/null 2>&1 && shopt -s execfail set +e > /dev/null 2>&1 # # This should be the default # export TERM=xterm # # choose a window manager # if test -n "$WINDOWMANAGER" ; then WINDOWMANAGER=`type -p $WINDOWMANAGER` fi if test -z "$WINDOWMANAGER" ; then if test -x /usr/X11R6/bin/kde ; then WINDOWMANAGER=/usr/X11R6/bin/kde elif test -x /usr/X11R6/bin/startkde ; then WINDOWMANAGER=/usr/X11R6/bin/startkde elif test -x /usr/X11R6/bin/fvwm2 ; then WINDOWMANAGER=/usr/X11R6/bin/fvwm2 elif test -x /usr/X11R6/bin/wmlist ; then for i in `/usr/X11R6/bin/wmlist` ; do WINDOWMANAGER=`type -p $i` test -n "$WINDOWMANAGER" && break done elif test -x /usr/X11R6/bin/twm ; then WINDOWMANAGER=/usr/X11R6/bin/twm fi fi if test -z "$WINDOWMANAGER" ; then echo "Error: Unable to find a window manager. Please make sure you installed one!" echo "Exiting..." xmessage -timeout 10 -default okay -center -file - <<-EOF Error: Unable to find a window manager. Please make sure you installed one! Exiting... EOF exit 1 fi # # Load system and users resources if not already done # (XSESSION_IS_UP set by xdm in $XLIBDIR/xdm/Xsession) # if test "$XSESSION_IS_UP" != "yes" ; then XLIBDIR=/usr/X11R6/lib/X11 test -r $XLIBDIR/Xmodmap && xmodmap $XLIBDIR/Xmodmap test -r $HOME/.Xmodmap && xmodmap $HOME/.Xmodmap test -r $XLIBDIR/Xresources && xrdb -load -retain $XLIBDIR/Xresources test -r $HOME/.Xdefaults && xrdb -I$HOME -merge $HOME/.Xdefaults test -r $HOME/.Xresources && xrdb -I$HOME -merge $HOME/.Xresources fi # Start the XIM server test -r $HOME/.xim && source $HOME/.xim # Enable Numlock if set test -r /var/run/numlock-on -a -x /usr/X11R6/bin/numlock && /usr/X11R6/bin/numlock # Disable new Xcursor themes if none is specified resp. located in $HOME # (use "unset XCURSOR_CORE" to enable them again later) #if [ "x$XCURSOR_THEME" == "x" -a ! -d $HOME/.icons ]; then # export XCURSOR_CORE=true #else # unset XCURSOR_CORE #fi # Prevent keyboard bouncing for Toshiba Notebooks # Means, disable AccessX test -r /etc/sysconfig/sax && source /etc/sysconfig/sax if [ "x$KBD_BOUNCE_FIX" = "xyes" ]; then test -x /usr/X11R6/bin/xbounce && /usr/X11R6/bin/xbounce fi # # Add your own lines here... # # day planer deamon # pland & # # finally start the window manager # exec $WINDOWMANAGER # call failsafe exit 0 Tk-CodeText-0.3.4/samples/Xresources.test0100644000076400001440000001430610026043405017151 0ustar hajeusers! =========================================================================== ! OpenWindows Olwm Olvwn ! =========================================================================== ! OpenWindows.AutoRaise: false OpenWindows.AutoReReadMenuFile: true OpenWindows.Beep: never OpenWindows.ClickMoveThreshold: 5 OpenWindows.DragRightDistance: 50 OpenWindows.DragThreshold: 5 OpenWindows.FocusLenience: true OpenWindows.IconFlashCount: 3 OpenWindows.IconLocation: bottom OpenWindows.MinimalDecor: Virtual xload xmem xsysinfo xosview xbiff xclock xeyes OpenWindows.MultiClickTimeout: 4 OpenWindows.PaintWorkspace: true OpenWindows.PopupJumpCursor: true OpenWindows.RubberBandThickness: 1 OpenWindows.ScrollbarPlacement: right OpenWindows.SelectDisplaysMenu: False OpenWindows.SelectToggleStacking: true OpenWindows.SelectWindows: true OpenWindows.ServerGrabs: true OpenWindows.SetInput: followmouse OpenWindows.ShowMoveGeometry: true OpenWindows.ShowResizeGeometry: true OpenWindows.SnapToGrid: true OpenWindows.Use3D: true OpenWindows.Use3DFrames: true OpenWindows.Use3DResize: true OpenWindows.VirtualDesktop: 2x2 OpenWindows.VirtualGrid: none OpenWindows.VirtualSticky: Virtual xload xmem xsysinfo xosview xbiff xclock swissclock !OpenWindows.WindowColor: #b2b2b2 !OpenWindows.WorkspaceColor: gray *printCommand: lpr Mwm.interactivePlacement: false grok*ColSheet: black xterm*background: LightYellow2 xterm.eightBitInput: true xterm*multiScroll: on xterm*jumpScroll: on ! xterm*font: -adobe-courier-bold-r-normal--14-140-75-75-m-90-iso8859-1 xterm*ScrollBar: on xterm*SaveLines: 2000 ! xterm*VisualBell: true xterm.eightBitOutput: true Scrollbar.JumpCursor: True Ghostview.pageMedia: A4 *XConsole*text.scrollHorizontal: False *XConsole*text.wrap: line ! ! XSysinfo ! XSysinfo*.font: fixed XSysinfo*.title.label: Linx System Info XSysinfo*.title.width: 200 XSysinfo*.load.name.label: CPU Load: XSysinfo*.idle.name.label: CPU Idle: XSysinfo*.mem.name.label: Memory: XSysinfo*.swap.name.label: Swap: ! set foreground colors for load XSysinfo*load*bar.foreground: RosyBrown1 XSysinfo*load*bar.foreground1: IndianRed1 XSysinfo*load*bar.foreground2: OrangeRed1 XSysinfo*load*bar.foreground3: firebrick1 XSysinfo*load*bar.foreground4: pink1 XSysinfo*load*bar.foreground5: HotPink1 XSysinfo*load*bar.foreground6: DeepPink2 XSysinfo*load*bar.foreground7: maroon1 XSysinfo*load*bar.segmentGap: 1 ! set idle gauge color XSysinfo*idle*bar.foreground: green XSysinfo*idle*bar.backgroud: red ! set mem info gauge colors XSysinfo*mem*bar.foreground: tomato XSysinfo*mem*bar.foreground1: green3 XSysinfo*mem*bar.foreground2: orchid ! set swap gauge color XSysinfo*swap*bar.foreground: hotpink1 ! set background XSysinfo*.background: gray50 XSysinfo*.BarGauge.background: white *basicLocale: C *timeFormat: C *numeric: C *displayLang: C *inputLang: C #ifdef COLOR *customization: -color #endif !Here are the Xaw3D definitions that reside within my .Xdefaults file. !It took me a while to make everything look like the true Motif feel, so !put it into your .Xdefaults file and enjoy this cool xterm! ! ! Good Xaw3d Defaults #ifdef COLOR *Form.background: grey67 *TransientShell*Dialog.background: grey67 *Command.background: grey77 *MenuButton.background: grey77 *MenuButton.foreground: black *SimpleMenu*background: grey77 *SimpleMenu*foreground: black *ScrollbarBackground: grey67 *ScrollbarForeground: grey37 *Scrollbar*background: grey77 *Scrollbar*foreground: grey37 *Scrollbar*pointerColor: black *Scrollbar*pointerColorBackground: white *beNiceToColormap: False #else *Form.background: black *Form.foreground: white *TransientShell*Dialog.background: black *TransientShell*Dialog.foreground: white *Command.background: black *Command.foreground: white *MenuButton.background: black *MenuButton.foreground: white *SimpleMenu*background: black *SimpleMenu*foreground: white *ScrollbarBackground: black *ScrollbarForeground: white *Scrollbar*background: black *Scrollbar*foreground: white *Scrollbar*pointerColor: black *Scrollbar*pointerColorBackground: white *beNiceToColormap: True #endif XTerm*Scrollbar*width: 16 XTerm*Scrollbar*height: 16 XTerm*Scrollbar*shadowWidth: 2 XTerm*Scrollbar*borderWidth: 3 *Scrollbar*width: 15 *Scrollbar*height: 15 *Scrollbar*shadowWidth: 2 *Scrollbar*borderWidth: 2 *Scrollbar*cursorName: top_left_arrow *Scrollbar*pushThumb: false *Label*shadowWidth: 2 *Label*borderWidth: 2 *shapeStyle: Rectangle *shadowWidth: 2 *SmeBSB*shadowWidth: 2 *Toggle*highlightThickness: 2 *MenuButton*highlightThickness: 2 *Command*highlightThickness: 2 *Panner*shadowThickness: 2 *SimpleMenu*shadowThickness: 2 *topShadowContrast: 20 *bottomShadowContrast: 45 *PushThumb: False ! =========================================================================== ! Motif ! =========================================================================== !*XmText.translations: #override\n\ ! osfDelete: delete-previous-character()\n\ ! osfBackSpace: delete-next-character()\n ! !*XmTextField.translations: #override\n\ ! osfDelete: delete-next-character()\n\ ! osfBackSpace: delete-previous-character()\n ! =========================================================================== ! XTerm ! =========================================================================== !*vt100.translations: #override \ ! Home: string("[1~") \n\ ! Insert: string("[2~") \n\ ! BackSpace: string("[3~") \n\ ! End: string("[4~") ! =========================================================================== ! Acrobat Reader ! =========================================================================== AcroRead*XmScrollBar.baseTranslations: #augment \ Shift: PageDownOrRight(0) \n Shift: PageUpOrLeft(0) \n\ Ctrl: IncrementDownOrRight(0) IncrementDownOrRight(0) IncrementDownOrRight(0) \n\ Ctrl: IncrementUpOrLeft(0) IncrementUpOrLeft(0) IncrementUpOrLeft(0) \n\ : IncrementDownOrRight(0) \n : IncrementUpOrLeft(0) \n Tk-CodeText-0.3.4/samples/Pod.test0100755000076400001440000003553410026043570015545 0ustar hajeusers =head1 NAME Tk::CodeText - a TextUndo widget with syntax highlighting capabilities =head1 SYNOPSIS =over 4 use Tk; require Tk::CodeText; my $m = new MainWindow; my $e = $m->Scrolled('CodeText', -disablemenu => 1, -syntax => 'Perl', -scrollbars => 'se', )->pack(-expand => 1, -fill => 'both'); $m->configure(-menu => $e->menu); $m->MainLoop; =back =head1 DESCRIPTION Tk::CodeText inherits Tk::TextUndo and all its options and methods. Besides syntax highlighting, methods are provided for commenting and uncommenting as well as indenting and unindenting a selected area, matching pairs of braces, brackets and brackets and curlies and automatic indenting of new lines. Syntax highlighting is done through a plugin approach. Adding languages is a matter of writing plugin modules. Theoretically this is not limited to programming languages. The plugin approach could also provide the possibility for grammar or spell checking in spoken languages. If you have written a plugin and it works, if you send it to me, i will be happy to include it in the next release of Tk::CodeText. Currently there is support for B, B, B, B and B. =head1 OPTIONS =over 4 =item Name: B =item Class: B =item Switch: B<-autoindent> Boolean, when you press the enter button, should the next line begin at the same position as the current line or not. By default B. =item Name: B =item Class: B =item Switch: B<-commentchar> By default "#". =item Name: B =item Class: B =item Switch: B<-disablemenu> Boolean, by default 0. In case you don't want the menu under the right mouse button to pop up. =item Name: B =item Class: B =item Switch: B<-indentchar> By default "\t". =item Name: B =item Class: B =item Switch: B<-match> string of pairs for brace/bracket/curlie etc matching. If this description doesn't make anything clear, don't worry, the default setting will: '[]{}()' if you don't want matching to be available, simply set it to ''. =item Name: B =item Class: B =item Switch: B<-matchoptions> Options list for the tag 'Match'. By default: [-background => 'red', -foreground => 'yellow'] You can also specify this option as a space separated string. Might come in handy for your Xresource files. "-background red -foreground yellow" =item Name: not available =item Class: not available =item Switch B<-rules> Specify the color and font options for highlighting. You specify a list looking a bit like this. [ ['Tagname1', @options1], ['Tagname2', @options2], ] The names of the tags are depending on the syntax that is highlighted. See the language modules for more information about this data structure. =item Name: rulesdir =item Class: Rulesdir =item Switch B<-rulesdir> Specify the directory where this widget stores its coloring defenitions. Files in this directory are stored as "HTML.rules", "Perl.rules" etc. By default it is set to '', which means that when you switch syntax the highlighting rules are not loaded or stored. The hard coded defaults in the language modules will be used. =item Name: B =item Class: B =item Switch: B<-syntax> Specifies the language for highlighting. At this moment the possible values are B, B, B, B and B. By default B Alternatively it is possible to specify a reference to your independent plugin. =item Name: Not available =item Class: Not available =item Switch: B<-updatecall> Here you can specify a callback that will be executed whenever the insert cursor has moved or text has been modified, so your application can keep track of position etc. Don't make this callback to heavy, the widget will get sluggish quickly. =back There are some undocumented options. They are used internally. It is propably best to leave them alone. =cut =head1 METHODS =over 4 =item B Checks the indention of the previous line and indents the line where the cursor is equally deep. =item B(I<$begin>, I<$end>); Does syntax highlighting on the section of text indicated by $begin and $end. $begin and $end are linenumbers not indexes! =item B>(I<$begin>, I<$end>); An insert or delete has taken place affecting the section of text between $begin and $end. B is being called after and insert or delete operation. $begin and $end (again linenumbers, not indexes) indicate the section of text affected. B checks what needs to be highlighted again and does the highlighting. =item B(I<$line>); Does syntax highlighting on linenumber $line. =item B Checks wether the appropriate highlight plugin has been loaded. If none or the wrong one is loaded, it loads the correct plugin. It returns a reference to the plugin loaded. It also checks wether the rules have changed. If so, it restarts highlighting from the beginning of the text. =item B Loads and initalizes a highlighting plugin. First it checks the value of the B<-syntax> option to see which plugin should be loaded. Then it checks wether a set of rules is defined to this plugin in the B<-rules> option. If not, it tries to obtain a set of rules from disk using B. If this fails as well it will use the hardcoded rules from the syntax plugin. =item B(I<$line>); Tells the widget that the text from linenumber $line to the end of the text is not to be considered highlighted any more. =item B Calls B to see what part of the text is visible on the display, and adjusts highlighting accordingly. =item B(I<$index>); Returns the linenumber part of an index. You may also specify indexes like 'end' or 'insert' etc. =item B Checks wether the character that is just before the 'insert'-mark should be matched, and if so should it match forwards or backwards. It then calls B. =item B(I<$direction>, I<$char>, I<$match>, I<$start>, I<$stop>); Matches $char to $match, skipping nested $char/$match pairs, and displays the match found (if any). =item B Pops up a window that enables the user to set the color and font options for the current syntax. =item B Checks wether the file $text->cget('-rulesdir') . '/' . $text->cget('-syntax') . '.rules' exists, and if so attempts to load this as a set of rules. =item B Saves the currently loaded rules as $text->cget('-rulesdir') . '/' . $text->cget('-syntax') . '.rules' =item B Comment currently selected text. =item B Indent currently selected text. =item B Used by the other B methods to do the actual work. =item B Uncomment currently selected text. =item B Unindent currently selected text. =back =head1 SYNTAX HIGHLIGHTING This section is a brief description of how the syntax highlighting process works. B The highlighting plugin is only then initiated when it is needed. When some highlighting needs to be done, the widget calls B to retrieve a reference to the plugin. B checks wether a plugin is present. Next it will check whether the B<-rules> option has been specified or wether the B<-rules> option has changed. If no rules are specified in B<-rules>, it will look for a pathname in the B<-rulesdir> option. If that is found it will try to load a file called '*.rules', where * is the value of B<-syntax>. If no plugin is present, or the B<-syntax> option has changed value, B loads the plugin. and constructs optionally giving it a reference to the found rules as parameter. if no rules are specified, the plugin will use its internal hardcoded defaults. B A set of rules is a list, containing lists of tagnames, followed by options. If you want to see what they look like, you can have a look at the constructors of each plugin module. Every plugin has a fixed set of tagnames it can handle. There are two ways to change the rules. You can invoke the B method, which is also available through the B menu. The result is a popup in which you can specify color and font options for each tagname. After pressing 'Ok', the edited rules will be applied. If B<-rulesdir> is specified, the rules will be saved on disk as I. You can also use B to specify a new set of rules. In this you have ofcause more freedom to use all available tag options. For more details about those there is a nice section about tag options in the Tk::Text documentation. After the call to B it is wise to call B. B Syntax highlighting is done in a lazy manor. Only that piece of text is highlighted that is needed to present the user a pretty picture. This is done to minimize use of system resources. Highlighting is running on the foreground. Jumping directly to the end of a long fresh loaded textfile may very well take a couple of seconds. Highlighting is done on a line to line basis. At the end of each line the highlighting status is saved in the list in B<-colorinf>, so when highlighting the next line, the B method of B will know how to begin. The line that needs highlighting is offered to the B method of the plugin. This method returns a list of offset and tagname pairs. Take for example the following line of perl code. my $mother = 'older than i am'; The B method of the Perl plugin will return the following list; (2 => 'Reserved', #'my' is a reserved word 1 => 'DEFAULT', #Space 7 => 'Variable', #$mother 1 => 'DEFAULT', #Space 1 => 'Operator', #'=' 1 => 'DEFAULT', #Space 17 => 'String', #'older than i am' 1 => 'DEFAULT',) #; The B method of CodeText will then mark positions 0 to 2 as 'Reserved', positions 2 to 3 as 'DEFAULT', positions 3 to 10 as 'Variable', etcetera. =cut =head1 WRITING PLUGINS After writing a couple of plugins myself i have come to a couple of guidelines about how to set them up. If you are interested in adding support for your own syntax highlighting problem or language this section is of interest to you. B If you choose to build a plugin completely from scratch, your module needs to meet the following requirements. - If you want to write a formal addition to Tk::CodeText, your plugin must be in the namespace Tk::CodeText::YourSyntax. - The constructor is called 'new', and it should accept a reference a reference to a list of rules as parameters. - The following methods will be called upon by Tk::CodeText: highlight, stateCompare, rules, setSate, getState, syntax. More information about those methods is available in the documentation of Tk::CodeText::None and Tk::CodeText::Template. Good luck, you're on your own now. B For many highlighting problems Tk::CodeText::Template provides a nice basis to start from. Your code could look like this: package Tk::CodeText::MySyntax; use strict; use base('Tk::CodeText::Template'); sub new { my ($proto, $wdg, $rules) = @_; my $class = ref($proto) || $proto; Next, specify the set of hardcoded rules. if (not defined($rules)) { $rules = [ ['Tagname1', -foreground => 'red'], ['Tagname1', -foreground => 'red'], ]; }; Call the constructor of Tk::CodeText::Template and bless your object. my $self = $class->SUPER::new($rules); So now we have the SUPER class avalable and we can start defining a couple of things. You could add a couple of lists, usefull for keywords etc. $self->lists({ 'Keywords' => ['foo', 'bar'], 'Operators' => ['and', 'or'], }); For every tag you have to define a corresponding callback like this. $self->callbacks({ 'Tagname1' => \&Callback1, 'Tagname2' => \&Callback2, }); You have to define a default tagname like this: $self->stackPush('Tagname1'); Perhaps do a couple of other things but in the end, wrap up the new method. bless ($self, $class); return $self; } Then you need define the callbacks that are mentioned in the B hash. When you just start writing your plugin i suggest you make them look like this: sub callback1 { my ($self $txt) = @_; return $self->parserError($txt); #for debugging your later additions } Later you add matching statements inside these callback methods. For instance, if you want I to parse spaces it is going to look like this: sub callback1 { my ($self $txt) = @_; if ($text =~ s/^(\s+)//) { #spaces $self->snippetParse($1, 'Tagname1'); #the tagname here is optional return $text; } return $self->parserError($txt); #for debugging your later additions } If I is the callback that is called by default, you have to add the mechanism for checking lists to it. Hnce, the code will look like this: sub callback1 { my ($self $txt) = @_; if ($text =~ s/^(\s+)//) { #spaces $self->snippetParse($1, 'Tagname1'); #the tagname here is optional 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 } return $self->parserError($txt); #for debugging your later additions } Have a look at the code of Tk::CodeText::Bash. Things should clear up. And then, last but not least, you need a B method. B An example of this approach is the Perl syntax module. Also with this approach you will have to meet the minimum criteria as set out in the B section. =cut =head1 AUTHOR =over 4 =item Hans Jeuken (haje@toneel.demon.nl) =back =cut =head1 BUGS Unknown. If you find any, please contact the author. =cut =head1 TODO =over 4 =item Find and eliminate bugs. =item Add additional language modules. I am going to need help on this one. =item Optimize highlighting methods. Syntax highlighting consumes a lot of system resources. Squeezing every bit of performance out of it might make it less sluggish on slow systems, like a pentium at 100Mhz. If you're interested in this module, please have a look at the code and point out to me where I might have overlooked something. Of special interest are the CodeText methods B and B as well as the code of the language modules. =back =cut =head1 SEE ALSO =over 4 =item B, B, B, B B =back =cut Tk-CodeText-0.3.4/samples/Perl.test0100755000076400001440000003253010026043260015712 0ustar hajeuserspackage Tk::CodeText; 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 'CodeText'; 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('', sub { $cw->highlightVisual }); $cw->bind('', 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::CodeText::$syntax; \$plug = new Tk::CodeText::$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/CodeText/*.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::CodeText::$name; \$fm = new Tk::CodeText::$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__ Tk-CodeText-0.3.4/Makefile.PL0100644000076400001440000000151210032317712014411 0ustar hajeusersuse strict; use ExtUtils::MakeMaker; my $pm = 'CodeText'; my $ld = '$(INST_LIBDIR)'; WriteMakefile( NAME => "Tk::$pm", PREREQ_PM => { 'Tk' => '800.024', 'Syntax::Highlight::Perl' => 0, }, # PMLIBDIRS => ['Tk'], PM => { "$pm.pm" => "$ld/$pm.pm", "$pm/Bash.pm" => "$ld/$pm/Bash.pm", "$pm/HTML.pm" => "$ld/$pm/HTML.pm", "$pm/None.pm" => "$ld/$pm/None.pm", "$pm/Perl.pm" => "$ld/$pm/Perl.pm", "$pm/Pod.pm" => "$ld/$pm/Pod.pm", "$pm/Template.pm" => "$ld/$pm/Template.pm", "$pm/Xresources.pm" => "$ld/$pm/Xresources.pm", "$pm.pod" => "$ld/$pm.pod", "RulesEditor.pm" => "$ld/RulesEditor.pm", }, VERSION_FROM => "$pm.pm", 'dist' => {COMPRESS => 'gzip', SUFFIX => 'gz'}, ($] >= 5.005 ? (ABSTRACT => "a TextUndo widget with syntax highlight capabilities", AUTHOR => 'Hans Jeuken (haje@toneel.demon.nl)') : ()), ); Tk-CodeText-0.3.4/META.yml0100644000076400001440000000057410032317765013727 0ustar hajeusers# http://module-build.sourceforge.net/META-spec.html #XXXXXXX This is a prototype!!! It will change in the future!!! XXXXX# name: Tk-CodeText version: 0.3.4 version_from: CodeText.pm installdirs: site requires: Syntax::Highlight::Perl: 0 Tk: 800.024 distribution_type: module generated_by: ExtUtils::MakeMaker version 6.17 Tk-CodeText-0.3.4/CHANGES0100644000076400001440000000353610031371052013436 0ustar hajeusersTk::CodeText module changes log 27 march 2004 removed -headerbackground bug from RulesEditor renamed test.pl to demo.pl so testing without a connection to an X-server will not fail. 17 march 2004 Update to version 0.3.2 Added a decent test suite. Added support for bash. Modified Tk::CodeText::Template.pm to support a more structured approach for writing plugins. Things are backwards compatible. Plugins that inherit Tk::CodeText::Template also don't need to specify a 'syntax' method any more. Rewrote the rules editor, put it in a separate module. Numerous small changes and additions 22 April 2003 Update to version 0.3.1 Added slant option to rules editor. Corrected couple of mistakes in the documentation. 17 April 2003 Update to version 0.3.0 Modified clipboard handling. Added support for Pod and Xresources files Modified plugin protocol Modified highlighting algorithm Added '-updatecall' option. Fixed bug in rules editor. 03 March 2003 Update to version 0.2.0. Updated documentation. Renamed a number of methods so they make sense. Added test.pl. Improved Makefile.PL. Fixed bug in selectionModify. -rules option now also available at create time. Added support for HTML. Created rules editor and provided methods for storing and retrieving rules. Added Syntax option to the View-menu. Switching syntax on the fly now possible. Scanning now also checked with highlighting. -matchoptions can now also be specified as space separated string. Now you can also specify it in your Xresources file. 09 February 2003 Update to version 0.1.2 Fixed yview bug. Removed unneccessary keybinding Added capabilities for matching curlies/braces/brackets 07 February 2003 Update to version 0.1.1 Fixed bug that made highlighting fail in overstrike mode. Improved documentation. 02 February 2003 First alpha version 0.1 Tk-CodeText-0.3.4/RulesEditor.pm0100755000076400001440000002367610031371111015250 0ustar hajeusers{ package Tk::TBrowseEntry; use base qw(Tk::Derived Tk::BrowseEntry); Construct Tk::Widget 'TBrowseEntry'; sub LabEntryWidget { "Entry" } sub Populate { my ($cw, $args) = @_; my $sub = $args->{'-browsecmd'}; unless(defined($sub)) { $sub = {}}; $cw->SUPER::Populate($args); $cw->Subwidget('entry')->bind('', $sub); $cw->Subwidget('entry')->bind('', $sub); $cw->ConfigSpecs( -background => ['SELF', 'DESCENDANTS'], DEFAULT => [$cw->Subwidget('entry')], ); } } { package Tk::OptionLine; use base qw(Tk::Derived Tk::Frame); use strict; Construct Tk::Widget 'OptionLine'; sub Populate { my ($cw,$args) = @_; $cw->SUPER::Populate($args); my @padding = ( -padx => 2, -pady => 2, ); my $b = $cw->Checkbutton( -anchor => 'w', -width => 10, -onvalue => 1, -offvalue => 0, -command => sub { $cw->togglestate }, )->pack(@padding, -side => 'left', ); $cw->Advertise('status' => $b); my $f = $cw->Frame( )->pack(@padding, -side => 'left', -fill => 'both', -expand => 1, -padx => 2, -pady => 2, ); $cw->Advertise('fields' => $f); $cw->ConfigSpecs( -background => ['SELF', 'DESCENDANTS'], -borderwidth => [$cw, $f], -command => ['PASSIVE', undef, undef, sub {}], -relief => [$cw, $f], -text => [$b], -variable => [$b], DEFAULT => [$cw], ); $cw->togglestate; } sub togglestate { my $cw = shift; my $v = $cw->Subwidget('status')->cget('-variable'); my $dv = $$v; if ($dv) { $cw->setstate('normal'); } else { $cw->setstate('disabled'); } } sub setstate { my ($cw, $state) = @_; my @w = $cw->Subwidget('fields')->children; foreach my $c (@w) { $c->configure(-state => $state); } } }#end of package OptionLine { package Tk::OptionColor; use base qw(Tk::Derived Tk::OptionLine); use strict; Construct Tk::Widget 'OptionColor'; sub Populate { my ($cw,$args) = @_; $cw->SUPER::Populate($args); my @padding = ( -padx => 2, -pady => 2, ); my $f = $cw->Subwidget('fields'); my $value = ''; my $v = $f->Entry( -textvariable => \$value, -width => 20, )->pack(@padding, -side => 'left', -expand => 1, -fill => 'x', ); my $cmd = sub { my $c = $cw->cget('-command'); &$c; }; $v->bind('', $cmd); $v->bind('', $cmd); $f->Button( -bitmap => '@' . Tk->findINC('cbxarrow.xbm'), -command => sub { if (my $c = $cw->chooseColor(-initialcolor => $value)) { $cw->content($c); } } )->pack(@padding, -side => 'left' )->pack(@padding, -side => 'left', ); $cw->ConfigSpecs( -textvariable => ['PASSIVE', undef, undef, \$value], -background => ['SELF', 'DESCENDANTS'], DEFAULT => [$cw], ); } sub content { my $cw = shift; my $v = $cw->cget('-textvariable'); if (@_) { $$v = shift; my $cmd = $cw->cget('-command'); if (defined($cmd)) { &$cmd($$v); } } return $$v; } }#end of package OptionColor { package Tk::OptionFont; use base qw(Tk::Derived Tk::OptionLine); use strict; Construct Tk::Widget 'OptionFont'; sub Populate { my ($cw,$args) = @_; $cw->SUPER::Populate($args); my @padding = ( -padx => 2, -pady => 2, ); my $f = $cw->Subwidget('fields'); my $family = ''; my $size = '10'; my $weight = 'normal'; my $slant = 'roman'; my @fonts = sort $cw->fontFamilies; my $cmd = sub { my $c = $cw->cget('-command'); &$c; }; my $v = $f->TBrowseEntry( -browsecmd => $cmd, -variable => \$family, -width => 20, -choices => [ @fonts ], )->pack( -side => 'left', -expand => 1, -fill => 'x', ); my @sizes = qw(0 2 3 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 33 34 36 40 44 48 50 56 64 72); $f->TBrowseEntry( -browsecmd => $cmd, -variable => \$size, -listwidth => 20, -width => 3, -choices => \@sizes, )->pack(#@padding, -side => 'left', ); $f->Checkbutton( -command => $cmd, -variable => \$weight, -text => 'Bold', -onvalue => 'bold', -offvalue => 'normal', )->pack(#@padding, -side => 'left', ); $f->Checkbutton( -variable => \$slant, -command => $cmd, -text => 'Italic', -onvalue => 'italic', -offvalue => 'roman', )->pack(#@padding, -side => 'left', ); $cw->ConfigSpecs( -background => ['SELF', 'DESCENDANTS'], -familyvar => ['PASSIVE', undef, undef, \$family], -sizevar => ['PASSIVE', undef, undef, \$size], -slantvar => ['PASSIVE', undef, undef, \$slant], -weightvar => ['PASSIVE', undef, undef, \$weight], DEFAULT => [$cw], ); } sub content { my $cw = shift; my %t = ( '-family' => '-familyvar', '-size' => '-sizevar', '-slant' => '-slantvar', '-weight' => '-weightvar', ); if (@_) { my $o = shift; my %args = (@$o); foreach my $k (keys %args) { my $op = $t{$k}; my $v = $cw->cget($op); $$v = $args{$k} } my $cmd = $cw->cget('-command'); if (defined($cmd)) { &$cmd($o); } } my @res = (); foreach my $k (keys %t) { my $v = $cw->cget($t{$k}); push @res, $k, $$v; }; return \@res; } }#end of package OptionFont package Tk::RulesEditor; use strict; use base qw(Tk::Derived Tk::Toplevel); Construct Tk::Widget 'RulesEditor'; use File::Basename; require Tk::HList; require Tk::Adjuster; sub Populate { my ($cw,$args) = @_; my $widget = delete $args->{'-widget'}; unless (defined($widget)) { $widget = $cw->parent; } $args->{'-title'} = $widget->cget('-syntax') . ' - Rules editor'; $cw->SUPER::Populate($args); my @padding = ( -padx => 2, -pady => 2, ); my $synfr = $cw->Frame( -relief => 'groove', -borderwidth => 2, )->pack(@padding, -side => 'bottom', -fill => 'x', ); $synfr->Button( -text => 'Close', -command => sub { $cw->destroy }, )->pack(@padding, -side => 'right', ); $synfr->Button( -text => 'Apply', -command => sub { $cw->apply } )->pack(@padding, -side => 'right', ); my $tagfr = $cw->LabFrame( -label => 'Tag names', -labelside => 'acrosstop', )->pack( -side => 'left', -fill => 'both', ); my $taglist = $tagfr->Scrolled('HList', -browsecmd => sub { $cw->entryOpen(shift) }, -columns => 1, -scrollbars => 'osoe', )->pack(@padding, -expand => 1, -fill => 'both', ); my $rules = $widget->cget('-rules'); unless (defined($rules)) { $rules = $widget->highlightPlug->rules; } foreach my $rl (@$rules) { my @r = @$rl; my $tag = shift @r; $taglist->add($tag, -text => $tag, -data => \@r, ); } my $oppn = $cw->LabFrame( -label => 'Options', -labelside => 'acrosstop', )->pack( -side => 'left', -expand => 1, -fill => 'both', ); my $df = $oppn->Frame( -borderwidth => 2, -relief => 'groove', )->pack(@padding, -side => 'bottom', -expand => 1, -fill => 'both', ); my $d = $df->Entry( )->pack(@padding, -expand => 1, -fill => 'both' ); $cw->Advertise('display' => $d); my @fields = ('-foreground', '-background'); my %flags = (); foreach my $fld (@fields) { my $flag = 0; $flags{$fld} = \$flag, my $b = $oppn->OptionColor( -variable => \$flag, -class => 'Frame', -borderwidth => 2, -relief => 'groove', -command => sub { $cw->entryOpen($cw->cget('-current')); }, -text => $fld, )->pack(@padding, -fill => 'x'); $b->togglestate; $cw->Advertise($fld => $b); } my $fl = 0; $flags{'-font'} = \$fl; my $font = $oppn->OptionFont( -variable => \$fl, -class => 'Frame', -borderwidth => 2, -relief => 'groove', -text => '-font', -command => sub { $cw->entryOpen($cw->cget('-current')); }, )->pack(@padding, -fill => 'x'); $font->togglestate; $cw->Advertise('-font' => $font); $cw->ConfigSpecs( -background => ['SELF', 'DESCENDANTS'], -current => ['PASSIVE', undef, undef, ''], -flags => ['PASSIVE', undef, undef, \%flags], -widget => ['PASSIVE', undef, undef, $widget], -sampletext => [{-text => $d}, 'sampletext', 'Sampletext', 'ABCDEFGHIJabcdefghij0123456789'], DEFAULT => ['SELF'], ); $cw->Delegates( 'DEFAULT' => $taglist, ); } sub apply { my $cw = shift; my @tree = $cw->infoChildren; my @res = (); foreach my $c (@tree) { my $d = $cw->entrycget($c, '-data'); push @res, [$c, @$d]; } my $widget = $cw->cget('-widget'); $widget->configure(-rules => \@res); $widget->rulesSave; $widget->highlightPlug; } sub entryClose { my $cw = shift; my $s = $cw->cget('-current'); if ($s) { $cw->entrySync; $cw->configure('-current' => ''); my @l = ('-foreground', '-background', '-font'); foreach my $o (@l) { my $w = $cw->Subwidget($o); my $flags = $cw->cget('-flags'); my $flag = $flags->{$o}; $$flag = 0; my $widget = $cw->cget('-widget'); my $display = $cw->Subwidget('display'); if ($o eq '-font') { my $font = $widget->cget('-font'); my $f = [ -family => $widget->fontActual($font, '-family'), -size => abs($widget->fontActual($font, '-size')), -weight => $widget->fontActual($font, '-weight'), -slant => $widget->fontActual($font, '-slant'), ]; $w->content($f); $display->configure('-font' => $f); } else { my $c = $widget->cget($o); $w->content($c); $display->configure($o => $c); } $w->togglestate; } } } sub entryOpen { my ($cw, $entry) = @_; $cw->entryClose; if ($entry) { my $data = $cw->entrycget($entry, '-data'); my %opt = (@$data); foreach my $o (keys %opt) { my $w = $cw->Subwidget($o); my $flags = $cw->cget('-flags'); my $flag = $flags->{$o}; $$flag = 1; $w->content($opt{$o}); $w->togglestate; } $cw->Subwidget('display')->configure(%opt); $cw->configure('-current' => $entry); } } sub entrySync { my $cw = shift; my $c = $cw->cget('-current'); if ($c) { my @l = ('-foreground', '-background', '-font'); my @data = (); foreach my $i (@l) { my $w = $cw->Subwidget($i); my $flag = $w->cget('-variable'); my $f = $$flag; if ($f) { push @data, $i; push @data, $w->content; } }; $cw->entryconfigure($c, -data => \@data); } } 1;Tk-CodeText-0.3.4/CodeText.pod0100755000076400001440000003526110026047515014701 0ustar hajeusers =head1 NAME Tk::CodeText - a TextUndo widget with syntax highlighting capabilities =head1 SYNOPSIS =over 4 use Tk; require Tk::CodeText; my $m = new MainWindow; my $e = $m->Scrolled('CodeText', -disablemenu => 1, -syntax => 'Perl', -scrollbars => 'se', )->pack(-expand => 1, -fill => 'both'); $m->configure(-menu => $e->menu); $m->MainLoop; =back =head1 DESCRIPTION Tk::CodeText inherits Tk::TextUndo and all its options and methods. Besides syntax highlighting, methods are provided for commenting and uncommenting as well as indenting and unindenting a selected area, matching pairs of braces, brackets and brackets and curlies and automatic indenting of new lines. Syntax highlighting is done through a plugin approach. Adding languages is a matter of writing plugin modules. Theoretically this is not limited to programming languages. The plugin approach could also provide the possibility for grammar or spell checking in spoken languages. Currently there is support for B, B, B, B, and B. =head1 OPTIONS =over 4 =item Name: B =item Class: B =item Switch: B<-autoindent> Boolean, when you press the enter button, should the next line begin at the same position as the current line or not. By default B. =item Name: B =item Class: B =item Switch: B<-commentchar> By default "#". =item Name: B =item Class: B =item Switch: B<-disablemenu> Boolean, by default 0. In case you don't want the menu under the right mouse button to pop up. =item Name: B =item Class: B =item Switch: B<-indentchar> By default "\t". =item Name: B =item Class: B =item Switch: B<-match> string of pairs for brace/bracket/curlie etc matching. If this description doesn't make anything clear, don't worry, the default setting will: '[]{}()' if you don't want matching to be available, simply set it to ''. =item Name: B =item Class: B =item Switch: B<-matchoptions> Options list for the tag 'Match'. By default: [-background => 'red', -foreground => 'yellow'] You can also specify this option as a space separated string. Might come in handy for your Xresource files. "-background red -foreground yellow" =item Name: not available =item Class: not available =item Switch B<-rules> Specify the color and font options for highlighting. You specify a list looking a bit like this. [ ['Tagname1', @options1], ['Tagname2', @options2], ] The names of the tags are depending on the syntax that is highlighted. See the language modules for more information about this data structure. =item Name: rulesdir =item Class: Rulesdir =item Switch B<-rulesdir> Specify the directory where this widget stores its coloring defenitions. Files in this directory are stored as "HTML.rules", "Perl.rules" etc. By default it is set to '', which means that when you switch syntax the highlighting rules are not loaded or stored. The hard coded defaults in the language modules will be used. =item Name: B =item Class: B =item Switch: B<-syntax> Specifies the language for highlighting. At this moment the possible values are B, B, B, B and B. By default B Alternatively it is possible to specify a reference to your independent plugin. =item Name: Not available =item Class: Not available =item Switch: B<-updatecall> Here you can specify a callback that will be executed whenever the insert cursor has moved or text has been modified, so your application can keep track of position etc. Don't make this callback to heavy, the widget will get sluggish quickly. =back There are some undocumented options. They are used internally. It is propably best to leave them alone. =cut =head1 METHODS =over 4 =item B Checks the indention of the previous line and indents the line where the cursor is equally deep. =item B(I<$begin>, I<$end>); Does syntax highlighting on the section of text indicated by $begin and $end. $begin and $end are linenumbers not indexes! =item B>(I<$begin>, I<$end>); An insert or delete has taken place affecting the section of text between $begin and $end. B is being called after and insert or delete operation. $begin and $end (again linenumbers, not indexes) indicate the section of text affected. B checks what needs to be highlighted again and does the highlighting. =item B(I<$line>); Does syntax highlighting on linenumber $line. =item B Checks wether the appropriate highlight plugin has been loaded. If none or the wrong one is loaded, it loads the correct plugin. It returns a reference to the plugin loaded. It also checks wether the rules have changed. If so, it restarts highlighting from the beginning of the text. =item B Loads and initalizes a highlighting plugin. First it checks the value of the B<-syntax> option to see which plugin should be loaded. Then it checks wether a set of rules is defined to this plugin in the B<-rules> option. If not, it tries to obtain a set of rules from disk using B. If this fails as well it will use the hardcoded rules from the syntax plugin. =item B(I<$line>); Tells the widget that the text from linenumber $line to the end of the text is not to be considered highlighted any more. =item B Calls B to see what part of the text is visible on the display, and adjusts highlighting accordingly. =item B(I<$index>); Returns the linenumber part of an index. You may also specify indexes like 'end' or 'insert' etc. =item B Checks wether the character that is just before the 'insert'-mark should be matched, and if so should it match forwards or backwards. It then calls B. =item B(I<$direction>, I<$char>, I<$match>, I<$start>, I<$stop>); Matches $char to $match, skipping nested $char/$match pairs, and displays the match found (if any). =item B Pops up a window that enables the user to set the color and font options for the current syntax. =item B Checks wether the file $text->cget('-rulesdir') . '/' . $text->cget('-syntax') . '.rules' exists, and if so attempts to load this as a set of rules. =item B Saves the currently loaded rules as $text->cget('-rulesdir') . '/' . $text->cget('-syntax') . '.rules' =item B Comment currently selected text. =item B Indent currently selected text. =item B Used by the other B methods to do the actual work. =item B Uncomment currently selected text. =item B Unindent currently selected text. =back =head1 SYNTAX HIGHLIGHTING This section is a brief description of how the syntax highlighting process works. B The highlighting plugin is only then initiated when it is needed. When some highlighting needs to be done, the widget calls B to retrieve a reference to the plugin. B checks wether a plugin is present. Next it will check whether the B<-rules> option has been specified or wether the B<-rules> option has changed. If no rules are specified in B<-rules>, it will look for a pathname in the B<-rulesdir> option. If that is found it will try to load a file called '*.rules', where * is the value of B<-syntax>. If no plugin is present, or the B<-syntax> option has changed value, B loads the plugin. and constructs optionally giving it a reference to the found rules as parameter. if no rules are specified, the plugin will use its internal hardcoded defaults. B A set of rules is a list, containing lists of tagnames, followed by options. If you want to see what they look like, you can have a look at the constructors of each plugin module. Every plugin has a fixed set of tagnames it can handle. There are two ways to change the rules. You can invoke the B method, which is also available through the B menu. The result is a popup in which you can specify color and font options for each tagname. After pressing 'Ok', the edited rules will be applied. If B<-rulesdir> is specified, the rules will be saved on disk as I. You can also use B to specify a new set of rules. In this you have ofcause more freedom to use all available tag options. For more details about those there is a nice section about tag options in the Tk::Text documentation. After the call to B it is wise to call B. B Syntax highlighting is done in a lazy manor. Only that piece of text is highlighted that is needed to present the user a pretty picture. This is done to minimize use of system resources. Highlighting is running on the foreground. Jumping directly to the end of a long fresh loaded textfile may very well take a couple of seconds. Highlighting is done on a line to line basis. At the end of each line the highlighting status is saved in the list in B<-colorinf>, so when highlighting the next line, the B method of B will know how to begin. The line that needs highlighting is offered to the B method of the plugin. This method returns a list of offset and tagname pairs. Take for example the following line of perl code. my $mother = 'older than i am'; The B method of the Perl plugin will return the following list; (2 => 'Reserved', #'my' is a reserved word 1 => 'DEFAULT', #Space 7 => 'Variable', #$mother 1 => 'DEFAULT', #Space 1 => 'Operator', #'=' 1 => 'DEFAULT', #Space 17 => 'String', #'older than i am' 1 => 'DEFAULT',) #; The B method of CodeText will then mark positions 0 to 2 as 'Reserved', positions 2 to 3 as 'DEFAULT', positions 3 to 10 as 'Variable', etcetera. =cut =head1 WRITING PLUGINS After writing a couple of plugins myself i have come to a couple of guidelines about how to set them up. If you are interested in adding support for your own syntax highlighting problem or language this section is of interest to you. B If you choose to build a plugin completely from scratch, your module needs to meet the following requirements. - If you want to write a formal addition to Tk::CodeText, your plugin must be in the namespace Tk::CodeText::YourSyntax. - The constructor is called 'new', and it should accept a reference a reference to a list of rules as parameters. - The following methods will be called upon by Tk::CodeText: highlight, stateCompare, rules, setSate, getState, syntax. More information about those methods is available in the documentation of Tk::CodeText::None and Tk::CodeText::Template. Good luck, you're on your own now. B For many highlighting problems Tk::CodeText::Template provides a nice basis to start from. Your code could look like this: package Tk::CodeText::MySyntax; use strict; use base('Tk::CodeText::Template'); sub new { my ($proto, $wdg, $rules) = @_; my $class = ref($proto) || $proto; Next, specify the set of hardcoded rules. if (not defined($rules)) { $rules = [ ['Tagname1', -foreground => 'red'], ['Tagname1', -foreground => 'red'], ]; }; Call the constructor of Tk::CodeText::Template and bless your object. my $self = $class->SUPER::new($rules); So now we have the SUPER class avalable and we can start defining a couple of things. You could add a couple of lists, usefull for keywords etc. $self->lists({ 'Keywords' => ['foo', 'bar'], 'Operators' => ['and', 'or'], }); For every tag you have to define a corresponding callback like this. $self->callbacks({ 'Tagname1' => \&Callback1, 'Tagname2' => \&Callback2, }); You have to define a default tagname like this: $self->stackPush('Tagname1'); Perhaps do a couple of other things but in the end, wrap up the new method. bless ($self, $class); return $self; } Then you need define the callbacks that are mentioned in the B hash. When you just start writing your plugin i suggest you make them look like this: sub callback1 { my ($self $txt) = @_; return $self->parserError($txt); #for debugging your later additions } Later you add matching statements inside these callback methods. For instance, if you want I to parse spaces it is going to look like this: sub callback1 { my ($self $txt) = @_; if ($text =~ s/^(\s+)//) { #spaces $self->snippetParse($1, 'Tagname1'); #the tagname here is optional return $text; } return $self->parserError($txt); #for debugging your later additions } If I is the callback that is called by default, you have to add the mechanism for checking lists to it. Hnce, the code will look like this: sub callback1 { my ($self $txt) = @_; if ($text =~ s/^(\s+)//) { #spaces $self->snippetParse($1, 'Tagname1'); #the tagname here is optional 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 } return $self->parserError($txt); #for debugging your later additions } Have a look at the code of Tk::CodeText::Bash. Things should clear up. And then, last but not least, you need a B method. B An example of this approach is the Perl syntax module. Also with this approach you will have to meet the minimum criteria as set out in the B section. =cut =head1 CONTRIBUTIONS If you have written a plugin, i will be happy to include it in the next release of Tk::CodeText. If you send it to me, please have it accompanied with the sample of code that you used for testing. =head1 AUTHOR =over 4 =item Hans Jeuken (haje@toneel.demon.nl) =back =cut =head1 BUGS Unknown. If you find any, please contact the author. =cut =head1 TODO =over 4 =item Add additional language modules. I am going to need help on this one. =item HTML and Xresources plugins need rewriting. =item The sample files in the test suite should be set up so that conformity with the language specification can actually be verified. =back =cut =head1 SEE ALSO =over 4 =item B, B, B, B B, B, B =back =cut Tk-CodeText-0.3.4/MANIFEST0100644000076400001440000000110110031370540013557 0ustar hajeusersMANIFEST Makefile.PL demo.pl README CHANGES CodeText.pm CodeText.pod CodeText/Bash.pm CodeText/Perl.pm CodeText/None.pm CodeText/HTML.pm CodeText/Template.pm CodeText/Pod.pm CodeText/Xresources.pm RulesEditor.pm samples/Bash.test samples/Perl.test samples/Pod.test samples/HTML.test samples/Xresources.test t/Tk_RulesEditor.t t/Tk_CodeText.t t/Tk_CodeText_Perl.t t/Tk_CodeText_Bash.t t/Tk_CodeText_None.t t/Tk_CodeText_HTML.t t/Tk_CodeText_Template.t t/Tk_CodeText_Pod.t t/Tk_CodeText_Xresources.t META.yml Module meta-data (added by MakeMaker) Tk-CodeText-0.3.4/CodeText.pm0100755000076400001440000003252210032317645014531 0ustar hajeuserspackage Tk::CodeText; use vars qw($VERSION); $VERSION = '0.3.4'; use base qw(Tk::Derived Tk::TextUndo); use strict; use Storable; use File::Basename; Construct Tk::Widget 'CodeText'; 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('', sub { $cw->highlightVisual }); $cw->bind('', 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::CodeText::$syntax; \$plug = new Tk::CodeText::$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/CodeText/*.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::CodeText::$name; \$fm = new Tk::CodeText::$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__