1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278
|
#----------------------------------------------------------------------
#
# TracedText.tcl --
#
# Package that implements a change to the text widget that
# allows a -textvariable option to be specified at creation
# time.
#
#----------------------------------------------------------------------
# Copyright (c) 1999, by Kevin B. Kenny. All rights reserved.
package provide TracedText 1.0
namespace eval TracedText {
namespace export TracedText
# The traced text widgets have a <Destroy> binding that
# cleans up internal storage. Establish it here so that
# the widget creation procedure just has to fiddle binding
# tags.
bind TracedText <Destroy> [namespace code {cleanup %W}]
}
#----------------------------------------------------------------------
#
# TracedText::TracedText --
#
# Create a text widget that supports a -textvariable flag
#
# Parameters:
# w -- Path name of the widget
# args -- Option-value pairs
#
# Results:
# Returns the path name of the newly-created widget.
#
# Side effects:
# The widget is created. If a -textvariable option is
# supplied, the widget command is renamed, and an alias
# is installed in the global namespace. The alias command
# intercepts the 'insert' and 'delete' subcommands and
# updates the text variable. In addition, a trace is
# established on the text variable to keep the text
# variable up to date.
#
# Options:
# The TracedText command accepts all the options of a text
# widget, plus a -textvariable option that gives the name
# of a variable or array element in the global namespace
# that will contain the same content as the widget itself.
#
# Limitations:
# The code does not work entirely correctly in the presence
# of embedded images. The -textvariable option cannot be
# set via 'configure' or interrogated via 'cget'.
#
#----------------------------------------------------------------------
proc TracedText::TracedText { w args } {
variable textvar
# Extract the special '-textvariable' option.
set textArgs {}
foreach { option value } $args {
switch -exact -- $option {
-textvariable {
set textvar($w) $value
}
default {
lappend textArgs $option $value
}
}
}
# Create the widget
eval [list text $w] $textArgs
# Rename the widget command to an alias in the "TracedText"
# namespace. Create a new command that looks just like the
# widget command but goes off to the "widgetCmd" procedure.
if {[info exists textvar($w)]} {
rename $w alias$w
proc ::$w args {
# p is the name of this procedure, which may or
# may not have a :: qualifier.
set p [lindex [info level 0] 0]
# w is the name of the traced text widget.
set w [namespace tail $p]
# Go to the TracedText::widgetCmd procedure to
# process the command.
return [eval [list TracedText::widgetCmd $w] $args]
}
# Adjust the bind tags so that the <Destroy> binding will fire.
bindtags $w [linsert [bindtags $w] 1 TracedText]
# If the variable exists, update the widget content.
# Otherwise, create the variable.
# the original had a upvar \#0 here
upvar 1 $textvar($w) theVariable
if { [info exists theVariable] } {
alias$w insert 1.0 $theVariable
} else {
set theVariable {}
}
# Put a trace on the text variable so that we can update
# the widget if it changes.
trace variable theVariable w \
[namespace code [list traceCallback $w]]
}
return $w
}
#----------------------------------------------------------------------
#
# TracedText::widgetCmd --
#
# Widget command for a text widget with a textvariable.
#
# Parameters:
# w -- Path name of the widget
# args -- Arguments to the widget command
#
# Results:
# Returns whatever the text widget does in response to the
# widget command.
#
# Side effects:
# In addition to whatever side effects the text widget
# has in response to the widget command, the 'insert' and
# 'delete' widget commands cause the text variable of the
# widget to be updated.
#
#----------------------------------------------------------------------
proc TracedText::widgetCmd {w args} {
# Execute the widget command
set retval [eval [list alias$w] $args]
# After the widget command returns, set the text variable if
# the command was 'insert' or 'delete.'
switch -exact [lindex $args 0] {
del -
dele -
delet -
delete -
ins -
inse -
inser -
insert {
variable textvar
variable busy
# The 'busy' variable keeps the traceCallback
# procedure from attempting to reload the widget
# content.
upvar \#0 $textvar($w) content
set busy($w) {}
set content [$w get 1.0 end]
unset busy($w)
}
}
return $retval
}
#----------------------------------------------------------------------
#
# TracedText::traceCallback --
#
# Trace callback entered when the text variable of a text widget
# is changed.
#
# Parameters:
# w -- Path name of the widget
# name1 -- Name of the text variable in the calling namespace.
# name2 -- Subscript name of the text variable, if any.
# op -- Traced variable operation (always "w")
#
# Results:
# None.
#
# Side effects:
# If the variable was being changed in response to an 'insert'
# or 'delete' command on the widget, the procedure does nothing.
# Otherwise, it deletes the entire content of the widget and
# replaces it with the new contents of the variable; it does this
# even if the widget is disabled.
#
#----------------------------------------------------------------------
proc TracedText::traceCallback { w name1 name2 op } {
variable busy
if { ! [info exists busy($w)] } {
variable textvar
# Retrieve the changed content of the textvariable
upvar 2 $name1 theVariable
if { [array exists theVariable] } {
set content $theVariable($name2)
} else {
set content $theVariable
}
# Enable the widget temporarily, and adjust its content.
set state [alias$w cget -state]
alias$w configure -state normal
alias$w delete 1.0 end
alias$w insert 1.0 $content
alias$w configure -state $state
}
return
}
#----------------------------------------------------------------------
#
# TracedText::cleanup --
#
# Clean up after destroyoing a text widget with a textvariable.
#
# Parameters:
# w -- Path name of the destroyed widget.
#
# Results:
# None.
#
# Side effects:
# The variables and traces that belong to the widget are deleted,
# as is the procedure that aliases the widget command.
#
#----------------------------------------------------------------------
proc TracedText::cleanup { w } {
variable textvar
upvar #0 $textvar($w) theVariable
trace vdelete theVariable w \
[namespace code [list traceCallback $w]]
unset textvar($w)
rename ::$w {}
return
}
|