blob: 9b9be9278e7c5e42acc44701335b9d9e9a861e3e (
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
|
# 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 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] {
after cancel $cb
unset IdleCallbacks($name)
}
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:
|
