Tk Source Code

Check-in [ee1d765e]
Login
Bounty program for improvements to Tcl and certain Tcl packages.
Tcl 2019 Conference, Houston/TX, US, Nov 4-8
Send your abstracts to tclconference@googlegroups.com
or submit via the online form by Sep 9.

Many hyperlinks are disabled.
Use anonymous login to enable hyperlinks.

Overview
Comment:Merged core-8-6-branch
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | tip-449
Files: files | file ages | folders
SHA1:ee1d765edd8102a6ac10759616a0e5b7d869d67f
User & Date: fvogel 2016-07-05 20:37:10
Context
2016-07-06
17:00
The undo marks identifier is now a member of textPtr->sharedTextPtr. This makes results of test text-8.22 independant of previous undo/redo actions on other text widgets. check-in: e45568b5 user: fvogel tags: tip-449
2016-07-05
20:37
Merged core-8-6-branch check-in: ee1d765e user: fvogel tags: tip-449
20:36
Fixed copy/paste error in test text-27.28 - one wants to test undo and redo, not twice undo check-in: 2fad88cb user: fvogel tags: tip-449
2016-06-28
21:25
[ce92c79bc6] Improve the 'configure' method of the internal megawidget framework. Thanks to Schelte Bron for pointing out the problems with it. check-in: e1099ee9 user: dkf tags: core-8-6-branch
Changes
Hide Diffs Unified Diffs Ignore Whitespace Patch

Changes to library/megawidget.tcl.

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
..
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
    self method create {name superclasses body} {
	next $name [list \
		superclass ::tk::MegawidgetClass {*}$superclasses]\;$body
    }
}

::oo::class create ::tk::MegawidgetClass {
    variable w hull OptionSpecification options IdleCallbacks
    constructor args {
	# Extract the "widget name" from the object name
	set w [namespace tail [self]]

	# Configure things
	set OptionSpecification [my GetSpecs]
	my configure {*}$args

	# Move the object out of the way of the hull widget
	rename [self] _tmp

	# Make the hull widget(s)
	my CreateHull
	bind $hull <Destroy> [list [namespace which my] destroy]

	# Rename things into their final places
	rename ::$w theFrame
	rename [self] ::$w

	# Make the contents
	my Create
    }
    destructor {
	foreach {name cb} [array get IdleCallbacks] {
................................................................................
	}
	if {[winfo exists $w]} {
	    bind $hull <Destroy> {}
	    destroy $w
	}
    }

















    method configure args {
	tclParseConfigSpec [my varname options] $OptionSpecification "" $args





    }

































































    method cget option {
	return $options($option)
    }























    method GetSpecs {} {
	return {
	    {-takefocus takeFocus TakeFocus {}}
	}
    }













    method CreateHull {} {
	return -code error -errorcode {TCL OO ABSTRACT_METHOD} \
	    "method must be overridden"
    }








    method Create {} {
	return -code error -errorcode {TCL OO ABSTRACT_METHOD} \
	    "method must be overridden"
    }











    method WhenIdle {method args} {
	if {![info exists IdleCallbacks($method)]} {
	    set IdleCallbacks($method) [after idle [list \
		    [namespace which my] DoWhenIdle $method $args]]
	}
    }
    method DoWhenIdle {method arguments} {
	unset IdleCallbacks($method)
	tailcall my $method {*}$arguments
    }
}










::tk::Megawidget create ::tk::SimpleWidget {} {
    variable w hull options
    method GetSpecs {} {
	return {
	    {-cursor cursor Cursor {}}
	    {-takefocus takeFocus TakeFocus {}}
	}
    }
    method CreateHull {} {
	set hull [::ttk::frame $w -cursor $options(-cursor)]
	trace add variable options(-cursor) write \
	    [namespace code {my UpdateCursorOption}]
    }
    method UpdateCursorOption args {
	$hull configure -cursor $options(-cursor)
    }

    method state args {
	tailcall $hull state {*}$args
    }
    method instate args {
	tailcall $hull instate {*}$args
    }
}








::tk::Megawidget create ::tk::FocusableWidget ::tk::SimpleWidget {
    variable w hull options
    method GetSpecs {} {
	return {
	    {-cursor cursor Cursor {}}
	    {-takefocus takeFocus TakeFocus ::ttk::takefocus}
	}
    }
    method CreateHull {} {
	ttk::frame $w
	set hull [ttk::entry $w.cHull -takefocus 0 -cursor $options(-cursor)]
	pack $hull -expand yes -fill both -ipadx 2 -ipady 2
	trace add variable options(-cursor) write \
	    [namespace code {my UpdateCursorOption}]
    }
}
 
return

# Local Variables:
# mode: tcl
# fill-column: 78
# End:







|





|
<









|







 







>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>

<
>
>
>
>
>
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>




>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>






>
>
>
>
>
>
>
>
>
>
>
>




>
>
>
>
>
>
>
>





>
>
>
>
>
>
>
>
>
>












>
>
>
>
>
>
>
>
>










<
|




>








>
>
>
>
>
>
>












<
|









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
..
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
279
280
281
282
283
284
285
286
287

288
289
290
291
292
293
294
295
296
297
    self method create {name superclasses body} {
	next $name [list \
		superclass ::tk::MegawidgetClass {*}$superclasses]\;$body
    }
}

::oo::class create ::tk::MegawidgetClass {
    variable w hull options IdleCallbacks
    constructor args {
	# Extract the "widget name" from the object name
	set w [namespace tail [self]]

	# Configure things
	tclParseConfigSpec [my varname options] [my GetSpecs] "" $args


	# Move the object out of the way of the hull widget
	rename [self] _tmp

	# Make the hull widget(s)
	my CreateHull
	bind $hull <Destroy> [list [namespace which my] destroy]

	# Rename things into their final places
	rename ::$w theWidget
	rename [self] ::$w

	# Make the contents
	my Create
    }
    destructor {
	foreach {name cb} [array get IdleCallbacks] {
................................................................................
	}
	if {[winfo exists $w]} {
	    bind $hull <Destroy> {}
	    destroy $w
	}
    }

    ####################################################################
    #
    # MegawidgetClass::configure --
    #
    #	Implementation of 'configure' for megawidgets. Emulates the operation
    #	of the standard Tk configure method fairly closely, which makes things
    #	substantially more complex than they otherwise would be.
    #
    #	This method assumes that the 'GetSpecs' method returns a description
    #	of all the specifications of the options (i.e., as Tk returns except
    #	with the actual values removed). It also assumes that the 'options'
    #	array in the class holds all options; it is up to subclasses to set
    #	traces on that array if they want to respond to configuration changes.
    #
    #	TODO: allow unambiguous abbreviations.
    #
    method configure args {

	# Configure behaves differently depending on the number of arguments
	set argc [llength $args]
	if {$argc == 0} {
	    return [lmap spec [my GetSpecs] {
		lappend spec $options([lindex $spec 0])
	    }]
	} elseif {$argc == 1} {
	    set opt [lindex $args 0]
	    if {[info exists options($opt)]} {
		set spec [lsearch -inline -index 0 -exact [my GetSpecs] $opt]
		return [linsert $spec end $options($opt)]
	    }
	} elseif {$argc == 2} {
	    # Special case for where we're setting a single option. This
	    # avoids some of the costly operations. We still do the [array
	    # get] as this gives a sufficiently-consistent trace.
	    set opt [lindex $args 0]
	    if {[dict exists [array get options] $opt]} {
		# Actually set the new value of the option. Use a catch to
		# allow a megawidget user to throw an error from a write trace
		# on the options array to reject invalid values.
		try {
		    array set options $args
		} on error {ret info} {
		    # Rethrow the error to get a clean stack trace
		    return -code error -errorcode [dict get $info -errorcode] $ret
		}
		return
	    }
	} elseif {$argc % 2 == 0} {
	    # Check that all specified options exist. Any unknown option will
	    # cause the merged dictionary to be bigger than the options array
	    set merge [dict merge [array get options] $args]
	    if {[dict size $merge] == [array size options]} {
		# Actually set the new values of the options. Use a catch to
		# allow a megawidget user to throw an error from a write trace
		# on the options array to reject invalid values
		try {
		    array set options $args
		} on error {ret info} {
		    # Rethrow the error to get a clean stack trace
		    return -code error -errorcode [dict get $info -errorcode] $ret
		}
		return
	    }
	    # Due to the order of the merge, the unknown options will be at
	    # the end of the dict. This makes the first unknown option easy to
	    # find.
	    set opt [lindex [dict keys $merge] [array size options]]
	} else {
	    set opt [lindex $args end]
	    return -code error -errorcode [list TK VALUE_MISSING] \
		"value for \"$opt\" missing"
	}
	return -code error -errorcode [list TK LOOKUP OPTION $opt] \
	    "bad option \"$opt\": must be [tclListValidFlags options]"
    }

    ####################################################################
    #
    # MegawidgetClass::cget --
    #
    #	Implementation of 'cget' for megawidgets. Emulates the operation of
    #	the standard Tk cget method fairly closely.
    #
    #	This method assumes that the 'options' array in the class holds all
    #	options; it is up to subclasses to set traces on that array if they
    #	want to respond to configuration reads.
    #
    #	TODO: allow unambiguous abbreviations.
    #
    method cget option {
	return $options($option)
    }

    ####################################################################
    #
    # MegawidgetClass::TraceOption --
    #
    #	Sets up the tracing of an element of the options variable.
    #
    method TraceOption {option method args} {
	set callback [list my $method {*}$args]
	trace add variable options($option) write [namespace code $callback]
    }

    ####################################################################
    #
    # MegawidgetClass::GetSpecs --
    #
    #	Return a list of descriptions of options supported by this
    #	megawidget. Each option is described by the 4-tuple list, consisting
    #	of the name of the option, the "option database" name, the "option
    #	database" class-name, and the default value of the option. These are
    #	the same values returned by calling the configure method of a widget,
    #	except without the current values of the options.
    #
    method GetSpecs {} {
	return {
	    {-takefocus takeFocus TakeFocus {}}
	}
    }

    ####################################################################
    #
    # MegawidgetClass::CreateHull --
    #
    #	Creates the real main widget of the megawidget. This is often a frame
    #	or toplevel widget, but isn't always (lightweight megawidgets might
    #	use a content widget directly).
    #
    #	The name of the hull widget is given by the 'w' instance variable. The
    #	name should be written into the 'hull' instance variable. The command
    #	created by this method will be renamed.
    #
    method CreateHull {} {
	return -code error -errorcode {TCL OO ABSTRACT_METHOD} \
	    "method must be overridden"
    }

    ####################################################################
    #
    # MegawidgetClass::Create --
    #
    #	Creates the content of the megawidget. The name of the widget to
    #	create the content in will be in the 'hull' instance variable.
    #
    method Create {} {
	return -code error -errorcode {TCL OO ABSTRACT_METHOD} \
	    "method must be overridden"
    }

    ####################################################################
    #
    # MegawidgetClass::WhenIdle --
    #
    #	Arrange for a method to be called on the current instance when Tk is
    #	idle. Only one such method call per method will be queued; subsequent
    #	queuing actions before the callback fires will be silently ignored.
    #	The additional args will be passed to the callback, and the callbacks
    #	will be properly cancelled if the widget is destroyed.
    #
    method WhenIdle {method args} {
	if {![info exists IdleCallbacks($method)]} {
	    set IdleCallbacks($method) [after idle [list \
		    [namespace which my] DoWhenIdle $method $args]]
	}
    }
    method DoWhenIdle {method arguments} {
	unset IdleCallbacks($method)
	tailcall my $method {*}$arguments
    }
}

####################################################################
#
# tk::SimpleWidget --
#
#	Simple megawidget class that makes it easy create widgets that behave
#	like a ttk widget. It creates the hull as a ttk::frame and maps the
#	state manipulation methods of the overall megawidget to the equivalent
#	operations on the ttk::frame.
#
::tk::Megawidget create ::tk::SimpleWidget {} {
    variable w hull options
    method GetSpecs {} {
	return {
	    {-cursor cursor Cursor {}}
	    {-takefocus takeFocus TakeFocus {}}
	}
    }
    method CreateHull {} {
	set hull [::ttk::frame $w -cursor $options(-cursor)]

	my TraceOption -cursor UpdateCursorOption
    }
    method UpdateCursorOption args {
	$hull configure -cursor $options(-cursor)
    }
    # Not fixed names, so can't forward
    method state args {
	tailcall $hull state {*}$args
    }
    method instate args {
	tailcall $hull instate {*}$args
    }
}

####################################################################
#
# tk::FocusableWidget --
#
#	Simple megawidget class that makes a ttk-like widget that has a focus
#	ring.
#
::tk::Megawidget create ::tk::FocusableWidget ::tk::SimpleWidget {
    variable w hull options
    method GetSpecs {} {
	return {
	    {-cursor cursor Cursor {}}
	    {-takefocus takeFocus TakeFocus ::ttk::takefocus}
	}
    }
    method CreateHull {} {
	ttk::frame $w
	set hull [ttk::entry $w.cHull -takefocus 0 -cursor $options(-cursor)]
	pack $hull -expand yes -fill both -ipadx 2 -ipady 2

	my TraceOption -cursor UpdateCursorOption
    }
}
 
return

# Local Variables:
# mode: tcl
# fill-column: 78
# End: