summaryrefslogtreecommitdiff
path: root/systems/texlive/tlnet/tlpkg/tltcl/lib/itcl4.2.2/itclWidget.tcl
blob: 5fcda510e09859696663c619080dfda3f43b391d (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
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
#
# itclWidget.tcl
# ----------------------------------------------------------------------
# Invoked automatically upon startup to customize the interpreter
# for [incr Tcl] when one of ::itcl::widget or ::itcl::widgetadaptor is called.
# ----------------------------------------------------------------------
#   AUTHOR:  Arnulf P. Wiedemann
#
# ----------------------------------------------------------------------
#            Copyright (c) 2008  Arnulf P. Wiedemann
# ======================================================================
# 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
# package require itclwidget [set ::itcl::version]

namespace eval ::itcl {

proc widget {name args} {
    set result [uplevel 1 ::itcl::internal::commands::genericclass widget $name $args]
    # we handle create by owerselfs !! allow classunknown to handle that
    oo::objdefine $result unexport create
    return $result
}

proc widgetadaptor {name args} {
    set result [uplevel 1 ::itcl::internal::commands::genericclass widgetadaptor $name $args]
    # we handle create by owerselfs !! allow classunknown to handle that
    oo::objdefine $result unexport create
    return $result
}

} ; # end ::itcl


namespace eval ::itcl::internal::commands {

proc initWidgetOptions {varNsName widgetName className} {
    set myDict [set ::itcl::internal::dicts::classOptions]
    if {$myDict eq ""} {
        return
    }
    if {![dict exists $myDict $className]} {
        return
    }
    set myDict [dict get $myDict $className]
    foreach option [dict keys $myDict] {
        set infos [dict get $myDict $option]
	set resource [dict get $infos -resource]
	set class [dict get $infos -class]
	set value [::option get $widgetName $resource $class]
	if {$value eq ""} {
	    if {[dict exists $infos -default]} {
	        set defaultValue [dict get $infos -default]
	        uplevel 1 set ${varNsName}::itcl_options($option) $defaultValue
	    }
	} else {
	    uplevel 1 set ${varNsName}::itcl_options($option) $value
	}
    }
}

proc initWidgetDelegatedOptions {varNsName widgetName className args} {
    set myDict [set ::itcl::internal::dicts::classDelegatedOptions]
    if {$myDict eq ""} {
        return
    }
    if {![dict exists $myDict $className]} {
        return
    }
    set myDict [dict get $myDict $className]
    foreach option [dict keys $myDict] {
        set infos [dict get $myDict $option]
	if {![dict exists $infos -resource]} {
	    # this is the case when delegating "*"
	    continue
	}
	if {![dict exists $infos -component]} {
	    # nothing to do
	    continue
	}
	# check if not in the command line options
	# these have higher priority
	set myOption $option
	if {[dict exists $infos -as]} {
	   set myOption [dict get $infos -as]
	}
	set noOptionSet 0
	foreach {optName optVal} $args {
	    if {$optName eq $myOption} {
	        set noOptionSet 1
		break
	    }
	}
	if {$noOptionSet} {
	    continue
	}
	set resource [dict get $infos -resource]
	set class [dict get $infos -class]
	set component [dict get $infos -component]
	set value [::option get $widgetName $resource $class]
	if {$component ne ""} {
	    if {$value ne ""} {
		set compVar [namespace eval ${varNsName}${className} "set $component"]
		if {$compVar ne ""} {
	            uplevel 1 $compVar configure $myOption $value
	        }
	    }
	}
    }
}

proc widgetinitobjectoptions {varNsName widgetName className} {
#puts stderr "initWidgetObjectOptions!$varNsName!$widgetName!$className!"
}

proc deletehull {newName oldName what} {
    if {$what eq "delete"} {
        set name [namespace tail $newName]
        regsub {hull[0-9]+} $name {} name
        rename $name {}
    }
    if {$what eq "rename"} {
        set name [namespace tail $newName]
        regsub {hull[0-9]+} $name {} name
        rename $name {}
    }
}

proc hullandoptionsinstall {objectName className widgetClass hulltype args} {
    if {$hulltype eq ""} {
        set hulltype frame
    }
    set idx 0
    set found 0
    foreach {optName optValue} $args {
	if {$optName eq "-class"} {
	    set found 1
	    set widgetClass $optValue
	    break
	}
        incr idx
    }
    if {$found} {
        set args [lreplace $args $idx [expr {$idx + 1}]]
    }
    if {$widgetClass eq ""} {
        set widgetClass $className
	set widgetClass [string totitle $widgetClass]
    }
    set cmd "set win $objectName; ::itcl::builtin::installhull using $hulltype -class $widgetClass $args"
    uplevel 2 $cmd
}

} ; # end ::itcl::internal::commands

namespace eval ::itcl::builtin {

proc installhull {args} {
    set cmdPath ::itcl::internal::commands
    set className [uplevel 1 info class]

    set replace 0
    switch -- [llength $args] {
	0	{
		return -code error\
		"wrong # args: should be \"[lindex [info level 0] 0]\
		name|using <widgetType> ?arg ...?\""
	}
	1	{
		set widgetName [lindex $args 0]
		set varNsName $::itcl::internal::varNsName($widgetName)
	}
	default	{
		upvar win win
		set widgetName $win

		set varNsName $::itcl::internal::varNsName($widgetName)
	        set widgetType [lindex $args 1]
		incr replace
		if {[llength $args] > 3 && [lindex $args 2] eq "-class"} {
		    set classNam [lindex $args 3]
		    incr replace 2
		} else {
		    set classNam [string totitle $widgetType]
		}
		uplevel 1 [lreplace $args 0 $replace $widgetType $widgetName -class $classNam]
		uplevel 1 [list ${cmdPath}::initWidgetOptions $varNsName $widgetName $className]
	}
    }

    # initialize the itcl_hull variable
    set i 0
    set nam ::itcl::internal::widgets::hull
    while {1} {
         incr i
	 set hullNam ${nam}${i}$widgetName
	 if {[::info command $hullNam] eq ""} {
	     break
	}
    }
    uplevel 1 [list ${cmdPath}::sethullwindowname $widgetName]
    uplevel 1 [list ::rename $widgetName $hullNam]
    uplevel 1 [list ::trace add command $hullNam {delete rename} ::itcl::internal::commands::deletehull]
    catch {${cmdPath}::checksetitclhull [list] 0}
    namespace eval ${varNsName}${className} "set itcl_hull $hullNam"
    catch {${cmdPath}::checksetitclhull [list] 2}
    uplevel 1 [lreplace $args 0 $replace ${cmdPath}::initWidgetDelegatedOptions $varNsName $widgetName $className]
}

proc installcomponent {args} {
    upvar win win

    set className [uplevel 1 info class]
    set myType [${className}::info types [namespace tail $className]]
    set isType 0
    if {$myType ne ""} {
        set isType 1
    }
    set numArgs [llength $args]
    set usage "usage: installcomponent <componentName> using <widgetType> <widgetPath> ?-option value ...?"
    if {$numArgs < 4} {
        error $usage
    }
    foreach {componentName using widgetType widgetPath} $args break
    set opts [lrange $args 4 end]
    if {$using ne "using"} {
        error $usage
    }
    if {!$isType} {
        set hullExists [uplevel 1 ::info exists itcl_hull]
        if {!$hullExists} {
            error "cannot install \"$componentName\" before \"itcl_hull\" exists"
        }
        set hullVal [uplevel 1 set itcl_hull]
        if {$hullVal eq ""} {
            error "cannot install \"$componentName\" before \"itcl_hull\" exists"
        }
    }
    # check for delegated option and ask the option database for the values
    # first check for number of delegated options
    set numOpts 0
    set starOption 0
    set myDict [set ::itcl::internal::dicts::classDelegatedOptions]
    if {[dict exists $myDict $className]} {
        set myDict [dict get $myDict $className]
	foreach option [dict keys $myDict] {
	    if {$option eq "*"} {
	        set starOption 1
	    }
	    incr numOpts
	}
    }
    set myOptionDict [set ::itcl::internal::dicts::classOptions]
    if {[dict exists $myOptionDict $className]} {
        set myOptionDict [dict get $myOptionDict $className]
    }
    set cmd [list $widgetPath configure]
    set cmd1 "set $componentName \[$widgetType $widgetPath\]"
    uplevel 1 $cmd1
    if {$starOption} {
	upvar $componentName compName
	set cmd1 [list $compName configure]
        set configInfos [uplevel 1 $cmd1]
	foreach entry $configInfos {
	    if {[llength $entry] > 2} {
	        foreach {optName resource class defaultValue} $entry break
		set val ""
		catch {
		    set val [::option get $win $resource $class]
		}
		if {$val ne ""} {
		    set addOpt 1
		    if {[dict exists $myDict $$optName]} {
		        set addOpt 0
		    } else {
		        set starDict [dict get $myDict "*"]
			if {[dict exists $starDict -except]} {
			    set exceptions [dict get $starDict -except]
			    if {[lsearch $exceptions $optName] >= 0} {
			        set addOpt 0
			    }

			}
			if {[dict exists $myOptionDict $optName]} {
			    set addOpt 0
			}
                    }
		    if {$addOpt} {
		        lappend cmd $optName $val
		    }

		}

	    }
        }
    } else {
        foreach optName [dict keys $myDict] {
	    set optInfos [dict get $myDict $optName]
	    set resource [dict get $optInfos -resource]
	    set class [namespace tail $className]
	    set class [string totitle $class]
	    set val ""
	    catch {
	        set val [::option get $win $resource $class]
            }
	    if {$val ne ""} {
		if {[dict exists $optInfos -as] } {
	            set optName [dict get $optInfos -as]
		}
		lappend cmd $optName $val
	    }
	}
    }
    lappend cmd {*}$opts
    uplevel 1 $cmd
}

} ; # end ::itcl::builtin

set ::itcl::internal::dicts::hullTypes [list \
       frame \
       toplevel \
       labelframe \
       ttk:frame \
       ttk:toplevel \
       ttk:labelframe \
    ]

namespace eval ::itcl::builtin::Info {

proc hulltypes {args} {
    namespace upvar ::itcl::internal::dicts hullTypes hullTypes

    set numArgs [llength $args]
    if {$numArgs > 1} {
        error "wrong # args should be: info hulltypes ?<pattern>?"
    }
    set pattern ""
    if {$numArgs > 0} {
        set pattern [lindex $args 0]
    }
    if {$pattern ne ""} {
        return [lsearch -all -inline -glob $hullTypes $pattern]
    }
    return $hullTypes

}

proc widgetclasses {args} {
    set numArgs [llength $args]
    if {$numArgs > 1} {
        error "wrong # args should be: info widgetclasses ?<pattern>?"
    }
    set pattern ""
    if {$numArgs > 0} {
        set pattern [lindex $args 0]
    }
    set myDict [set ::itcl::internal::dicts::classes]
    if {![dict exists $myDict widget]} {
        return [list]
    }
    set myDict [dict get $myDict widget]
    set result [list]
    if {$pattern ne ""} {
        foreach key [dict keys $myDict] {
	    set myInfo [dict get $myDict $key]
	    set value [dict get $myInfo -widget]
	    if {[string match $pattern $value]} {
	        lappend result $value
            }
        }
    } else {
        foreach key [dict keys $myDict] {
	    set myInfo [dict get $myDict $key]
	    lappend result [dict get $myInfo -widget]
	}
    }
    return $result
}

proc widgets {args} {
    set numArgs [llength $args]
    if {$numArgs > 1} {
        error "wrong # args should be: info widgets ?<pattern>?"
    }
    set pattern ""
    if {$numArgs > 0} {
        set pattern [lindex $args 0]
    }
    set myDict [set ::itcl::internal::dicts::classes]
    if {![dict exists $myDict widget]} {
        return [list]
    }
    set myDict [dict get $myDict widget]
    set result [list]
    if {$pattern ne ""} {
        foreach key [dict keys $myDict] {
	    set myInfo [dict get $myDict $key]
	    set value [dict get $myInfo -name]
	    if {[string match $pattern $value]} {
	        lappend result $value
            }
        }
    } else {
        foreach key [dict keys $myDict] {
	    set myInfo [dict get $myDict $key]
	    lappend result [dict get $myInfo -name]
	}
    }
    return $result
}

proc widgetadaptors {args} {
    set numArgs [llength $args]
    if {$numArgs > 1} {
        error "wrong # args should be: info widgetadaptors ?<pattern>?"
    }
    set pattern ""
    if {$numArgs > 0} {
        set pattern [lindex $args 0]
    }
    set myDict [set ::itcl::internal::dicts::classes]
    if {![dict exists $myDict widgetadaptor]} {
        return [list]
    }
    set myDict [dict get $myDict widgetadaptor]
    set result [list]
    if {$pattern ne ""} {
        foreach key [dict keys $myDict] {
	    set myInfo [dict get $myDict $key]
	    set value [dict get $myInfo -name]
	    if {[string match $pattern $value]} {
	        lappend result $value
            }
        }
    } else {
        foreach key [dict keys $myDict] {
	    set myInfo [dict get $myDict $key]
	    lappend result [dict get $myInfo -name]
	}
    }
    return $result
}

} ; # end ::itcl::builtin::Info