::hl_tclTop

The hl_tcl package is a syntax highlighter for Tcl/Tk code.

It can be applied to a Tk text widget or to a static html page.

The Tk text widget may be made read-only or editable. Also, the hl_tcl may take an argument, sort of command to watch the viewing / editing.

When applied to html pages, the hl_tcl highlights Tcl/Tk code snippets embedded between <code> </code> tags.

The hl_tcl has highlighted its own code in Reference.


Some of blah-blahhl_tcl, Top

The Tcl being incredibly dynamic language sets a lot of problems before any Tcl syntax highlighter. Probably, the usage of quotes and esp. the strings spanning several lines are the main challenges.

Below is a line that brings most (not hl_tcl, as seen in Reference) of Tcl highlighters in a stupor:


if {[set i [string first {"} $line $i]]==-1} {return no}

... as well as this one:


regsub -all {(([^A-Z@]|\\@)[.?!]("|'|'')?([])])?) } $fieldText {\1 } fieldText

Good luck for a highlighter when the second line (or similar) follows the first, giving it a matching quote and thus bringing it out of the stupor.

Those orphan quotes are often used in regexp and regsub Tcl commands, so that when a honest Tcl highlighter (like Geany) stumbles upon an orphan quote, it tries its best to highlight the rest of code as a string, till the next unmatched quote.

Thus, we have

... instead of

There are "tricky" highlighters (like Gedit) that behave more wisely at the stumbling an orphan quote: they permit only a one-line Tcl strings (if not continued with \), so that the string highlighting would be most likely finished in the same line it started. No problems except for this silly line. And no delays due to the highlighting the rest of code...

... as seen in:


Some of editorshl_tcl, Top

Geany. Probably, the best Tcl highlighter. And the great programming tool at that. Still, it has few drawbacks:

  • doesn't highlight the above mentioned Tcl lines properly
  • doesn't highlight ${var} in contrast with $var
  • tries to highlight any (even hexidecimal) number it encounters, thus set a 1fix or set b #abxxx looks a bit peculiar
  • set c {{#000} #FFF} is quite a legal Tcl command as well as set c {#000 #FFF}, not for Geany
  • no highlighting TclOO (method, my, mixin etc.)

Vim. Probably, the fastest Tcl highlighter. Great and awful. Nonetheless:

  • tricky with those above mentioned Tcl lines
  • doesn't highlight ttk commands (Tk only) and TclOO
  • tries to highlight every bit of Tcl, e.g. set set set is highlighted as three set commands ;)
  • as a result, much more florid than most of others

Kate. As nearly good as Geany. As nearly florid as Vim (set set set). Doesn't highlight ttk and TclOO.

TKE. Written in Tcl/Tk, it might be the best of all to highlight the Tcl/Tk. In spite of its suspended state it still can. Issues with highlighting strings and the performance.

Pluma and Gedit seem to use the same Tcl highlighting engine that gives rather good results. Still, the mentioned above drawbacks are here too. And no highlighting of tk, ttk, TclOO.

Notepad++. Very fast Tcl highlighter. And very basic. All the same drawbacks. No highlighting of tk, ttk, TclOO. Plus an obsolete version of Tcl, i.e. no highlighting lset, lassign etc.


What can we do?hl_tcl, Top

To develop an ideal (correct and fast) Tcl/Tk highlighter, we would have to dive into Tcl core. Though, no hopes to achieve the ideal through repeating the core in Tcl/Tk or massively using the regular expressions.

That said, while implementing Tcl/Tk highlighter in pure Tcl/Tk, we might hope to achieve a reasonable compromise between the performance and the elimination of blunders.

It seems hl_tcl got close to this compromise. Specifically, it provides:

  • special highlighting for Tcl and TclOO commands
  • special highlighting for Tk and ttk commands
  • allowing additional commands to highlight (as Tk ones)
  • special highlighting for declarations proc, method, oo::class etc. as well as return, yield
  • special highlighting for #comments, $variables, "strings", -options
  • in-line comments being recognized and thus highlighted only after ;#
  • proper handling of most regexp and regsub expressions containing a quote
  • highlighting the multi-line strings, with possible switching this mode off (a-la Gedit) to improve the performance
  • customizing colors of the highlighting
  • highlighting viewable/editable Tk text widget and static html pages
  • good performance at editing 1000-4000 LOC and rather acceptable for 4000-9000 LOC
  • even monstrous 10000 LOC and more are handled fast at the "tricky" mode a-la Gedit

The hl_tcl doesn't provide the following:

  • highlighting numbers
  • highlighting brackets, except for matched ones and inside the strings

These are in no way critical drawbacks. A little less florid Tcl code might be even preferable for other tastes.

The Tcl can arrange its pitfalls for hl_tcl (I know where). Also, tricky practices or tastes can make a fool of hl_tcl. Still hopefully these pranks are few and rare to encounter.


Use for text widgethl_tcl, Top

The code below:


package require hl_tcl proc ::stub {args} {puts "stub: $args"} ::hl_tcl::hl_init $::txt -readonly yes -cmd ::stub #... inserting a text into the text widget ::hl_tcl::hl_text $::txt

sets an example of hl_tcl usage. Here are the details:

  • ::stub is a procedure to watch the text editing; here it simply puts out the text's last index;
  • hl_init is called before filling the text widget with a Tcl code; it sets the highlighting options and disables the highlighting till hl_text runs;
  • hl_text runs to highlight the Tcl code of the text widget and to view/edit it.

The hl_init takes arguments:

  • txt is the text widget's path
  • args contains options of text widget (omittable)

The args is a list of -option "value" where -option may be:

  • -colors - list of colors: clrCOM, clrCOMTK, clrSTR, clrVAR, clrCMN, clrPROC, clrOPT
  • -dark - flag "dark background of text", i.e. simplified -colors (default "no")
  • -font - attributes of text font
  • -readonly - flag "text is read-only" (default "no")
  • -multiline - flag "multi-line strings" (default "yes")
  • -cmd - command to watch editing/viewing (default "")
  • -cmdpos - command to watch cursor positioning (default "")
  • -seen - number of first lines seen at start (default 500)
  • -optRE - flag "use a regular expression to highlight options" (default "yes")
  • -keywords - additional commands to highlight (as Tk ones)
  • -dobind - if true, forces keys binding at repeating calls of hl_init
  • -plaintext - true for plain texts with no highlighting
  • -plaincom - a command for plain highlighting line by line

Note: -seen 500 and -multiline no can improve the performance a lot. It's recommended to use -seen 500 (or any other reasonable limit, e.g. -seen 200) at any rate, except for static html pages.

A command for -plaincom option has two arguments: a current text's path and a current line's number. It should highlight the current line and return true, otherwise (if the current line is Tcl code) it returns false. An example of its usage is presented by alited editor (lib/addon directory).

The rest of hl_tcl procedures are:

  • hl_all updates all highlighted existing text widgets, e.g. at changing a color scheme of application
  • hl_readonly gets/sets a read-only mode and/or a command to watch a text widget at viewing/editing it
  • hl_colors gets a list of colors for highlighting

See details in Reference.


Use for static htmlhl_tcl, Top

In the hl_tcl.zip, there is a Tcl script named tcl_html.tcl that highlights Tcl snippets of static html page(s).

It runs as follows:


tclsh tcl_html.tcl "glob-pattern-of-html-files"

For example:


tclsh ~/UTILS/hl_tcl/tcl_html.tcl "~/UTILS/mulster/tasks/ruff/src/*"

In this example, the html files are located in ~/UTILS/mulster/tasks/ruff/src.

Perhaps, you would want to modify the tcl_html.tcl, this way:

  • replace "no" with "yes" for dark html pages
  • replace <code class="tcl"> with html tags starting the Tcl code in your html files
  • replace </code> with html tags finishing the Tcl code in your html files

These are arguments of ::hl_tcl_html::highlight procedure.

The tag pairs can be multiple if the html pages contain them, e.g.


::hl_tcl_html::highlight $fhtml "no" {<code class="tcl">} {</code>} {<pre class="code">} {</pre>}

Linkshl_tcl, Top

Note that hl_tcl is still disposed to update.


Commandshl_tcl, Top




addingColors [::hl_tcl]hl_tcl, Top

Sets/gets colors for a text syntax highlighting.

addingColors ?dark? ?txt? ?cs?
Parameters
darkyes, if the current theme is dark; optional, default ""
txtpath to the text or {}; optional, default ""
cscolor scheme; optional, default ""
Description

If txt omitted, returns a list of resting colors. The resting colors are:

  • current line's background
  • #TODO and #! comment's foreground

proc ::hl_tcl::addingColors {{dark {}} {txt {}} {cs {}}} { # Sets/gets colors for a text syntax highlighting. # dark - yes, if the current theme is dark # txt - path to the text or {} # cs - color scheme # If *txt* omitted, returns a list of resting colors. # The resting colors are: # - current line's background # - #TODO and #! comment's foreground variable my::data # try to get color options from current apave settings if {[catch {set clrCURL [lindex [::apave::obj csGet $cs] 16]}]} { set clrCURL {} } if {$dark eq {}} { if {[catch {set dark [::apave::obj csDark]}]} { set dark no } } if {$dark} { if {$clrCURL eq {}} {set clrCURL #29383c} set clrCMN2 #ff7272 } else { if {$clrCURL eq {}} {set clrCURL #efe0cd} set clrCMN2 #ff0000 } if {$txt eq {}} { return [list $clrCURL $clrCMN2] } set my::data(COLORS,$txt) [list {*}[hl_colors $txt] $clrCURL $clrCMN2] }




cget [::hl_tcl]hl_tcl, Top

Gets a highlighting option's value.

cget txt opt
Parameters
txttext's path
optoption's name

proc ::hl_tcl::cget {txt opt} { # Gets a highlighting option's value. # txt - text's path # opt - option's name variable my::data set opt [string toupper [string trimleft $opt -]] if {[info exists my::data($opt,$txt)]} { return $my::data($opt,$txt) } return {} }




clearup [::hl_tcl]hl_tcl, Top

Clears data related to text (esp. at deleting it).

clearup txt
Parameters
txttext's path

proc ::hl_tcl::clearup {txt} { # Clears data related to text (esp. at deleting it). # txt - text's path variable my::data foreach key [array names my::data *,$txt] { unset my::data($key) } foreach i [lsearch -all -exact -index 0 $my::data(LIST_TXT) $txt] { set my::data(LIST_TXT) [lreplace $my::data(LIST_TXT) $i $i] } }




configure [::hl_tcl]hl_tcl, Top

Sets a highlighting option's value.

configure txt opt val
Parameters
txttext's path
optoption's name
valoption's value

proc ::hl_tcl::configure {txt opt val} { # Sets a highlighting option's value. # txt - text's path # opt - option's name # val - option's value variable my::data set opt [string toupper [string trimleft $opt -]] set my::data($opt,$txt) $val }




hl_all [::hl_tcl]hl_tcl, Top

Updates ("rehighlights") all highlighted and existing text widgets.

hl_all ?args?
Parameters
argsdict of options
See also

hl_init


proc ::hl_tcl::hl_all {args} { # Updates ("rehighlights") all highlighted and existing text widgets. # args - dict of options # See also: hl_init if {[info exists ::hl_tcl::my::data(LIST_TXT)]} { foreach wattrs $::hl_tcl::my::data(LIST_TXT) { lassign $wattrs txt ro com2 if {[winfo exists $txt]} { if {![info exists ::hl_tcl::my::data(SETCOLORS,$txt)]} { unset ::hl_tcl::my::data(COLORS,$txt) ;# colors defined by DARK } # args (if set) override the appropriate settings for $txt hl_init $txt -- {*}$args hl_text $txt } } } return }




hl_colorNames [::hl_tcl]hl_tcl, Top

Returns a list of color names for syntax highlighting.

hl_colorNames
Return value

Returns a list of color names for syntax highlighting.


proc ::hl_tcl::hl_colorNames {} { # Returns a list of color names for syntax highlighting. return [list clrCOM clrCOMTK clrSTR clrVAR clrCMN clrPROC clrOPT clrBRA] }




hl_colors [::hl_tcl]hl_tcl, Top

Gets/sets the main colors for highlighting (except for "curr.line").

hl_colors txt ?dark? ?args?
Parameters
txttext widget's path or {} or an index of default colors
darkflag "dark scheme" optional, default ""
argsa list of colors to set for txt
Return value

Returns a list of colors for COM COMTK STR VAR CMN PROC OPT BRAC or, if the colors aren't initialized, "standard" colors.


proc ::hl_tcl::hl_colors {txt {dark {}} args} { # Gets/sets the main colors for highlighting (except for "curr.line"). # txt - text widget's path or {} or an index of default colors # dark - flag "dark scheme" # args - a list of colors to set for *txt* # Returns a list of colors for COM COMTK STR VAR CMN PROC OPT BRAC or, if the colors aren't initialized, "standard" colors. if {[llength $args]} { set ::hl_tcl::my::data(COLORS,$txt) $args return } if {[info exists ::hl_tcl::my::data(COLORS,$txt)]} { return $::hl_tcl::my::data(COLORS,$txt) } if {$dark eq {}} {set dark $::hl_tcl::my::data(DARK,$txt)} if {![string is integer -strict $txt] || $txt<0 || $txt>3} {set txt 0} if {$dark} {set dark 1} {set dark 0} return [lindex $::hl_tcl::my::data(SYNTAXCOLORS,$txt) $dark] }




hl_commands [::hl_tcl]hl_tcl, Top

Lists all Tcl/Tk commands registered here.

hl_commands

proc ::hl_tcl::hl_commands {} { # Lists all Tcl/Tk commands registered here. variable my::data return [list {*}$my::data(PROC_TCL) {*}$my::data(CMD_TCL) {*}$my::data(CMD_TK)] }




hl_init [::hl_tcl]hl_tcl, Top

Initializes highlighting.

hl_init txt ?args?
Parameters
txttext widget's path
argsdict of options
Description

The 'args' options include:

--means that only args' options will be initialized (defaults skipped)
-darkflag "the text widget has dark background"
-readonlyflag "read-only"
-optREflag "use of RE to highlight options"
-multilineflag "allowed multi-line strings"
-cmdcommand to watch editing/viewing
-cmdposcommand to watch cursor positioning
-colorslist of colors as set in hl_tcl::hl_colorNames
-fontattributes of font
-seenlines seen at start
-keywordsadditional commands to highlight (as Tk ones)
-dobindif yes, forces key bindings

This procedure has to be called before writing a text in the text widget.

See also

hl_colorNames


proc ::hl_tcl::hl_init {txt args} { # Initializes highlighting. # txt - text widget's path # args - dict of options # The 'args' options include: # -- - means that only args' options will be initialized (defaults skipped) # -dark - flag "the text widget has dark background" # -readonly - flag "read-only" # -optRE - flag "use of RE to highlight options" # -multiline - flag "allowed multi-line strings" # -cmd - command to watch editing/viewing # -cmdpos - command to watch cursor positioning # -colors - list of colors as set in hl_tcl::hl_colorNames # -font - attributes of font # -seen - lines seen at start # -keywords - additional commands to highlight (as Tk ones) # -dobind - if yes, forces key bindings # This procedure has to be called before writing a text in the text widget. # See also: hl_colorNames if {[set setonly [expr {[lindex $args 0] eq {--}}]]} { set args [lrange $args 1 end] } iscurline $txt 1 set ::hl_tcl::my::data(REG_TXT,$txt) {} ;# disables Modified at changing the text set ::hl_tcl::my::data(KEYWORDS,$txt) {} set ::hl_tcl::my::data(DOBIND,$txt) 0 foreach {opt val} {-dark 0 -readonly 0 -cmd {} -cmdpos {} -optRE 1 -dobind 0 -multiline 1 -seen 500 -plaintext no -plaincom {} -insertwidth 2 -keywords {}} { if {[dict exists $args $opt]} { set val [dict get $args $opt] } elseif {$setonly} { continue ;# only those set in args are taken into account } set ::hl_tcl::my::data([string toupper [string range $opt 1 end]],$txt) $val } set ::hl_tcl::my::data(CMD_TK_EXP) [lsort [list {*}$::hl_tcl::my::data(CMD_TK) {*}$::hl_tcl::my::data(KEYWORDS,$txt)]] unset ::hl_tcl::my::data(KEYWORDS,$txt) if {[dict exists $args -colors]} { set colors [dict get $args -colors] lassign [addingColors $::hl_tcl::my::data(DARK,$txt)] clrCURL clrCMN2 if {[set llen [llength $colors]]==8} { lappend colors $clrCURL ;# add curr.line color if omitted } if {$llen==9} { lappend colors $clrCMN2 ;# add #TODO color if omitted } set ::hl_tcl::my::data(COLORS,$txt) $colors set ::hl_tcl::my::data(SETCOLORS,$txt) 1 } else { if {![info exists ::hl_tcl::my::data(COLORS,$txt)]} { addingColors $::hl_tcl::my::data(DARK,$txt) $txt } } if {!$setonly} { if {[dict exists $args -font]} { set ::hl_tcl::my::data(FONT,$txt) [dict get $args -font] } else { set ::hl_tcl::my::data(FONT,$txt) [font actual TkFixedFont] } set ::hl_tcl::my::data(ISPLAINCOM,$txt) [expr {$::hl_tcl::my::data(PLAINCOM,$txt) ne {}}] } if {!$setonly || [dict exists $args -readonly]} { hl_readonly $txt $::hl_tcl::my::data(READONLY,$txt) } if {[string first ::hl_tcl:: [bind $txt]]<0} { my::BindToEvent $txt <FocusIn> ::hl_tcl::my::ShowCurrentLine $txt } set ::hl_tcl::my::data(_INSPOS_,$txt) {} my::MemPos $txt return }




hl_line [::hl_tcl]hl_tcl, Top

Updates a current line's highlighting.

hl_line txt
Parameters
txttext's path

proc ::hl_tcl::hl_line {txt} { # Updates a current line's highlighting. # txt - text's path if {!$::hl_tcl::my::data(PLAINTEXT,$txt)} { set ln0 [expr {int([$txt index insert])}] set ln2 [expr {int([$txt index end])}] set ln1 [expr {max (1,$ln0-1)}] set ln2 [expr {min ($ln2,$ln0+1)}] # update lines: previous, current, next ::hl_tcl::my::RunCoroAfterIdle $txt $ln1 $ln2 no } ::hl_tcl::my::MemPos $txt yes $txt configure -insertwidth $::hl_tcl::my::data(INSERTWIDTH,$txt) return }




hl_readonly [::hl_tcl]hl_tcl, Top

Makes the text widget be readonly or gets its 'read-only' state.

hl_readonly txt ?ro? ?com2?
Parameters
txttext widget's path
roflag "the text widget is readonly" optional, default -1
com2command to be called at viewing and after changes; optional, default ""
Description

If 'ro' argument is omitted, returns the widget's 'read-only' state.


proc ::hl_tcl::hl_readonly {txt {ro -1} {com2 {}}} { # Makes the text widget be readonly or gets its 'read-only' state. # txt - text widget's path # ro - flag "the text widget is readonly" # com2 - command to be called at viewing and after changes # If 'ro' argument is omitted, returns the widget's 'read-only' state. if {$ro==-1} { return [expr {[info exists ::hl_tcl::my::data(READONLY,$txt)] && $::hl_tcl::my::data(READONLY,$txt)}] } set ::hl_tcl::my::data(READONLY,$txt) $ro if {$com2 ne {}} {set ::hl_tcl::my::data(CMD,$txt) $com2} set newcom "::$txt.internal" if {[info commands $newcom] eq ""} {rename $txt $newcom} set com "[namespace current]::my::Modified $txt" #if {$com2 ne ""} {append com " ; $com2"} if {$ro} {proc ::$txt {args} " if {!\[winfo exists $txt\]} {return 0} ; switch -exact -- \[lindex \$args 0\] \{ insert \{$com2\} delete \{$com2\} replace \{$com2\} default \{ return \[eval $newcom \$args\] \} \}" } else {proc ::$txt {args} " if {!\[winfo exists $txt\]} {return 0} ; switch -exact -- \[lindex \$args 0\] \{ delete \{$com {*}\$args\} insert \{$com {*}\$args\} replace \{$com {*}\$args\} \} ; set _res_ \[eval $newcom \$args\] ; return \$_res_" } return }




hl_text [::hl_tcl]hl_tcl, Top

Highlights Tcl code of a text widget.

hl_text txt
Parameters
txttext widget's path

proc ::hl_tcl::hl_text {txt} { # Highlights Tcl code of a text widget. # txt - text widget's path set font0 $::hl_tcl::my::data(FONT,$txt) set font1 [set font2 $font0] $txt tag configure tagSTD -font "$font0" $txt tag add tagSTD 1.0 end dict set font1 -weight bold dict set font2 -slant italic lassign $::hl_tcl::my::data(COLORS,$txt) clrCOM clrCOMTK clrSTR clrVAR clrCMN clrPROC clrOPT clrBRA clrCURL clrCMN2 $txt tag configure tagCOM -font "$font1" -foreground $clrCOM $txt tag configure tagCOMTK -font "$font1" -foreground $clrCOMTK $txt tag configure tagSTR -font "$font0" -foreground $clrSTR $txt tag configure tagVAR -font "$font0" -foreground $clrVAR $txt tag configure tagCMN -font "$font2" -foreground $clrCMN $txt tag configure tagCMN2 -font "$font2" -foreground $clrCMN2 ;#red $txt tag configure tagPROC -font "$font1" -foreground $clrPROC $txt tag configure tagOPT -font "$font0" -foreground $clrOPT $txt tag configure tagBRACKET -font "$font0" -foreground $clrBRA $txt tag configure tagBRACKETERR -font "$font0" -foreground white -background red $txt tag configure tagCURLINE -background $clrCURL $txt tag raise sel $txt tag raise tagBRACKETERR catch {$txt tag raise hilited; $txt tag raise hilited2} ;# for apave package my::HighlightAll $txt if {![info exists ::hl_tcl::my::data(BIND_TXT,$txt)] || [info exists ::hl_tcl::my::data(DOBIND,$txt)] && $::hl_tcl::my::data(DOBIND,$txt)} { my::BindToEvent $txt <FocusIn> ::hl_tcl::my::MemPos $txt my::BindToEvent $txt <KeyPress> ::hl_tcl::my::MemPos1 $txt yes %K %s my::BindToEvent $txt <KeyRelease> ::hl_tcl::my::MemPos $txt my::BindToEvent $txt <ButtonRelease-1> ::hl_tcl::my::MemPos $txt foreach ev {Enter KeyRelease ButtonRelease-1} { my::BindToEvent $txt <$ev> ::hl_tcl::my::HighlightBrackets $txt } set ::hl_tcl::my::data(BIND_TXT,$txt) yes } set ro $::hl_tcl::my::data(READONLY,$txt) set com2 $::hl_tcl::my::data(CMD,$txt) set txtattrs [list $txt $ro $com2] if {![info exists ::hl_tcl::my::data(LIST_TXT)] || [set i [lsearch -index 0 -exact $::hl_tcl::my::data(LIST_TXT) $txt]]==-1} { lappend ::hl_tcl::my::data(LIST_TXT) $txtattrs } else { set ::hl_tcl::my::data(LIST_TXT) [lreplace $::hl_tcl::my::data(LIST_TXT) $i $i $txtattrs] } hl_readonly $txt $ro $com2 return }




iscurline [::hl_tcl]hl_tcl, Top

Sets / gets "highlight a current line" flag for a text.

iscurline txt ?flag?
Parameters
txtthe text's path
flagthe flag; optional, default ""

proc ::hl_tcl::iscurline {txt {flag {}}} { # Sets / gets "highlight a current line" flag for a text. # txt - the text's path # flag - the flag return [my::IsCurline $txt $flag] }




isdone [::hl_tcl]hl_tcl, Top

Checks if the highlighting of the text is done.

isdone txt
Parameters
txttext's path

proc ::hl_tcl::isdone {txt} { # Checks if the highlighting of the text is done. # txt - text's path variable my::data return [expr {[info exist my::data(REG_TXT,$txt)] && $my::data(REG_TXT,$txt) ne {}}] }



::hl_tcl::myTop

The ::hl_tcl::my namespace contains procedures for the "internal" usage by hl_tcl package.

All of them are upper-cased, in contrast with the UI procedures of hl_tcl namespace.


Commandsmy, Top




AuxEnding [::hl_tcl::my]my, Top

Auxiliary procedure to process the ending comments in the line.

AuxEnding kName lineName iName
Parameters
kNamevariable's name for 'k'
lineNamevariable's name for 'line'
iNamevariable's name for 'i'
See also

HighlightLine


proc ::hl_tcl::my::AuxEnding {kName lineName iName} { # Auxiliary procedure to process the ending comments in the line. # kName - variable's name for 'k' # lineName - variable's name for 'line' # iName - variable's name for 'i' # See also: HighlightLine upvar 1 $kName k $lineName line $iName i if {[set k [string first # $line $i]]>-1 && [string index [string trimleft $line] 0] eq {#}} { return 1 } # not found a full line comment => try to find "good" ending comments i.e. ";# ..." # at that even proper comments like # if {cond} { #... # } # are skipped as "bad" set k [lindex [regexp -inline -indices {;\s*#} [string range $line $i end]] 0 0] if {$k eq {}} { set k -1 return 0 } set k [expr {$k+$i+1}] return 1 }




BindToEvent [::hl_tcl::my]my, Top

Binds an event on a widget to a command.

BindToEvent w event ?args?
Parameters
wthe widget's path
eventthe event
argsthe command

proc ::hl_tcl::my::BindToEvent {w event args} { # Binds an event on a widget to a command. # w - the widget's path # event - the event # args - the command if {[string first $args [bind $w $event]]<0} { bind $w $event [list + {*}$args] } return }




CoroHighlightAll [::hl_tcl::my]my, Top

Highlights all of a text as a coroutine.

CoroHighlightAll txt
Parameters
txttext widget's path
See also

HighlightAll


proc ::hl_tcl::my::CoroHighlightAll {txt} { # Highlights all of a text as a coroutine. # txt - text widget's path # See also: HighlightAll variable data catch { ;# $txt may be destroyed, so catch this if {!$data(PLAINTEXT,$txt)} { set tlen [lindex [split [$txt index end] .] 0] RemoveTags $txt 1.0 end set maxl [expr {min($data(SEEN,$txt),$tlen)}] set maxl [expr {min($data(SEEN,$txt),$tlen)}] for {set currQtd [set ln [set lnseen 0]]} {$ln<$tlen} {} { incr ln set currQtd [HighlightLine $txt $ln $currQtd] if {[incr lnseen]>$data(SEEN,$txt)} { set lnseen 0 after idle after 1 [info coroutine] yield } } } } set data(REG_TXT,$txt) {1} return }




CoroModified [::hl_tcl::my]my, Top

Handles modifications of text.

CoroModified txt ?i1? ?i2? ?args?
Parameters
txttext widget's path
i11st index of changes; optional, default -1
i22nd index of changes; optional, default -1
argsarguments for a command called after the modifications
See also

Modified


proc ::hl_tcl::my::CoroModified {txt {i1 -1} {i2 -1} args} { # Handles modifications of text. # txt - text widget's path # i1 - 1st index of changes # i2 - 2nd index of changes # args - arguments for a command called after the modifications # See also: Modified catch { variable data # current line: set ln [expr {int([$txt index insert])}] # ending line: set endl [expr {int([$txt index {end -1 char}])}] # range of change: if {$i1!=-1} { set dl [expr {abs($i2-$i1)}] set ln $i1 } else { set dl [expr {abs(int($data(CUR_LEN,$txt)) - $endl)}] } # begin and end of changes: set ln1 [set lno1 [expr {max(($ln-$dl),1)}]] set ln2 [set lno2 [expr {min(($ln+$dl),$endl)}]] lassign [CountQSH $txt $ln] cntq cnts ccmnt # flag "highlight to the end": set bf1 [expr {abs($ln-int($data(CURPOS,$txt)))>1 || $dl>1 || $cntq!=$data(CNT_QUOTE,$txt) || $ccmnt!=$data(CNT_COMMENT,$txt)}] set bf2 [expr {$cnts!=$data(CNT_SLASH,$txt)}] if {$bf1 && !$data(MULTILINE,$txt) || $bf2} { set lnt1 $ln set lnt2 [expr {$ln+1}] while {$ln2<$endl && $lnt1<$endl && $lnt2<=$endl && ( [$txt get "$lnt1.end -1 char" $lnt1.end] in {\\ \"} || [$txt get "$lnt2.end -1 char" $lnt2.end] in {\\ \"}) || $bf2} { incr lnt1 ;# next lines be handled too, if ended with "\\" incr lnt2 incr ln2 set bf2 0 } } set tSTR [$txt tag ranges tagSTR] set tCMN [$txt tag ranges tagCMN] lappend tCMN {*}[$txt tag ranges tagCMN2] if {$ln1==1} { set currQtd 0 } else { set currQtd [LineState $txt $tSTR $tCMN "$ln1.0 -1 chars"] } $txt tag add tagSTD $ln1.0 $ln2.end if {!$data(PLAINTEXT,$txt)} { set lnseen 0 while {$ln1<=$ln2} { if {$ln1==$ln2} { set bf2 [LineState $txt $tSTR $tCMN "$ln1.end +1 chars"] } RemoveTags $txt $ln1.0 $ln1.end set currQtd [HighlightLine $txt $ln1 $currQtd] if {$ln1==$ln2 && ($bf1 || $bf2!=$currQtd) && $data(MULTILINE,$txt)} { set ln2 $endl ;# run to the end } if {[incr lnseen]>$data(SEEN,$txt)} { set lnseen 0 catch {after cancel $data(COROATFER,$txt)} set data(COROATFER,$txt) [after idle after 1 [info coroutine]] yield } incr ln1 } } if {[set cmd $data(CMD,$txt)] ne {}} { # run a command after changes done (its arguments are txt, ln1, ln2) append cmd { } $txt { } $lno1 { } $lno2 { } $args after idle $cmd } MemPos $txt } return }




CoroRun [::hl_tcl::my]my, Top

CoroRun txt pos1 pos2 ?args?
Parameters
txtNot documented.
pos1Not documented.
pos2Not documented.
argsOptional arguments.

proc ::hl_tcl::my::CoroRun {txt pos1 pos2 args} { variable data if {![info exist data(REG_TXT,$txt)] || $data(REG_TXT,$txt) eq {} || ![info exist data(CUR_LEN,$txt)]} { # skip changes till the highlighting done after 10 [list ::hl_tcl::my::RunCoroAfterIdle $txt $pos1 $pos2 yes {*}$args] return } # let them work one by one set i1 [expr {int($pos1)}] set i2 [expr {int($pos2)}] set coroNo [expr {[incr data(CORMOD)] % 10000000}] coroutine CoModified$coroNo ::hl_tcl::my::CoroModified $txt $i1 $i2 {*}$args return }




CountChar [::hl_tcl::my]my, Top

Counts a character in a string.

CountChar str ch ?plistName? ?escaped?
Parameters
strthe string
chthe character
plistNamevariable name for a list of positions of ch; optional, default ""
escapedtrue, if the character is escaped; optional, default yes
Return value

Returns a number of any occurences of character ch in string str if the character is escaped, but if it is not escaped, only non-escaped characters are counted.


proc ::hl_tcl::my::CountChar {str ch {plistName {}} {escaped yes}} { # Counts a character in a string. # str - the string # ch - the character # plistName - variable name for a list of positions of *ch* # escaped - true, if the character is escaped. # Returns a number of any occurences of character *ch* in string *str* # if the character is escaped, but if it is not escaped, only non-escaped # characters are counted. if {$plistName ne {}} { upvar 1 $plistName plist set plist [list] } set icnt [set begidx 0] while {[set idx [string first $ch $str]] >= 0} { set nidx $idx if {$escaped || ![Escaped $str $idx]} { incr icnt if {$plistName ne {}} {lappend plist [expr {$begidx+$idx}]} } incr begidx [incr idx] set str [string range $str $idx end] } return $icnt }




CountQSH [::hl_tcl::my]my, Top

Counts quotes, slashes, hashes in a line

CountQSH txt ln
Parameters
txttext widget's path
lnline's index

proc ::hl_tcl::my::CountQSH {txt ln} { # Counts quotes, slashes, hashes in a line # txt - text widget's path # ln - line's index set ln [expr {int($ln)}] set st [$txt get $ln.0 $ln.end] return [list [CountChar $st \"] [CountChar $st \\] [CountChar $st #]] }




Escaped [::hl_tcl::my]my, Top

Checks if a character is escaped in a string.

Escaped line curpos
Parameters
linethe string
curposposition of the character in the line
Return value

Returns 1 if the character is escaped in the string.


proc ::hl_tcl::my::Escaped {line curpos} { # Checks if a character is escaped in a string. # line - the string # curpos - position of the character in the line # Returns 1 if the character is escaped in the string. set line [string range $line 0 $curpos-1] set linetrim [string trimright $line \\] return [expr {([string length $line]-[string length $linetrim])%2}] }




FirstQtd [::hl_tcl::my]my, Top

Searches the quote characters in line.

FirstQtd lineName iName currQtd
Parameters
lineNamevariable's name for 'line'
iNamevariable's name for 'i'
currQtdyes, if searching inside the quoted
Return value

Returns "yes" if a quote character was found.


proc ::hl_tcl::my::FirstQtd {lineName iName currQtd} { # Searches the quote characters in line. # lineName - variable's name for 'line' # iName - variable's name for 'i' # currQtd - yes, if searching inside the quoted # Returns "yes" if a quote character was found. variable data upvar 1 $lineName line $iName i while {1} { if {[set i [string first \" $line $i]]==-1} {return no} if {[NotEscaped $line $i]} { if {$currQtd||$i==0} {return yes} set i1 [expr {$i-1}] set i2 [expr {$i+1}] if {[NotEscaped $line $i1]} { set c1 [string index $line $i1] ;# check the string ends set c2 [string index $line $i2] # not needed: $c1 in $data(S_BOTH) && $c2 ni $data(S_BOTH) || if {$c1 in $data(S_LEFT) && $c2 ni $data(S_RIGHT) || $c1 ni $data(S_LEFT) && $c2 in $data(S_RIGHT)} { return yes } # last reverence: for braced expression set i1 $i while {$i1>0} { set c1 [string index $line $i1-1] set c2 [string index $line $i1] if {$c1 in $data(S_SPACE)} {return [expr { $c2 ne "\{" }]} incr i1 -1 } return no } return yes } incr i } }




HighlightAll [::hl_tcl::my]my, Top

Highlights all of a text.

HighlightAll txt
Parameters
txttext widget's path
Description

Makes a coroutine from this.

See also

CoroHighlightAll


proc ::hl_tcl::my::HighlightAll {txt} { # Highlights all of a text. # txt - text widget's path # Makes a coroutine from this. # See also: CoroHighlightAll # let them work one by one: set coroNo [expr {[incr ::hl_tcl::my::data(CORALL)] % 10000000}] coroutine co_HlAll$coroNo ::hl_tcl::my::CoroHighlightAll $txt return }




HighlightBrackets [::hl_tcl::my]my, Top

Highlights matching brackets if any.

HighlightBrackets w
Parameters
wtext widget's path

proc ::hl_tcl::my::HighlightBrackets {w} { # Highlights matching brackets if any. # w - text widget's path variable data set curpos [ShowCurrentLine $w] set curpos2 [$w index {insert -1 chars}] set ch [$w get $curpos] set il [string first $ch $data(LBR)] set ir [string first $ch $data(RBR)] set txt [split [$w get 1.0 end] \n] if {$il>-1} { set brcpos [MatchedBrackets $w $txt $curpos [string index $data(LBR) $il] [string index $data(RBR) $il] 1] } elseif {$ir>-1} { set brcpos [MatchedBrackets $w $txt $curpos [string index $data(RBR) $ir] [string index $data(LBR) $ir] -1] } elseif {[set il [string first [$w get $curpos2] $data(LBR)]]>-1} { set curpos $curpos2 set brcpos [MatchedBrackets $w $txt $curpos [string index $data(LBR) $il] [string index $data(RBR) $il] 1] } elseif {[set ir [string first [$w get $curpos2] $data(RBR)]]>-1} { set curpos $curpos2 set brcpos [MatchedBrackets $w $txt $curpos [string index $data(RBR) $ir] [string index $data(LBR) $ir] -1] } else { return } if {$brcpos ne {}} { $w tag add tagBRACKET $brcpos $w tag add tagBRACKET $curpos } else { $w tag add tagBRACKETERR $curpos } return }




HighlightCmd [::hl_tcl::my]my, Top

Highlights Tcl/Tk commands.

HighlightCmd txt line ln pri i
Parameters
txttext widget's path
lineline to be highlighted
lnline number
pricolumn number to highlighted from
icurrent position in 'line'

proc ::hl_tcl::my::HighlightCmd {txt line ln pri i} { # Highlights Tcl/Tk commands. # txt - text widget's path # line - line to be highlighted # ln - line number # pri - column number to highlighted from # i - current position in 'line' variable data $txt tag add tagSTD "$ln.$pri" "$ln.$i +1 chars" if {$pri} { incr pri -1 set RE $data(RE1) } else { set RE $data(RE0) } set st [string range $line $pri $i-1] set lcom [regexp -inline -all -indices $RE $st] # commands foreach {- - lc -} $lcom { lassign $lc i1 i2 set c [string trim [string range $st $i1 $i2] "\{\}\[;\t "] set ik [expr {$i2-$i1+1-[string length $c]}] if {$c ne {}} { incr i1 $ik incr i2 if {[lsearch -exact -sorted $data(CMD_TCL) $c]>-1} { $txt tag add tagCOM "$ln.$pri +$i1 char" "$ln.$pri +$i2 char" } elseif {[lsearch -exact -sorted $data(PROC_TCL) $c]>-1} { if {$c eq {namespace} && ![regexp {^namespace[\s]+eval([\s]|$)+} [string range $st $i1 end]]} { set tag tagCOM ;# let "namespace eval" only be highlighted as proc/return } else { set tag tagPROC } $txt tag add $tag "$ln.$pri +$i1 char" "$ln.$pri +$i2 char" } elseif {[lsearch -exact -sorted $data(CMD_TK_EXP) $c]>-1} { $txt tag add tagCOMTK "$ln.$pri +$i1 char" "$ln.$pri +$i2 char" } } } # $variables: set dlist [list] set slen [expr {[string length $st]-1}] set cnt [CountChar $st \$ dlist no] foreach dl $dlist { if { [string index $st $dl+1] eq "\{" } { if {[set br2 [string first \} $st $dl+2]]!=-1} { $txt tag add tagVAR "$ln.$pri +$dl char" "$ln.$pri +[incr br2] char" } continue } for {set i [set dl2 $dl]} {$i<$slen} {} { incr i set ch [string index $st $i] if {[string is wordchar $ch] || $ch eq {:}} { set dl2 $i continue } elseif {$ch eq {(}} { if {[set br2 [string first {)} $st $i+1]]>-1} { set dl2 $br2 } } break } if {$dl2>$dl} { $txt tag add tagVAR "$ln.$pri +$dl char" "$ln.$pri +[incr dl2] char" } } # -options set dl -1 while {[set dl [string first - $st [incr dl]]]>-1} { if {[string index $st $dl-1] ni $data(S_SPACE2)} continue set idx1 "$ln.$pri +$dl char" if {[string index $st $dl+1] eq {-}} { incr dl ;# for --longoption } set i $dl set ch [string index $st $i+1] if {![string is alpha -strict $ch]} { ;# || ![string is ascii -strict $ch] continue ;# first, a Latin letter } set dl2 -1 while {$i<$slen} { incr i set ch [string index $st $i] if {![string is wordchar $ch] && $ch ne {-}} break set dl2 $i } if {$dl2>-1} { $txt tag add tagOPT $idx1 "$ln.$pri +[incr dl2] char" set dl $dl2 } } return }




HighlightComment [::hl_tcl::my]my, Top

Highlights comments.

HighlightComment txt line ln k
Parameters
txttext widget's path
linecurrent line
lnline's number
kcomment's starting position in line

proc ::hl_tcl::my::HighlightComment {txt line ln k} { # Highlights comments. # txt - text widget's path # line - current line # ln - line's number # k - comment's starting position in line variable data set stcom [string range $line $k end] if {[regexp $data(RETODO) $stcom]} { $txt tag add tagCMN2 $ln.$k $ln.end ;# "!" and TODO comments } else { $txt tag add tagCMN $ln.$k $ln.end } return }




HighlightLine [::hl_tcl::my]my, Top

Highlights a line in text.

HighlightLine txt ln prevQtd
Parameters
txttext widget's path
lnline's number
prevQtdflag of "being quoted" from the previous line

proc ::hl_tcl::my::HighlightLine {txt ln prevQtd} { # Highlights a line in text. # txt - text widget's path # ln - line's number # prevQtd - flag of "being quoted" from the previous line variable data if {$data(ISPLAINCOM,$txt)} { # plain highlighting: for the current line set res [{*}$data(PLAINCOM,$txt) $txt $ln $prevQtd] if {$res in {-1 0 1}} { return $res ;# to be continued in a next line with prevQtd } # if the line was highlighted okay, skip the highlighting as Tcl code if {$res} {return 0} # otherwise highlight it below as Tcl code } set line [$txt get $ln.0 $ln.end] if {$prevQtd==-1} { ;# comments continued HighlightComment $txt $line $ln 0 if {[string index $line end] ne "\\"} {set prevQtd 0} return $prevQtd } set currQtd $prevQtd ;# current state of being quoted set i [set pri [set lasti 0]] set k -1 while {1} { if {![FirstQtd line i $currQtd]} break set lasti $i if {$currQtd} { HighlightStr $txt $ln.$pri "$ln.$i +1 char" set currQtd 0 incr lasti if {[AuxEnding j line lasti]} { set i $lasti set st [string range $line $i $j] set it 0 if {[FirstQtd st it $currQtd]} continue ;# there is a quote yet set k $j break } } else { if {[AuxEnding j line pri] && $j<$i} { set lasti $pri set k $j break } HighlightCmd $txt $line $ln $pri $i set currQtd 1 } set pri $i incr i } if {$currQtd} { HighlightStr $txt $ln.$pri $ln.end } elseif {$k>-1 || [AuxEnding k line lasti]} { HighlightCmd $txt $line $ln $lasti $k HighlightComment $txt $line $ln $k if {[string index $line end] eq "\\"} {set currQtd -1} } else { HighlightCmd $txt $line $ln $lasti [string length $line] } if {!$data(MULTILINE,$txt) && $currQtd && [string index $line end] ne "\\"} { set currQtd 0 } return $currQtd }




HighlightStr [::hl_tcl::my]my, Top

Highlights strings.

HighlightStr txt p1 p2
Parameters
txttext widget's path
p1starting index of the string in 'txt'
p2ending index of the string in 'txt'

proc ::hl_tcl::my::HighlightStr {txt p1 p2} { # Highlights strings. # txt - text widget's path # p1 - starting index of the string in 'txt' # p2 - ending index of the string in 'txt' variable data set p1 [$txt index $p1] set p2 [$txt index $p2] $txt tag add tagSTR $p1 $p2 set st [$txt get $p1 $p2] set lcom [regexp -inline -all -indices $data(RE5) $st] foreach {lc g1 g2} $lcom { lassign $lc i1 i2 incr i2 while {$i1<$i2} { incr i1 if {[string first [string index $st $i1] "\[\]\$\{\}"]>-1} { set i12 [expr {$i1+1}] $txt tag add tagVAR "$p1 +$i1 char" "$p1 +$i12 char" } } } return }




InRange [::hl_tcl::my]my, Top

Checks if a text position is in a range of text positions.

InRange p1 p2 l ?c?
Parameters
p11st position of range
p22nd position of range
lline position to check (or 'l.c' if 'c' not set)
ccolumn position to check; optional, default -1

proc ::hl_tcl::my::InRange {p1 p2 l {c -1}} { # Checks if a text position is in a range of text positions. # p1 - 1st position of range # p2 - 2nd position of range # l - line position to check (or 'l.c' if 'c' not set) # c - column position to check if {$c==-1} {lassign [split $l .] l c} lassign [split $p1 .] l1 c1 lassign [split $p2 .] l2 c2 incr c2 -1 ;# text ranges are not right-inclusive return [expr { ($l>=$l1 && $l<$l2 && $c>=$c1) || ($l>$l1 && $l<=$l2 && $c<=$c2) || ($l==$l1 && $l1==$l2 && $c>=$c1 && $c<=$c2) || ($l>$l1 && $l<$l2)}] }




IsCurline [::hl_tcl::my]my, Top

Sets / gets "highlight a current line" flag for a text.

IsCurline txt ?flag?
Parameters
txtthe text's path
flagthe flag; optional, default ""

proc ::hl_tcl::my::IsCurline {txt {flag {}}} { # Sets / gets "highlight a current line" flag for a text. # txt - the text's path # flag - the flag variable data if {$flag eq {}} { if {[info exists data(HL_CURLINE,$txt)]} { set flag $data(HL_CURLINE,$txt) } else { set flag 0 } return $flag } set data(HL_CURLINE,$txt) $flag }




LineState [::hl_tcl::my]my, Top

Gets an initial state of line.

LineState txt tSTR tCMN l1
Parameters
txttext widget's path
tSTRranges of string tags
tCMNranges of comment tags
l1the line's index
Description

Returns: 0 if no tags for the line; 1 if the line is a string's continuation; -1 if the line is a comment's continuation.


proc ::hl_tcl::my::LineState {txt tSTR tCMN l1} { # Gets an initial state of line. # txt - text widget's path # tSTR - ranges of string tags # tCMN - ranges of comment tags # l1 - the line's index # Returns: 0 if no tags for the line; 1 if the line is a string's continuation; -1 if the line is a comment's continuation. variable data set i1 [$txt index $l1] if {[set prev [string first -1 $l1]]>-1} { set i1 [$txt index "$i1 -1 chars"] } set ch [$txt get "$i1" "$i1 +1 chars"] if {[SearchTag $tCMN [$txt index "$i1 -1 chars"]]!=-1} { ;# is a comment continues? if {$ch eq "\\"} {return -1} } elseif {$data(MULTILINE,$txt) || $ch eq "\\"} { ;# is a string continues? set nl [lindex [split $l1 .] 0] if {$prev>-1} { # is the start of line quoted? # Tk tag ranges refer only to non-empty lines # => previous two non-empty chars' coordinates are needed # to analize whether they: # - end the range # - are inside of the range # - begin the range set co1 [set co2 {}] while {$nl>1} { incr nl -1 if {[set line [$txt get $nl.0 $nl.end]] ne {}} { if {$co2 eq {}} { set co2 [$txt index "$nl.end -1 char"] if {[string length $line]>1} { set co1 [$txt index "$nl.end -2 char"] break } } else { set co1 [$txt index "$nl.end -1 char"] break } } } if {$co2 eq {}} {return 0} {set f2 [expr {[SearchTag $tSTR $co2]!=-1}]} if {$co1 eq {}} {set f1 $f2} {set f1 [expr {[SearchTag $tSTR $co1]!=-1}]} set ch [$txt get $co2 "$co2 +1 chars"] set c [lindex [split [$txt index $co2] .] 1] if {![NotEscaped $line $c]} {set ch {}} return [expr {$ch ne {"} && $f2 || $ch eq {"} && !$f1}] } # is the end of line quoted? set line {} set nltot [lindex [split [$txt index end] .] 0] while {$nl<$nltot} { incr nl if {[set line [$txt get $nl.0 $nl.end]] ne {}} break } set i1 $nl.0 set ch [$txt get $i1 "$i1 +1 chars"] set c [lindex [split [$txt index $i1] .] 1] if {![NotEscaped $line $c]} {set ch {}} set f1 [expr {[SearchTag $tSTR [$txt index $i1]]!=-1}] set f2 [expr {[SearchTag $tSTR [$txt index "$i1 +1 chars"]]!=-1}] return [expr {$ch ne {"} && $f1 || $ch eq {"} && !$f2}] } return 0 }




MatchedBrackets [::hl_tcl::my]my, Top

Finds a match of characters (dchar for schar).

MatchedBrackets w inplist curpos schar dchar dir
Parameters
wtext widget's path
inplistlist of strings where to find a match
curposposition of schar in nl.nc form where nl=1.., nc=0..
scharsource character
dchardestination character
dirsearch direction: 1 to the end, -1 to the beginning of list

proc ::hl_tcl::my::MatchedBrackets {w inplist curpos schar dchar dir} { # Finds a match of characters (dchar for schar). # w - text widget's path # inplist - list of strings where to find a match # curpos - position of schar in nl.nc form where nl=1.., nc=0.. # schar - source character # dchar - destination character # dir - search direction: 1 to the end, -1 to the beginning of list lassign [split $curpos .] nl nc if {$schar eq {"}} { set npos $nl.$nc set hlpr [$w tag prevrange tagSTR $npos] if {[llength $hlpr] && [$w compare "$npos +1 char" == [lindex $hlpr 1]]} { set dir -1 ;# <- quotes are scanned depending on their range (for tcl/c) } else { set hlpr [$w tag nextrange tagSTR $npos] if {![llength $hlpr] || [$w compare $npos != [lindex $hlpr 0]]} { # for plain texts: if {[$w search -exact \" "$npos +1 char" end] eq {}} { set dir -1 } else { set lfnd [$w search -backwards -all -exact \" $npos 1.0] if {[llength $lfnd] % 2} { set dir -1 } } } } incr nc $dir } set escaped [Escaped [lindex $inplist $nl-1] $nc] if {$dir==1} {set rng1 "$nc end"} else {set rng1 "0 $nc"; set nc 0} set retpos {} set scount [set dcount 0] incr nl -1 set inplen [llength $inplist] while {$nl>=0 && $nl<$inplen} { set line [lindex $inplist $nl] set line [string range $line {*}$rng1] set sc [CountChar $line $schar slist $escaped] set dc [CountChar $line $dchar dlist $escaped] set plen [llength [set plist [MergePosList -1 $slist $dlist]]] for {set i [expr {$dir>0?0:($plen-1)}]} {$i>=0 && $i<$plen} {incr i $dir} { lassign [lindex $plist $i] src pos if {$src} {incr dcount} {incr scount} if {$scount <= $dcount} { set retpos [incr nl].[incr pos $nc] break } } if {$retpos ne {}} break set nc 0 set rng1 {0 end} incr nl $dir } return $retpos }




MemPos [::hl_tcl::my]my, Top

Remembers the state of current line.

MemPos txt ?doit?
Parameters
txttext widget's path
doitargument for ShowCurrentLine; optional, default no
See also

ShowCurrentLine


proc ::hl_tcl::my::MemPos {txt {doit no}} { # Remembers the state of current line. # txt - text widget's path # doit - argument for ShowCurrentLine # See also: ShowCurrentLine variable data set data(_INSPOS_,$txt) [MemPos1 $txt no] set ln [ShowCurrentLine $txt $doit] set data(CUR_LEN,$txt) [$txt index {end -1 char}] lassign [CountQSH $txt $ln] data(CNT_QUOTE,$txt) data(CNT_SLASH,$txt) data(CNT_COMMENT,$txt) if {[$txt tag ranges tagBRACKET] ne {}} {$txt tag remove tagBRACKET 1.0 end} if {[$txt tag ranges tagBRACKETERR] ne {}} {$txt tag remove tagBRACKETERR 1.0 end} if {[set cmd $data(CMDPOS,$txt)] ne {}} { # run a command after changing position (with the state as arguments) append cmd " $txt $data(CUR_LEN,$txt) $ln $data(CNT_QUOTE,$txt) $data(CNT_SLASH,$txt) $data(CNT_COMMENT,$txt)" catch {after cancel $data(CMDATFER,$txt)} set data(CMDATFER,$txt) [after idle $cmd] } return }




MemPos1 [::hl_tcl::my]my, Top

Checks and sets the cursor's width, depending on its position.

MemPos1 txt ?donorm? ?K? ?s?
Parameters
txttext widget's path
donormif yes, forces "normal" cursor; optional, default yes
Kkey (%K of bind); optional, default ""
sstate (%s of bind); optional, default ""
Description

This fixes an issue with text cursor: less width at 0th column.


proc ::hl_tcl::my::MemPos1 {txt {donorm yes} {K {}} {s {}}} { # Checks and sets the cursor's width, depending on its position. # txt - text widget's path # donorm - if yes, forces "normal" cursor # K - key (%K of bind) # s - state (%s of bind) # This fixes an issue with text cursor: less width at 0th column. variable data if {$K eq {Home} && [string is digit -strict $s] && [expr {$s & 4}]==0 && [expr {$s & 1}]==0} { # Ctrl-Home & Shift-Home are passed set p1 [$txt index insert] set line [$txt get "$p1 linestart" "$p1 lineend"] set p [expr {[string length $line]-[string length [string trimleft $line]]}] set p2 [expr {int($p1)}].$p if {$p && $p2 ne $p1} { after idle "::tk::TextSetCursor $txt $p2" return 0 } } if {$data(INSERTWIDTH,$txt)==1} { if {[$txt cget -insertwidth]!=1} {$txt configure -insertwidth 1} return 0 } set insLC [$txt index insert] lassign [split $insLC .] L C if {$data(_INSPOS_,$txt) eq {}} { set L2 [set C2 0] } else { lassign [split $data(_INSPOS_,$txt) .] L2 C2 } if {$L!=$L2 || $C==0 || $C2==0} { if {$C || $donorm} { $txt configure -insertwidth $data(INSERTWIDTH,$txt) } else { $txt configure -insertwidth [expr {$data(INSERTWIDTH,$txt)*2-1}] } } return $insLC }




MergePosList [::hl_tcl::my]my, Top

Merges lists of numbers that are not-coinciding and sorted.

MergePosList none ?args?
Parameters
nonea number to be not allowed in the lists (e.g. less than minimal)
argslist of the lists to be merged
Return value

Returns a list of pairs: index of list + item of list.


proc ::hl_tcl::my::MergePosList {none args} { # Merges lists of numbers that are not-coinciding and sorted. # none - a number to be not allowed in the lists (e.g. less than minimal) # args - list of the lists to be merged # Returns a list of pairs: index of list + item of list. set itot [set ilist 0] set lind [set lout [list]] foreach lst $args { incr ilist incr itot [set llen [llength $lst]] lappend lind [list 0 $llen] } for {set i 0} {$i<$itot} {incr i} { set min $none set ind -1 for {set k 0} {$k<$ilist} {incr k} { lassign [lindex $lind $k] li llen if {$li < $llen} { set e [lindex [lindex $args $k] $li] if {$min == $none || $min > $e} { set ind $k set min $e set savli [incr li] set savlen $llen } } } if {$ind == -1} {return -code error {Error: probably in the input data}} lset lind $ind [list $savli $savlen] lappend lout [list $ind $min] } return $lout }




Modified [::hl_tcl::my]my, Top

Handles modifications of text.

Modified txt oper pos1 ?args?
Parameters
txttext widget's path
operNot documented.
pos1Not documented.
argsOptional arguments.
Description

Makes a coroutine from this.

See also

CoroModified


proc ::hl_tcl::my::Modified {txt oper pos1 args} { # Handles modifications of text. # txt - text widget's path # Makes a coroutine from this. # See also: CoroModified variable data set ar2 [lindex $args 0] set posins [$txt index insert] if {[catch {set pos1 [set pos2 [$txt index $pos1]]}]} { set pos1 [set pos2 $posins] } switch $oper { insert { set pos2 [expr {$pos1 + [llength [split $ar2 \n]]}] } delete { if {$ar2 eq {} || [catch {set pos2 [$txt index $ar2]}]} { set pos2 $posins } } } RunCoroAfterIdle $txt $pos1 $pos2 no {*}$args return }




NotEscaped [::hl_tcl::my]my, Top

Checks if a character escaped in a line.

NotEscaped line i
Parameters
lineline
ithe character's position in 'line'
Return value

Returns "1" if the character not escaped.


proc ::hl_tcl::my::NotEscaped {line i} { # Checks if a character escaped in a line. # line - line # i - the character's position in 'line' # Returns "1" if the character not escaped. set cntq 0 while {$i>0} { if {[string index $line [incr i -1]] ne "\\"} { return [expr {($cntq%2)==0}] } incr cntq } return [expr {($cntq%2)==0}] }




RemoveTags [::hl_tcl::my]my, Top

Removes tags in text.

RemoveTags txt from to
Parameters
txttext widget's path
fromstarting index
toending index

proc ::hl_tcl::my::RemoveTags {txt from to} { # Removes tags in text. # txt - text widget's path # from - starting index # to - ending index foreach tag {tagCOM tagCOMTK tagSTR tagVAR tagCMN tagCMN2 tagPROC tagOPT} { $txt tag remove $tag $from $to } return }




RunCoroAfterIdle [::hl_tcl::my]my, Top

Runs a "modified" corotine after idle.

RunCoroAfterIdle txt pos1 pos2 wait ?args?
Parameters
txtNot documented.
pos1Not documented.
pos2Not documented.
waitNot documented.
argsOptional arguments.

proc ::hl_tcl::my::RunCoroAfterIdle {txt pos1 pos2 wait args} { # Runs a "modified" corotine after idle. variable data if {$wait} { catch { after cancel $data(COROAFTER,$txt) if {$data(COROPOS1,$txt) < $pos1} {set pos1 $data(COROPOS1,$txt)} if {$data(COROPOS2,$txt) > $pos2} {set pos2 $data(COROPOS2,$txt)} } set data(COROPOS1,$txt) $pos1 set data(COROPOS2,$txt) $pos2 } set data(COROAFTER,$txt) [after idle "::hl_tcl::my::CoroRun $txt $pos1 $pos2 $args"] return }




SearchTag [::hl_tcl::my]my, Top

Searches a position in tag ranges.

SearchTag tagpos l1
Parameters
tagpostag position ranges
l1the position to find
Return value

Returns a found range's index of -1 if not found.


proc ::hl_tcl::my::SearchTag {tagpos l1} { # Searches a position in tag ranges. # tagpos - tag position ranges # l1 - the position to find # Returns a found range's index of -1 if not found. lassign [split $l1 .] l c set i 0 foreach {p1 p2} $tagpos { if {[InRange $p1 $p2 $l $c]} {return $i} incr i 2 } return -1 }




ShowCurrentLine [::hl_tcl::my]my, Top

Shows the current line.

ShowCurrentLine txt ?doit?
Parameters
txttext widget's path
doitif yes, forces updating current line's background; optional, default no
Return value

Returns a current position of cursor.


proc ::hl_tcl::my::ShowCurrentLine {txt {doit no}} { # Shows the current line. # txt - text widget's path # doit - if yes, forces updating current line's background # Returns a current position of cursor. variable data set pos [$txt index insert] set nlines [expr {int([$txt index end])}] lassign [split $pos .] ln cn if {[catch {lassign [split $data(CURPOS,$txt) .] ln2 cn2}]} { set ln2 $ln set cn2 $cn set data(CURPOS,$txt) [set data(NLINES,$txt) 0] } if {[IsCurline $txt]} { if {$doit || int($data(CURPOS,$txt))!=$ln || $data(NLINES,$txt)!=$nlines || $ln!=$ln2 || abs($cn-$cn2)>1 || $cn<2} { $txt tag remove tagCURLINE 1.0 end $txt tag add tagCURLINE [list $pos linestart] [list $pos lineend]+1displayindices } } set data(NLINES,$txt) $nlines set data(CURPOS,$txt) $pos return $pos }

Document generated by Ruff!