Using Snit to make Tk DOM Glue

Michael A. Cleverly -- It seemed useful to be able to glue various Tk widgets to a tDOM DOM tree. Using Snit's Not Incr Tcl made it quite simple. The widgets start with the current value from the DOM tree, and when they're edited, the DOM tree is updated.
MC -- 7 May 2003: Updated to snit 0.81 syntax, added spinbox widget.
Would you consider contributing this to tklib?
 #-------------------------------------------------------------------------------
 # -*- tcl -*- $Id: 6104,v 1.5 2004-02-27 07:00:37 jcw Exp $
 # tdg -- Tk DOM Glue 1.1
 #
 # PURPOSE:
 #
 #     Tk widgets glued to a DOM tree with a bit of snit glue.
 #     See: http://wiki.tcl.tk/6104
 #
 # AUTHOR:
 #
 #     Michael A. Cleverly (michael@cleverly.com)
 #
 # HISTORY:
 #
 #     Version 1.0: Saturday, 28 December 2002
 #         * Initial release 
 #
 #     Version 1.1: Wednesday, 7 May 2003
 #         * Upgraded to snit 0.8 and Tk 8.4 (code simplified in the process)
 #         * Added spinbox
 #         * Added virtual event <<tdw::ValueChanged>>
 #
 #-------------------------------------------------------------------------------
 
 namespace eval ::tdg {
     package require Tcl 8.4
     package require Tk  8.4
     package require tdom 0.7.7
     package require snit 0.81
 }
 
 
 #-------------------------------------------------------------------------------
 # SPINBOX
 #
 ::snit::widgetadaptor ::tdg::spinbox {
     option -node ""
     option -attribute ""
     option -valuesvariable ""
     option -values ""
 
     constructor args {
         installhull [::spinbox $self] 
         $self configurelist $args
     }
 
     onconfigure -valuesvariable valuesvariable {
         trace remove variable $options(-valuesvariable) write \
             [mymethod ValuesUpdate]
         
         if {[string length $valuesvariable]} {
             trace add variable $valuesvariable write [mymethod ValuesUpdate]
             $self configure -values [set $valuesvariable]
         } 
 
         set options(-valuesvariable) $valuesvariable
     }
 
     onconfigure -node node {
         set options(-node) $node
         $hull set [$node tdwGetValue $options(-attribute)]
     }
 
     onconfigure -attribute attribute {
         set options(-attribute) $attribute
         if {$options(-node) != ""} {
             $hull set [$options(-node) tdwGetValue $attribute]
         }
     }
 
     method ValuesUpdate {name ndx op} {
         set before [$self get]
         $self configure -values [set $options(-valuesvariable)]
         if {[lsearch -exact [set $options(-valuesvariable)] $before] != -1} {
             $self set $before
         }
     }
 
     method WatchForChange {method arguments} {
         set before [$hull get]
         set result [eval $hull $method $arguments]
         set after  [$hull get]
 
         if {![string equal $before $after]} {
             if {$options(-node) != ""} {
                 $options(-node) tdwValueChanged $selected $options(-attribute)
             }
             event generate $win <<tdw::ValueChanged>>
         }
 
         return $result
     }
 
     onconfigure -values values {
         set options(-values) $values
         return [$self WatchForChange configure [list -values $values]]
     }
 
     method delete args {
         return [$self WatchForChange delete $args]
     }
 
     method insert args {
         return [$self WatchForChange insert $args]
     }
 
     method set args {
         return [$self WatchForChange set $args]
     }
 
     method invoke args {
         return [$self WatchForChange invoke $args]
     }
 
     delegate method * to hull
     delegate option * to hull 
 }
 

 #-------------------------------------------------------------------------------
 # CHECKBUTTON
 #
 ::snit::widgetadaptor ::tdg::checkbutton {
     option -node ""
     option -attribute ""
     option -variable ""
     variable selected
 
     constructor args {
         installhull [::checkbutton $self -variable ${selfns}::selected]
         trace add variable ${selfns}::selected write [mymethod SelectionUpdated]
         $self configurelist $args
     }
 
     onconfigure -node node {
         set options(-node) $node
         set selected [$node tdwGetValue $options(-attribute)]
     }
 
     onconfigure -attribute attribute {
         set options(-attribute) $attribute
         if {$options(-node) != ""} {
             set selected [$options(-node) tdwGetValue $attribute]
         }
     }
 
     onconfigure -variable variable {
         set options(-variable) $variable
         if {[info exists $variable]} {
             set selected [set $variable]
         } else {
             set $variable [set selected ""]
         }
     }
 
     method SelectionUpdated {var ndx op} {
         if {$options(-node) != ""} {
             $options(-node) tdwValueChanged $selected $optins(-attribute)
         }
 
         event generate $win <<tdw::ValueChanged>>
 
         if {[string length $options(-variable)]} {
             after 0 [list set $options(-variable) $selected]
         }
     }
 
     method get {} {
         return $selected
     }
 
     method getOpposite {} {
         if {[string is boolean -strict $selected]} {
             return [expr {![string is true -strict $selected]}]
         } else {
             return $selected
         }
     }
 
     method on? {} {
         return [string equal $selected [$hull cget -onvalue]]
     }
 
     method off? {} {
         return [string equal $selected [$hull cget -offvalue]]
     }
 
     delegate method * to hull
     delegate option * to hull
 }
 
 
 #-------------------------------------------------------------------------------
 # ENTRY
 #
 ::snit::widgetadaptor ::tdg::entry {
     option -node ""
     option -attribute ""
 
     constructor args {
         installhull [::entry $self] 
         $self configurelist $args
     }
 
     onconfigure -node node {
         set options(-node) $node
         $self delete 0 end
         $self insert 0 [$node tdwGetValue $options(-attribute)]
     }
 
     onconfigure -attribute attribute {
         set options(-attribute) $attribute
         if {$options(-node) != ""} {
             $self delete 0 end
             $self insert 0 [$options(-node) tdwGetValue $attribute]
         }
     }
 
     method WatchForChange {method arguments} {
         set before [$hull get]
         set result [eval $hull $method $arguments]
         set after  [$hull get]
 
         if {![string equal $before $after]} {
             if {$options(-node) != ""} {
                 $options(-node) tdwValueChanged $after $options(-attribute)
             }
             event generate $win <<tdw::ValueChanged>>
         }
 
         return $result
     }
 
     method insert args {
         return [$self WatchForChange insert $args]
     }
 
     method delete args {
         return [$self WatchForChange delete $args]
     }
 
     delegate method * to hull
     delegate option * to hull
 }
 
 
 #-------------------------------------------------------------------------------
 # TEXT
 #
 ::snit::widgetadaptor ::tdg::text {
     option -node ""
     option -attribute ""
 
     constructor args {
         installhull [::text $self] 
         $self configurelist $args
     }
 
     onconfigure -node node {
         set options(-node) $node
         $self delete 1.0 end
         $self insert 1.0 [$node tdwGetValue $options(-attribute)]
     }
 
     onconfigure -attribute attribute {
         set options(-attribute) $attribute
         if {$options(-node) != ""} {
             $self delete 1.0 end
             $self insert 1.0 [$options(-node) tdwGetValue $attribute]
         }
     }
 
     method WatchForChange {method arguments} {
         set before [$hull get 1.0 end-1c]
         set result [eval $hull $method $arguments]
         set after  [$hull get 1.0 end-1c]
 
         if {![string equal $before $after]} {
             if {$options(-node) != ""} {
                 $options(-node) tdwValueChanged $after $options(-attribute)
             }
             event generate $win <<tdw::ValueChanged>>
         }
 
         return $result
     }
 
     method delete args {
         return [$self WatchForChange delete $args]
     }
 
     method edit args {
         return [$self WatchForChange edit $args]
     }
 
     method insert args {
         return [$self WatchForChange insert $args]
     }
 
     delegate method * to hull
     delegate option * to hull
 }
 
 
 #-------------------------------------------------------------------------------
 # tdwValueChanged (tDOM helper method)
 #
 proc ::dom::domNode::tdwValueChanged {node value attribute} {
     if {[$node nodeType] != "ELEMENT_NODE"} {
         return [$node nodeValue $value]
     } 
 
     if {[string length $attribute]} {
         return [$node setAttribute $attribute $value]
     }
 
     set child [lindex [$node selectNodes text()] end]
     if {$child != ""} {
         return [$child nodeValue $value]
     } 
 
     $node appendFromList {#text {}}
     set child [$node lastChild]
     return [$child nodeValue $value]
 }
 
 
 #-------------------------------------------------------------------------------
 # tdwGetValue (tDOM helper method)
 #
 proc ::dom::domNode::tdwGetValue {node attribute} {
     if {[string length $attribute]} {
         if {[$node hasAttribute $attribute]} {
             return [$node getAttribute $attribute]
         } else return
     }
 
     if {[$node nodeType] != "ELEMENT_NODE"} {
         return [$node data]
     }
     
     set child [lindex [$node selectNodes text()] end]
     if {$child != ""} {
         return [$child data]
     } else return
 }
 
 
 package provide tdg 1.1
Category Package
Category XML
Category GUI
Category Snit