[RS] 2003-02-17: [Tags] - strings that represent groups of objects - are a
powerful concept, used in [Tk] for [text] portions, [canvas] items, and for
bindings in [bindtags]. Another use for tags, and their [Tcl] implementation,
has been proposed by [Bryan Oakley] in [comp.lang.tcl].

The posting was in response to the question "is there an easy way to enable or
disable related widgets" (or something like that) 

It's fairly easy to code up yourself, and makes for a nice little programming
exercise.

A variation of what I do looks roughly like this (off of the top of my head,
not tested, YMMV, void where prohibited by law, do not operate heavy machinery
while using, wait two hours before going swimming, not suitable for young
children, etc)


======
# some typical widgets...
.menubar.editMenu add command -label Paste ...
.popupMenu add command -label Paste ...
button .toolbar.paste -text Paste ...

# associate them with a symbolic name
associate paste .menubar.editMenu Paste
associate paste .toolbar.paste
associate paste .popupMenu Paste

....

# enable only if there's something on the clipboard
if {there is nothing on the clipboard} {
    disable paste
} else {
    enable paste
}
======

All that's left is to write the procs associate, enable and disable.

Associate is simple:

======
proc associate {what args} {
    global widgets
    lappend widgets($what) $args
}
======

enable and disable are also pretty simple:

======
proc enable {what} {
    global widgets
    foreach item $widgets($what) {
        set widget [lindex $item 0]
        if {[winfo exists $widget]} {
            if {[winfo class $widget] == "Menu"} {
                set index [lindex $item 1]
                $widget entryconfigure $index -state normal
            } else {
                $widget configure -state normal
            }
        }
    }
}
======



I've used a variation of this for years and it works great. It's a pain to have
to associate widgets with a symbolic name, but it's worth the effort. Besides
the obvious benefits, it makes the code easier to maintain in that if you
change widget paths or add or remove widgets you only have to change the
related "associate" commands rather than hunting down hard-coded widget paths
throughout your code.

There are lots of things you can do to make the code even more fancy.  For
example, you can support accelerators, build your own widget wrappers that do
the "associate" step automatically, add a disassociate step, etc.

----

After reading this, I was inspired to write a little library to really add this
functionality.  Here it is. 

[Damon Courtney]: If anyone is interested, I could package it up and actually
distribute it as a package.  Maybe add it to Tklib?

======
##
## TkTags - An interface for associating symbolic names with Tk widgets.
##
## tag add       tagName <widget ?menuItem?> ??widget ?menuItem?? ... ?
## tag addmenu   tagName menu menuItem ?menuItem ...?
## tag addtag    tagName searchSpec ?arg arg ... ?
##
## tag addtag    tagName ?recursive? ?class widgetClass? ?type menuItemType?
##                       ?children widgetName? ?menuentries menuName? ?arg ... ?
##
## tag cget      widgetOrTagName option
## tag configure widgetOrTagName ?option? ?value? ?option value ... ?
## tag delete    tagName ?tagName ... ?
## tag names     ?widget ?menuItem??
## tag remove    tagName <widget ?menuItem?> ??widget ?menuItem?? ... ?
## tag widgets   tagName ?tagName ... ?
##

package require Tk
package provide "TkTags" "1.0"

namespace eval ::TkTags {
    variable tags
    variable widgets

    proc ::TkTags::Lempty {list} {
        if {[catch {llength $list} len]} { return 0 }
        return [expr $len == 0]
    }

    proc ::TkTags::Lremove {list args} {
        foreach elem $args {
            set x [lsearch $list $elem]
            if {$x < 0} { continue }
            set list [lreplace $list $x $x]
        }
        return $list
    }

    proc ::TkTags::OptionErrorString {word type value list} {
        set msg "Error: $word $type \"$value\": must be "
        set last [lindex $list end]
        set list [lrange $list 0 end-1]
        append msg [join $list ", "] ", or $last"
        return $msg
    }

    proc ::TkTags::add {tagName args} {
        variable tags
        variable widgets
        foreach arg $args {
            if {![info exists tags($tagName)]
                || [lsearch $tags($tagName) $arg] < 0} {
                lappend tags($tagName) $arg
            }

            if {![info exists widgets($arg)]
                || [lsearch $widgets($arg) $tagName] < 0} {
                lappend widgets($arg)  $tagName
            }
        }
    }
    
    proc ::TkTags::addmenu {tagName menu args} {
        set list [list]
        foreach index $args {
            lappend list [list $menu $index]
        }
        eval add $tagName $list
    }

    proc ::TkTags::addtag {tagName args} {
        set recursive 0
        set pass      [list]
        set widgets   [list]
        for {set i 0} {$i < [llength $args]} {incr i} {
            set arg [lindex $args $i]

            switch -glob -- $arg {
                "cl*" { ## class
                    set class [lindex $args [incr i]]
                    lappend classes $class
                    lappend pass class $class
                }

                "r*" { ## recursive
                    set recursive 1
                    lappend pass recursive
                }

                "t*" { ## type
                    set type [lindex $args [incr i]]
                    lappend types $type
                    lappend pass type $type
                }

                default {
                    lappend search $arg
                }
            }
        }

        set args $search

        for {set i 0} {$i < [llength $args]} {incr i} {
            set arg [lindex $args $i]

            switch -glob -- $arg {
                "ch*" { ## children
                    set widget [lindex $args [incr i]]
                    if {![winfo exists $widget]} { continue }
                    foreach widget [winfo children $widget] {
                        if {[string match "*.#*" $widget]} { continue }
                        if {![info exists classes]
                            || [lsearch $classes [winfo class $widget]] > -1} {
                            lappend widgets $widget
                        }
                        if {$recursive} {
                            eval lappend widgets \
                                    [eval addtag $tagName $pass children $widget]
                        }
                    }
                }

                "m*" { ## menuentries
                    set widget [lindex $args [incr i]]
                    if {![winfo exists $widget]} { continue }
                    if {[string match "*.#*" $widget]} { continue }
                    if {[winfo class $widget] != "Menu"} {
                        return -code error "Error: $widget is not a menu"
                    }
                    for {set j 0} {1} {incr j} {
                        if {[$widget index $j] != $j} { break }
                        set type [$widget type $j]
                        if {![info exists types]
                            || [lsearch $types $type] > -1} {
                            lappend widgets [list $widget $j]
                        }

                        if {$type == "cascade" && $recursive} {
                            set menu [$widget entrycget $j -menu]
                            eval lappend widgets \
                                    [eval addtag $tagName $pass menuentries $menu]
                        }
                    }
                }

                default {
                    if {[winfo exists $arg]} { lappend widgets $arg }
                }
            }
        }
        eval add $tagName $widgets
        return $widgets
    }

    proc ::TkTags::cget {tagName option} {
        variable tags
        if {![info exists tags($tagName)]} {
            set widget [lindex $tagName 0]
            set index  [lindex $tagName 1]
            if {![winfo exists $widget]} { return }
        } else {
            if {[llength $tags($tagName)] > 1} { return }
            set item   [lindex $tags($tagName) 0]
            set widget [lindex $item 0]
            set index  [lindex $item 1]
        }

        if {[Lempty $index]} { return [$widget cget $option] }

        if {[winfo class $widget] == "Menu"} {
            return [$widget entrycget $index $option]
        } else {
            return [$widget itemcget $index $option]
        }
    }

    proc ::TkTags::configure {tagName args} {
        variable tags
        if {![info exists tags($tagName)]} {
            set widget [lindex $tagName 0]
            if {![winfo exists $widget]} { return }
            set items [list $tagName]
        } else {
            set items $tags($tagName)
        }

        if {[llength $args] < 2} {
            if {[llength $items] > 1} { return }
            set item   [lindex $items 0]
            set widget [lindex $item 0]
            set index  [lindex $item 1]
            if {![winfo exists $widget]} { return }

            if {[Lempty $index]} { return [eval $widget configure $args] }

            if {[winfo class $widget] == "Menu"} {
                return [eval $widget entryconfigure $index $args]
            } else {
                return [eval $widget itemconfigure $index $args]
            }
        }

        foreach {opt val} $args {
            foreach item $items {
                set widget [lindex $item 0]
                set index  [lindex $item 1]
                if {![winfo exists $widget]} { continue }
                if {![Lempty $index]} {
                    if {[winfo class $widget] == "Menu"} {
                        catch { $widget entryconfigure $index $opt $val }
                    } else {
                        catch { $widget itemconfigure $index $opt $val }
                    }
                } else {
                    catch { $widget configure $opt $val }
                }
            }
        }
    }

    proc ::TkTags::delete {args} {
        variable tags
        variable widgets

        foreach tagName $args {
            if {![info exists tags($tagName)]} { continue }
            foreach widget $tags($tagName) {
                if {![info exists widgets($widget)]} { continue }
                set widgets($widget) [Lremove $widgets($widget) $tagName]
                if {[Lempty $widgets($widget)]} { unset widgets($widget) }
            }
            unset tags($tagName)
        }
    }

    proc ::TkTags::names {{widget ""}} {
        variable tags
        variable widgets
        if {[Lempty $widget]} { return [lsort [array names tags]] }
        if {![info exists widgets($widget)]} { return }
        return $widgets($widget)
    }

    proc ::TkTags::remove {tagName args} {
        variable tags
        variable widgets

        if {![info exists tags($tagName)]} { return }

        set tags($tagName) [eval Lremove [list $tags($tagName)] $args]
        if {[Lempty $tags($tagName)]} { unset tags($tagName) }

        foreach widget $args {
            if {![info exists widgets($widget)]} { continue }
            set widgets($widget) [Lremove $widgets($widget) $tagName]
            if {[Lempty $widgets($widget)]} { unset widgets($widget) }
        }
    }

    proc ::TkTags::widgets {args} {
        variable tags
        set widgets [list]
        foreach tagName $args {
            if {![info exists tags($tagName)]} { continue }
            foreach widget $tags($tagName) {
                if {[lsearch $widgets $widget] > -1} { continue }
                lappend widgets $widget
            }
        }
        return $widgets
    }
}

proc ::tag {args} {
    if {[::TkTags::Lempty $args]} {
        set msg "Error: wrong # args: should be tag option arg ?arg ...?"
        return -code error $msg
    }

    set cmd [lindex $args 0]

    set list    [list add configure delete names remove widgets]
    set command [info commands ::TkTags::$cmd]
    if {[::TkTags::Lempty $command]} {
        set cmds [info commands ::TkTags::$cmd*]
        if {[::TkTags::Lempty $cmds]} {
            set msg [::TkTags::OptionErrorString bad option $cmd $list]
            return -code error $msg
        }
        if {[llength $cmds] > 1} {
            set msg [::TkTags::OptionErrorString ambiguous option $cmd $list]
            return -code error $msg
        }
        set command [lindex $cmds 0]
    }

    return [eval $command [lrange $args 1 end]]
}
======

<<categories>> Arts and crafts of Tcl-Tk programming |  Category Widget