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
|
# $Id: scwoop.tcl,v 3.12 2003/03/28 10:07:51 jfontain Exp $
package provide scwoop 4.1
class widget {
proc widget {this path} {
set ($this,path) $path
}
proc ~widget {this} {}
virtual proc configure {this args} {
return [eval $($this,path) configure $args]
}
virtual proc cget {this args} { ;# for native widgets, arguments sole element is option name
return [$($this,path) cget $args]
}
set option() {} ;### should not be necessary according to trace manual
# usage; option(widget,option) as in: $widget::option(button,borderwidth)
trace variable option r ::widget::checkOption
# option value is retrieved only when needed, dynamically, as opposed to preset default values, which may have been changed
# in the option database, preferably at the beginning of the program, since options are cached here once set, for efficiency
proc checkOption {array index operations} {
variable option
if {![info exists option($index)]} {
scan $index {%[^,],%s} type name
$type .temporary
set option($index) [.temporary cget -$name]
destroy .temporary
}
}
}
foreach class {button canvas entry frame label listbox menu menubutton message radiobutton scale scrollbar text toplevel} {
class $class { ;# create a widget wrapper class for each native Tk widget
# use fully qualified widget command so it does not interfere with class constructor procedure in class namespace
# if parent is ., Tcl widget command automatically strips off extra dot, that is ..path becomes .path
proc $class {this parentPath args} widget "\[eval ::$class \$parentPath.\$this \$args\]" {}
proc ~$class {this} {destroy $widget::($this,path)}
}
}
if {[package vcompare $::tcl_version 8.4] >= 0} {
class spinbox {
proc spinbox {this parentPath args} widget {[eval ::spinbox $parentPath.$this $args]} {}
proc ~spinbox {this} {destroy $widget::($this,path)}
}
}
# eventually comment out the following lines if you do not use the great tkTable widget:
class table {
proc table {this parentPath args} widget {[eval ::table $parentPath.$this $args]} {}
proc ~table {this} {destroy $widget::($this,path)}
}
# use the following wrappers for BLT (eventually comment out if you do not use the great BLT library):
# (which works around the following bug: [blt::graph ..g] returns .g but .g command does not exist, whereas ..g does)
foreach class {barchart graph hierbox htext stripchart tabset treeview} {
class $class {
proc $class {this parentPath args} widget "\[eval ::blt::$class .\[string trimleft \$parentPath.\$this .\] \$args\]" {}
proc ~$class {this} {destroy $widget::($this,path)}
}
}
class composite {}
# arguments are option / value pairs as are arguments to Tk widgets configure command
proc composite::composite {this base args} widget {$widget::($base,path)} {
if {([llength $args]%2)!=0} {
error "value for \"[lindex $args end]\" missing"
}
set ($this,base) $base
# base path is actually identical to widget path (in widget constructor) but is defined here for consistency
set ($this,base,path) $widget::($base,path)
set ($this,_children) {}
set ($this,complete) 0
# delay arguments processing till completion as pure virtual procedure invocations do not work from base class constructor
set ($this,initialArguments) $args
}
# delete children in reverse order of creation because Tk native widgets when destroyed destroy their children as well
proc composite::~composite {this} {
eval delete [lsort -integer -decreasing $($this,_children)] $($this,base)
}
# derived class implementation must return a list of {name dbname dbclass defaultValue currentValue} lists, as Tk widget configure
# options with current value optional
virtual proc composite::options {this}
proc composite::configure {this args} {
if {[llength $args]==0} {
return [descriptions $this]
}
if {![string match -* $args]} {
# first argument is a child widget name (no leading -), so configure child with optional option / value pairs
return [eval widget::configure $($this,[lindex $args 0]) [lrange $args 1 end]]
}
foreach {option value} $args { ;# check all options validity before doing anything else
if {![info exists ($this,$option)]} {
error "$($this,_derived): unknown option \"$option\""
}
}
if {[llength $args]==1} {
return [description $this [lindex $args 0]]
}
if {([llength $args]%2)!=0} {
error "value for \"[lindex $args end]\" missing"
}
# derived (dynamic virtual) procedure must either accept (or eventually adjust) the value or throw an error
# option data member is set prior to calling the method in case other methods are called and expect the new value
foreach {option value} $args {
if {![string equal $($this,$option) $value]} {
$($this,_derived)::set$option $this [set ($this,$option) $value]
}
}
}
proc composite::manage {this args} {
# arguments are one or more child widgets (widget class is composite base class) associated with a name which can later be
# used to retrieve the widget object and the widget path, at the composite level
foreach {child name} $args {
if {[string length $name]==0} {
error "widget $child has no name"
}
if {[string match -* $name]} {
error "widget $child name \"$name\" must not start with a dash character"
}
if {[info exists ($this,$name)]} {
error "\"$name\" member name already exists in composite layer"
}
set ($this,$name) $child
set ($this,$name,path) $widget::($child,path)
lappend ($this,_children) $child
}
}
# must be invoked at the end of derived class constructor so that components are properly configured
proc composite::complete {this} {
foreach description [options $this] {
set option [lindex $description 0]
set ($this,$option) [set default [lindex $description 1]] ;# by default always set option to default value
if {[llength $description]<3} {
set initialize($option) {} ;# no initial value so force initialization with default value
} elseif {![string equal $default [lindex $description 2]]} {
set ($this,$option) [lindex $description 2]
set initialize($option) {} ;# initial value different from default value so force initialization
}
}
# check validity of constructor options, which always take precedence for initialization
foreach {option value} $($this,initialArguments) {
if {[catch {string compare $($this,$option) $value} different]} {
error "$($this,_derived): unknown option \"$option\""
}
if {$different} {
set ($this,$option) $value
set initialize($option) {}
}
}
unset ($this,initialArguments)
foreach option [array names initialize] { ;# all option values are initialized before any of the set procedures are called
$($this,_derived)::set$option $this $($this,$option)
}
set ($this,complete) 1
}
proc composite::cget {this args} {
switch [llength $args] {
0 {
error "wrong # args: should be \"cget $this ?child? ?child? ... option\""
}
1 { ;# sole argument is option name, which must start with a dash character
if {![string match -* $args]||![info exists ($this,$args)]} {
error "$($this,_derived): unknown option \"$args\""
}
return $($this,$args) ;# return specified option current value
}
default { ;# leading arguments must be child widget names
return [eval widget::cget $($this,[lindex $args 0]) [lrange $args 1 end]]
}
}
}
# may be used by derived class for options that it does not implement, but no error checking here, not optimal for debugging
proc composite::try {this args} {
if {([llength $args]%2)!=0} {
error "value for \"[lindex $args end]\" missing"
}
foreach {option value} $args { ;# for best results, try each option / value pair separately
catch {widget::configure $($this,base) $option $value}
foreach child $($this,_children) {
catch {widget::configure $child $option $value}
}
}
}
proc composite::description {this option} { ;# build Tk widget like specified option description list
foreach description [options $this] {
if {[string equal [lindex $description 0] $option]} {
if {[llength $description]<3} { ;# no initial value
lappend description $($this,$option) ;# append current value
return $description
} else {
return [lreplace $description 2 2 $($this,$option)] ;# set current value
}
}
}
}
proc composite::descriptions {this} { ;# build Tk widget like option descriptions list for all supported options
set descriptions {}
foreach description [options $this] {
if {[llength $description]<3} { ;# no initial value
lappend description $($this,[lindex $description 0]) ;# append current value
lappend descriptions $description
} else {
lappend descriptions [lreplace $description 2 2 $($this,[lindex $description 0])] ;# set current value
}
}
return $descriptions
}
proc composite::managingOrder {this name1 name2} { ;# sort command: returns a negative value if first widget is older than second
return [expr {$($this,$name1)-$($this,$name2)}]
}
proc composite::componentNames {this} { ;# return component names in managing order
set names {}
foreach index [array names composite:: $this,*,path] {
if {[regexp {,(.+),path} $index dummy name]} {
lappend names $name
}
}
return [lsort -command "managingOrder $this" $names]
}
|
