[Bryan Oakley] 28-Dec-2008

The code on this page implements a command that allows you to add text widget tags using regular expressions.This code is "smart", in that it makes use of the event loop to schedule units of work so that it may be used in real time to highlight text without affecting performance. 

Using this code it becomes fairly easy to implement a minimalist wiki-like markup language or to implement progressive searching. An example included on this page colorizes Tcl comments and variables, and provides a progressive search box.

======

package require Tk 8.5

# usage: 
#    tag::tag widget options pattern start end body
#    tag::cancel id
#
#    options may be one of -regexp, -elide, -nocase, -nolinestop, -exact
#    as defined for the search command of text widgets
#
#    start and end are text widget indices which define the range
#    of text in which to search.
#
#    In the script, the following substitutions will be made:
#    %W  path to the text widget
#    %s  the name of a tag that represents the beginning of a match
#    %e  the name of a tag that represents the end of a mach
#
#    tag::tag returns an id which may be passed to the cancel command
#    to cancel any pending actions.
# 
namespace eval tag {
    variable tagid 0
    variable afterid {}
}
    
proc tag::example {} {
    global search
    set search ""

    frame .toolbar
    label .l -text "Search string:"
    entry .e -textvariable ::search
    pack .l -in .toolbar -side left
    pack .e -in .toolbar -side left -fill both -expand true
    bind .e <Any-KeyRelease> [namespace code search]
    text .t -wrap none -background white
    pack .toolbar -side top -fill x
    pack .t -side top -fill both -expand true
    .t insert end "proc tag::tag {[info args tag]} {[info body tag]}"
    .t tag configure comment -foreground firebrick
    .t tag configure string -foreground \#007300
    .t tag configure variable -foreground blue

    tag .t -regexp {(^|;)\s*\#.*$} 1.0 end {
        %W tag add comment %s %e
    }
    tag .t -regexp {".*?"} 1.0 end {
        %W tag add string %s %e
    }
    tag .t -regexp {\${.*?}} 1.0 end {
        %W tag add variable %s %e
    }
    ::tag::tag .t -regexp {\$\w+} 1.0 end {
        %W tag add variable %s %e
    }

    proc search {} {
        variable id 

        if {![info exists id]} {set id ""}
        .t tag configure search -background blue -foreground white
        .t tag remove search 1.0 end
        tag::cancel $id
        if {$::search ne ""} {
            set id [tag::tag .t -exact -- $::search 1.0 end {
                %W tag add search %s %e
            }]
        }
    }
}

proc tag::tag {w args} {

    variable tagid

    incr tagid

    # the goal is to build up a text widget search command based on
    # the passed in arguments along with additional arguments needed
    # by this proc.
    set searchCommand [list $w search -count count]

    set supportedOptions [list -regexp -elide -nocase -nolinestop -exact --]
    while {[string match {-*} [lindex $args 0]]} {
        set arg [lindex $args 0]
        set args [lrange $args 1 end]
        if {$arg eq "--"} break
        set ::supportedOptions $supportedOptions
        if {[lsearch -glob $supportedOptions  $arg*] >= 0} {
            lappend searchCommand $arg
        } else {
            return -code error "bad switch \"$arg\""
        }
    }

    lassign $args pattern start end script
    set startMark _start$tagid
    set endMark _end$tagid

    set script [string map [list %W $w %s $startMark %e $endMark] $script]

    # These need to be in canonical form; if they are a mark they may
    # move as text is inserted or delete.
    set start [$w index $start]
    set end [$w index $end]

    # $startMark - mark that indentifies start of the matched text
    $w mark set $startMark $start
    $w mark gravity $startMark left

    # $endMark - mark that indentifies end of the matched text
    $w mark set $endMark $start
    $w mark gravity $endMark right

    # searchLimit - mark that identifies the end of the search region
    $w mark set searchLimit $end
    $w mark gravity searchLimit right

    lappend searchCommand -- $pattern $endMark searchLimit
            
    _doOneIteration $tagid $w $searchCommand $startMark $endMark $script 10

    return $tagid
}

proc ::tag::cancel {id} {
    variable afterid
    if {$id eq "all"} {
        foreach id [dict values $afterid] {
            after cancel $id
        }
        set afterid {}
    } else {
        if {[dict exists $afterid $id]} {
            after cancel [dict get $afterid $id]
            dict unset afterid $id
        }
    }
}

proc ::tag::_doOneIteration {id w searchCommand startMark endMark script limit} {
    variable afterid

    for {set i 0} {$limit == 0 || $i < $limit} {incr i} {
        dict unset afterid $id
        set index [eval $searchCommand]
        if {[string length $index] == 0} {
            return false
        }
        $w mark set $startMark $index
        $w mark set $endMark [$w index "$index + $count c"]

        uplevel \#0 $script
    }

    # If we get to here the above code did not exit prematurely,
    # meaning there's potentially more search results. Schedule
    # a job to run shortly after becoming idle to do more searching.
    dict set afterid $id \
        [after idle [namespace code [list _reschedule $id [info level 0]]]]
}

proc ::tag::_reschedule {id command} {
    variable afterid
    # it's interesting to change the delay to a large number so
    # you can watch the search progress. Use a small number to get
    # better performance. 
    set delay 10
    dict set afterid $id [after $delay [namespace code $command]]
}

======


<<categories>> GUI