Version 0 of Using Snit to make Tk DOM Glue

Updated 2002-12-28 20:07:00

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.

---

 # tdg -- Tk DOM Glue 1.0
 # ======================
 #
 # Use snit to hook up Tk widgets to feed into a tDOM DOM tree.
 #
 # @author Michael A. Cleverly ([email protected])
 # @creation-date: Saturday, 28 December 2002
 #

 package require Tk   8.3
 package require tdom 0.7.5
 package require snit 0.72

 namespace eval ::tdg {}

 ::snit::widget ::tdg::text {
     # Options the text widget doesn't have by default
     option -node ""
     option -attribute ""


     # Configure a new value for -node, populating the text widget if possible
     onconfigure -node node {
         set options(-node) $node

         if {[string length $node] != 0} {
             switch -- [$node nodeType] {
                 TEXT_NODE                   -
                 COMMENT_NODE                -
                 PROCESSING_INSTRUCTION_NODE {
                     [component hull] delete 1.0 end
                     [component hull] insert 1.0 [$node nodeValue]
                 }

                 ELEMENT_NODE {
                     if {[string length $options(-attribute)]} {
                         [component hull] delete 1.0 end
                         [component hull] insert 1.0 \
                             [$node getAttribute $options(-attribute) ""]
                     }
                 }
             }
         }
     }


     # Configure a new value for -attribute, populating the text widget 
     # if possible
     onconfigure -attribute attribute {
         set options(-attribute) $attribute

         if {[string length $options(-node)] && [string length $attribute]} {
             if {[$options(-node) nodeType] == "ELEMENT_NODE"} {
                 [component hull] delete 1.0 end
                 [component hull] insert 1.0 \
                     [$options(-node) getAttribute $attribute ""]
             }
         }
     }


     # Create the text widget
     constructor args {
         component hull is [::text $self] 

         # Apply any options passed at creation time.
         $self configurelist $args
     }


     # Helper proc to keep the DOM tree synchronized with the contents
     # of the text widget.
     proc synchronize {hull node attribute} {
         if {[string length $node] == 0} then return

         switch -- [$node nodeType] {
             TEXT_NODE                   -
             COMMENT_NODE                -
             PROCESSING_INSTRUCTION_NODE {
                 $node nodeValue [$hull get 1.0 end-1c]
             }

             ELEMENT_NODE {
                 if {[string length $attribute]} {
                     $node setAttribute $attribute [$hull get 1.0 end-1c]
                 }
             }
         }
     }


     # Override the insert method to keep the DOM tree in-synch with additions
     method insert args {
         eval [list [component hull]] insert $args
         synchronize [component hull] $options(-node) $options(-attribute)
     }

     # Override the delete method to keep the DOM tree in-synch with deletions
     method delete args {
         eval [list [component hull]] delete $args
         synchronize [component hull] $options(-node) $options(-attribute)
     }


     # Pass all other methods and options to the real text widget, so
     # that the remaining behavior is as expected.
     delegate method * to hull
     delegate option * to hull
 }


 ::snit::widget ::tdg::entry {
     # Options the entry widget doesn't have by default
     option -node ""
     option -attribute ""


     # Configure a new value for -node, populating the entry widget if possible
     onconfigure -node node {
         set options(-node) $node

         if {[string length $node] != 0} {
             switch -- [$node nodeType] {
                 TEXT_NODE                   -
                 COMMENT_NODE                -
                 PROCESSING_INSTRUCTION_NODE {
                     [component hull] delete 0 end
                     [component hull] insert 0 [$node nodeValue]
                 }

                 ELEMENT_NODE {
                     if {[string length $options(-attribute)]} {
                         [component hull] delete 0 end
                         [component hull] insert 0 \
                             [$node getAttribute $options(-attribute) ""]
                     }
                 }
             }
         }
     }


     # Configure a new value for -attribute, populating the entry widget 
     # if possible
     onconfigure -attribute attribute {
         set options(-attribute) $attribute

         if {[string length $options(-node)] && [string length $attribute]} {
             if {[$options(-node) nodeType] == "ELEMENT_NODE"} {
                 [component hull] delete 0 end
                 [component hull] insert 0 \
                     [$options(-node) getAttribute $attribute ""]
             }
         }
     }


     # Create the entry widget
     constructor args {
         component hull is [::entry $self] 

         # Apply any options passed at creation time.
         $self configurelist $args
     }


     # Helper proc to keep the DOM tree synchronized with the contents
     # of the entry widget.
     proc synchronize {hull node attribute} {
         if {[string length $node] == 0} then return

         switch -- [$node nodeType] {
             TEXT_NODE                   -
             COMMENT_NODE                -
             PROCESSING_INSTRUCTION_NODE {
                 $node nodeValue [$hull get]
             }

             ELEMENT_NODE {
                 if {[string length $attribute]} {
                     $node setAttribute $attribute [$hull get] 
                 }
             }
         }
     }


     # Override the insert method to keep the DOM tree in-synch with additions
     method insert args {
         eval [list [component hull]] insert $args
         synchronize [component hull] $options(-node) $options(-attribute)
     }

     # Override the delete method to keep the DOM tree in-synch with deletions
     method delete args {
         eval [list [component hull]] delete $args
         synchronize [component hull] $options(-node) $options(-attribute)
     }


     # Pass all other methods and options to the real entry widget, so
     # that the remaining behavior is as expected.
     delegate method * to hull
     delegate option * to hull
 }


 ::snit::widget ::tdg::radiobutton {
     # Options the radiobutton widget doesn't have by default
     option -node ""
     option -attribute ""

     # And one that it does that we need to have our own onconfigure for
     option -value "" 


     # Configure a new value for -node, setting the radiobutton's -variable
     # if possible/applicable.
     onconfigure -node node {
         set options(-node) $node
         set buttonValue [[component hull] cget -value]
         upvar #0 [[component hull] cget -variable] variable

         if {[string length $node] != 0} {
             switch -- [$node nodeType] {
                 TEXT_NODE                   -
                 COMMENT_NODE                -
                 PROCESSING_INSTRUCTION_NODE {
                     if {[string equal [$node nodeValue] $buttonValue]} {
                         set variable $buttonValue
                     }
                 }

                 ELEMENT_NODE {
                     set attrValue [$node getAttribute $options(-attribute) ""]
                     if {[string equal $attrValue $buttonValue]} {
                         set variable $buttonValue
                     }
                 }
             }
         }
     }

     # Configure a new value for -attribute, populating the radiobutton widget 
     # if possible/applicable.
     onconfigure -attribute attribute {
         set options(-attribute) $attribute

         if {[string length $options(-node)] && [string length $attribute]} {
             if {[$options(-node) nodeType] == "ELEMENT_NODE"} {
                 set buttonValue [[component hull] cget -value]
                 set attrValue [$options(-node) getAttribute $attribute ""]
                 upvar #0 [[component hull] cget -variable] variable

                 if {[string equal $attrValue $buttonValue]} {
                     set variable $buttonValue
                 }
             }
         }
     }


     # Helper procedure to maybe select the radiobutton if 
     # the DOM value equals the button value.
     proc maybe {self action node attribute} {
         if {[string length $node] == 0} then return

         switch -- [$node nodeType] {
             TEXT_NODE                   -
             COMMENT_NODE                -
             PROCESSING_INSTRUCTION_NODE {
                 set domValue [$node nodeValue]
             }

             ELEMENT_NODE {
                 if {[string length $attribute] == 0} then return

                 set domValue [$node getAttribute $attribute ""]
             }

             default {
                 return
             }
         }

         set buttonValue [$self cget -value]
         if {[string equal $buttonValue $domValue]} {
             $self $action
         } 
     }


     # If the value changes, and it matches what's in the DOM tree, then
     # we want this radio button to be the selected one.
     onconfigure -value value {
         set options(-value) $value
         [component hull] configure -value $value
         maybe $self select $options(-node) $options(-attribute)
     }


     # Create the entry widget
     constructor args {
         component hull is [::radiobutton $self] 

         # We need this set before -node (& possibly -attribute)
         set options(-value) [from args -value]
         $self configure -value $options(-value)

         # Apply any options passed at creation time.
         $self configurelist $args
         maybe $self select $options(-node) $options(-attribute)
     }


     # Helper proc to keep the DOM tree synchronized with the selected
     # radiobutton.
     proc synchronize {node attribute value} {
         if {[string length $node] == 0} then return

         switch -- [$node nodeType] {
             TEXT_NODE                   -
             COMMENT_NODE                -
             PROCESSING_INSTRUCTION_NODE {
                 $node nodeValue $value
             }

             ELEMENT_NODE {
                 if {[string length $attribute]} {
                     $node setAttribute $attribute $value
                 }
             }
         }
     }


     # Override the insert method to keep the DOM tree in-synch with additions
     method select args {
         eval [list [component hull]] select $args
         synchronize $options(-node) $options(-attribute) \
             [[component hull] cget -value]
     }

     method invoke args {
         eval [list [component hull]] invoke $args
         synchronize $options(-node) $options(-attribute) \
             [[component hull] cget -value]
     }

     method deselet args {
         eval [list [component hull]] deselect $args
         synchronize $options(-node) $options(-attribute) ""
     }

     # Pass all other methods and options to the real entry widget, so
     # that the remaining behavior is as expected.
     delegate method * to hull
     delegate option * to hull
 }


 package provide tdg 1.0