[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. ---- #------------------------------------------------------------------------------- # -*- tcl -*- $Id: 6104,v 1.3 2003-05-15 08:01:15 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 <> # #------------------------------------------------------------------------------- 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 <> } 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 <> 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 <> } 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 <> } 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] ]]