summaryrefslogtreecommitdiff
path: root/systems/texlive/tlnet/tlpkg/tltcl/lib/tk8.6/megawidget.tcl
blob: aeb1263a8c7ba05aca292f2e512b526a3083bd5c (plain)
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
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
# megawidget.tcl
#
#	Basic megawidget support classes. Experimental for any use other than
#	the ::tk::IconList megawdget, which is itself only designed for use in
#	the Unix file dialogs.
#
# Copyright (c) 2009-2010 Donal K. Fellows
#
# See the file "license.terms" for information on usage and redistribution of
# this file, and for a DISCLAIMER OF ALL WARRANTIES.
#

package require Tk 8.6

::oo::class create ::tk::Megawidget {
    superclass ::oo::class
    method unknown {w args} {
	if {[string match .* $w]} {
	    [self] create $w {*}$args
	    return $w
	}
	next $w {*}$args
    }
    unexport new unknown
    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] {
	    after cancel $cb
	    unset IdleCallbacks($name)
	}
	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: