Artifact Content
Not logged in

Artifact d480935465f467affc54b1bf34320ef2e3c547cc


# Copyright (C) 2006-2010, Trevor Davel <twylite AT crypt DOT co DOT za>
#
# See the file "LICENSE.txt" (Tcl/Tk License) for information on usage and
# redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES.

# A mechanism to associate properties (variables) with a Tk window.
#
# DOCUMENTATION
#
# See http://dev.crypt.co.za/incubator/doc/tcltm/tk/wprop.wiki
# for documentation and EXAMPLE OF USE.
#
# DESIGN NOTES
#
# - Intention is to associate user-defined properties with a Tk window and allow
#   properties values to be set and retrieved.
# - Should also provide a mechanism to reveal the underlying variable name for 
#   use with -textvariable, traces, etc.
# - Binds to <Destroy> to free up all properties associated with a window.
# - API reworked to feel more like [dict]
#
# IMPLEMENTATION NOTES
#
# - Variables are stored in arrays in the ::wprop namespace.
# - Each array contains the properties for only one window, and is named
#   after the window's id.
# - The window's id is used as the array name to make error handling 
#   consistent.  Since cleanup is bound to a window event, we can only attach
#   properties to windows, so everything must check that pathName is a window
#   are return an appropriate error otherwise.  Using [winfo id] makes this
#   checking and error reporting some else's problem.
# - A cleanup script is bound to the window's <Destroy> event to ensure that
#   associated properties are deleted.  To prevent conflict with other scripts
#   using <Destroy> the window is tagged and we bind to the tag.
#
# KNOWN ISSUES
#
# See http://dev.crypt.co.za/incubator/doc/tcltm/tk/wprop.wiki
#
# DEBUGGING
# - Some useful debugging commands:
#   info vars ::wprop::0x*               ;# list of all properties arrays
#   winfo pathname 0x00040404           ;# find window path from array (win id)
#   array names ::wprop::0x00040404      ;# list all property names for a window
#   array names ::wprop::[winfo id .win] ;# list all property names for a window
 

namespace eval ::wprop {

  set WINDOW_TAG "wprop"

  # Remove properties array when the window is destroyed.
  bind $WINDOW_TAG <Destroy> { 
    array unset [namespace current]::%i 
    continue 
  }

  #** ::wprop::_tag_for_cleanup pathName
  # Bind a tag to a window so that we can hook the <Destroy> event.
  # The window must exist.
  # Returns nothing.
  proc _tag_for_cleanup {pathName} {
    variable WINDOW_TAG
    set tags [bindtags $pathName]
    if { $WINDOW_TAG ni $tags } {
      bindtags $pathName [concat $tags [list $WINDOW_TAG]]
    }
    return {}
  }
  

  #** ::wprop variable pathName key
  # Returns the fully qualified variable name for a property.  Ensures that a
  # cleanup hook is bound to the window.
  # Use with -variable, -textvariable, [vwait], etc.
  # The window must exist.
  proc _variable {pathName key} {
    # DESIGN NOTE: if external logic gets a reference to the underlying 
    # variable, we must ensure that the window is tagged for later cleanup,
    # even if the variable doesn't exist right now.
    set fqarrname [namespace current]::[winfo id $pathName]
    if { ! [array exists $fqarrname] } {
      _tag_for_cleanup $pathName
    }  
    return ${fqarrname}(${key}) 
  }


  #** ::wprop set pathName key
  # Sets the value of a property of a window.
  # The window must exist.
  # Returns the (new) value.
  proc _set {pathName key value} {
    # DESIGN NOTE: reuse the logic in _variable to ensure that the window is
    # tagged for later cleanup.
    set [_variable $pathName $key] $value
  }

  
  #** ::wprop get pathName ?key?
  # Return the value of a property of a window.  
  # Call without a property key to return a dict of all properties associated
  # with the window. 
  # Throws an error if the window or property does not exist.
  proc get {pathName args} {
    # DESIGN NOTE: interface is similar to [dict get] without support for
    # nested dicts.  To ensure that there are no reserved keys we have to
    # do an args hack rather than use an optional parameter.
    switch -- [llength $args] {
      0 {
        return [array get [namespace current]::[winfo id $pathName]]
      }
      1 {
        lassign $args key
        set fqvarname "[namespace current]::[winfo id $pathName](${key})"
        if { ! [info exists $fqvarname] } {
          error "no property \"$key\" for window \"$pathName\""
        } 
        return [set $fqvarname]
      }
      default {
        error "wrong # args: should be \"[lindex [info level 0] 0] pathName ?key?\""
      }
    }
  }


  #** ::wprop exists pathName key
  # Returns true if the property key exists for the window, or false otherwise.
  # The window must exist.
  proc exists {pathName key} {
    set fqvarname "[namespace current]::[winfo id $pathName](${key})"
    info exists $fqvarname
  }


  #** ::wprop get? pathName key
  # Returns the value of a property of a window, or an empty string if the
  # property key does not exist for the window.
  # The window must exist. 
  proc get? {pathName key} {
    set fqvarname "[namespace current]::[winfo id $pathName](${key})"
    if { ! [info exists $fqvarname] } {
      return {}
    }
    set $fqvarname
  }


  #** ::wprop unset pathName ?key?
  # Deletes a property from a window.
  # Call without a property key to delete all properties associated with the
  # window.
  # The window must exist.
  # Returns nothing.
  proc _unset {pathName args} {
    switch -- [llength $args] {
      0 {
        set fqarrname [namespace current]::[winfo id $pathName]
        array unset $fqarrname
        # DESIGN NOTE: do NOT untag the window.  Even though we have deleted
        # the array, external logic may still hold direct references to array
        # variables and could recreate them.
      }
      1 {
        # DESIGN NOTE: do not use [array unset] here, as that will cause $key
        # to be interpreted as a pattern (unlike everywhere else).
        lassign $args key
        set fqvarname "[namespace current]::[winfo id $pathName](${key})"
        if { [info exists $fqvarname] } {
          unset $fqvarname
        }
      }
      default {
        error "wrong # args: should be \"[lindex [info level 0] 0] pathName ?key?\""
      }
    }
  }


  # Create the ::wprop ensemble
  namespace ensemble create -command [namespace current] \
    -subcommands {variable set get exists get? unset} \
    -map {set _set unset _unset variable _variable}

}