File: TracedText.tcl

package info (click to toggle)
coccinella 0.96.20-7
  • links: PTS, VCS
  • area: main
  • in suites: jessie, jessie-kfreebsd
  • size: 13,108 kB
  • ctags: 5,908
  • sloc: tcl: 124,744; xml: 206; makefile: 66; sh: 62
file content (278 lines) | stat: -rw-r--r-- 7,682 bytes parent folder | download | duplicates (4)
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

}