summaryrefslogtreecommitdiff
path: root/systems/texlive/tlnet/tlpkg/tltcl/lib/itcl4.2.1/itclHullCmds.tcl
blob: 282041187c64585df33313664cabbde38685c4b3 (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
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
#
# itclHullCmds.tcl
# ----------------------------------------------------------------------
# Invoked automatically upon startup to customize the interpreter
# for [incr Tcl] when one of setupcomponent or createhull 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

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

# ======================= widgetDeleted ===========================

proc widgetDeleted {oldName newName op} {
    # The widget is beeing deleted, so we have to delete the object
    # which had the widget as itcl_hull too!
    # We have to get the real name from for example
    # ::itcl::internal::widgets::hull1.lw
    # we need only .lw here

#puts stderr "widgetDeleted!$oldName!$newName!$op!"
    set cmdName [namespace tail $oldName]
    set flds [split $cmdName {.}]
    set cmdName .[join [lrange $flds 1 end] {.}]
#puts stderr "DELWIDGET![namespace current]!$cmdName![::info command $cmdName]!"
    rename $cmdName {}
}

}

namespace eval ::itcl::builtin {

# ======================= createhull ===========================
# the hull widget is a tk widget which is the (mega) widget handled behind the itcl
# extendedclass/itcl widget.
# It is created be renaming the itcl class object to a temporary name <itcl object name>_
# creating the widget with the
# appropriate options and the installing that as the "hull" widget (the container)
# All the options in args and the options delegated to component itcl_hull are used
# Then a unique name (hull_widget_name) in the itcl namespace is created for widget:
# ::itcl::internal::widgets::hull<unique number><namespace tail path>
# and widget is renamed to that name
# Finally the <itcl object name>_ is renamed to the original <itcl object name> again
# Component itcl_hull is created if not existent
# itcl_hull is set to the hull_widget_name and the <itcl object name>
# is returned to the caller
# ==============================================================

proc createhull {widget_type path args} {
    variable hullCount
    upvar this this
    upvar win win


#puts stderr "il-1![::info level -1]!$this!"
#puts stderr "createhull!$widget_type!$path!$args!$this![::info command $this]!"
#puts stderr "ns1![uplevel 1 namespace current]!"
#puts stderr "ns2![uplevel 2 namespace current]!"
#puts stderr "ns3![uplevel 3 namespace current]!"
#puts stderr "level-1![::info level -1]!"
#puts stderr "level-2![::info level -2]!"
#    set my_this [namespace tail $this]
    set my_this $this
    set tmp $my_this
#puts stderr "II![::info command $this]![::info command $tmp]!"
#puts stderr "rename1!rename $my_this ${tmp}_!"
    rename ::$my_this ${tmp}_
    set options [list]
    foreach {option_name value} $args {
        switch -glob -- $option_name {
	-class {
	      lappend options $option_name [namespace tail $value]
	  }
        -* {
            lappend options $option_name $value
          }
        default {
	    return -code error "bad option name\"$option_name\" options must start with a \"-\""
          }
        }
    }
    set my_win [namespace tail $path]
    set cmd [list $widget_type $my_win]
#puts stderr "my_win!$my_win!cmd!$cmd!$path!"
    if {[llength $options] > 0} {
        lappend cmd {*}$options
    }
    set widget [uplevel 1 $cmd]
#puts stderr "widget!$widget!"
    trace add command $widget delete ::itcl::internal::commands::widgetDeleted
    set opts [uplevel 1 info delegated options]
    foreach entry $opts {
        foreach {optName compName} $entry break
	if {$compName eq "itcl_hull"} {
	    set optInfos [uplevel 1 info delegated option $optName]
	    set realOptName [lindex $optInfos 4]
	    # strip off the "-" at the beginning
	    set myOptName [string range $realOptName 1 end]
            set my_opt_val [option get $my_win $myOptName *]
            if {$my_opt_val ne ""} {
                $my_win configure -$myOptName $my_opt_val
            }
	}
    }
    set idx 1
    while {1} {
        set widgetName ::itcl::internal::widgets::hull${idx}$my_win
#puts stderr "widgetName!$widgetName!"
	if {[string length [::info command $widgetName]] == 0} {
	    break
	}
        incr idx
    }
#puts stderr "rename2!rename $widget $widgetName!"
    set dorename 0
    rename $widget $widgetName
#puts stderr "rename3!rename ${tmp}_ $tmp![::info command ${tmp}_]!my_this!$my_this!"
    rename ${tmp}_ ::$tmp
    set exists [uplevel 1 ::info exists itcl_hull]
    if {!$exists} {
	# that does not yet work, beacause of problems with resolving
        ::itcl::addcomponent $my_this itcl_hull
    }
    upvar itcl_hull itcl_hull
    ::itcl::setcomponent $my_this itcl_hull $widgetName
#puts stderr "IC![::info command $my_win]!"
    set exists [uplevel 1 ::info exists itcl_interior]
    if {!$exists} {
	# that does not yet work, beacause of problems with resolving
        ::itcl::addcomponent $this itcl_interior
    }
    upvar itcl_interior itcl_interior
    set itcl_interior $my_win
#puts stderr "hull end!win!$win!itcl_hull!$itcl_hull!itcl_interior!$itcl_interior!"
    return $my_win
}

# ======================= addToItclOptions ===========================

proc addToItclOptions {my_class my_win myOptions argsDict} {
    upvar win win
    upvar itcl_hull itcl_hull

    set opt_lst [list configure]
    foreach opt [lsort $myOptions] {
#puts stderr "IOPT!$opt!$my_class!$my_win![::itcl::is class $my_class]!"
        set isClass [::itcl::is class $my_class]
	set found 0
	if {$isClass} {
            if {[catch {
                set resource [namespace eval $my_class info option $opt -resource]
                set class [namespace eval $my_class info option $opt -class]
                set default_val [uplevel 2 info option $opt -default]
                set found 1
            } msg]} {
#                puts stderr "MSG!$opt!$my_class!$msg!"
            }
        } else {
            set tmp_win [uplevel #0 $my_class .___xx]

            set my_info [$tmp_win configure $opt]
            set resource [lindex $my_info 1]
            set class [lindex $my_info 2]
            set default_val [lindex $my_info 3]
	    uplevel #0 destroy $tmp_win
            set found 1
        }
	if {$found} {
           if {[catch {
               set val [uplevel #0 ::option get $win $resource $class]
           } msg]} {
               set val ""
           }
           if {[::dict exists $argsDict $opt]} {
               # we have an explicitly set option
               set val [::dict get $argsDict $opt]
           } else {
	       if {[string length $val] == 0} {
                   set val $default_val
	       }
           }
           set ::itcl::internal::variables::${my_win}::itcl_options($opt) $val
           set ::itcl::internal::variables::${my_win}::__itcl_option_infos($opt) [list $resource $class $default_val]
#puts stderr "OPT1!$opt!$val!"
#	   uplevel 1 [list set itcl_options($opt) [list $val]]
           if {[catch {uplevel 1 $win configure $opt [list $val]} msg]} {
#puts stderr "addToItclOptions ERR!$msg!$my_class!$win!configure!$opt!$val!"
	   }
        }
    }
}

# ======================= setupcomponent ===========================

proc setupcomponent {comp using widget_type path args} {
    upvar this this
    upvar win win
    upvar itcl_hull itcl_hull

#puts stderr "setupcomponent!$comp!$widget_type!$path!$args!$this!$win!$itcl_hull!"
#puts stderr "CONT![uplevel 1 info context]!"
#puts stderr "ns1![uplevel 1 namespace current]!"
#puts stderr "ns2![uplevel 2 namespace current]!"
#puts stderr "ns3![uplevel 3 namespace current]!"
    set my_comp_object  [lindex [uplevel 1 info context] 1]
    if {[::info exists ::itcl::internal::component_objects($my_comp_object)]} {
        set my_comp_object [set ::itcl::internal::component_objects($my_comp_object)]
    } else {
        set ::itcl::internal::component_objects($path) $my_comp_object
    }
    set options [list]
    foreach {option_name value} $args {
        switch -glob -- $option_name {
        -* {
            lappend options $option_name $value
          }
        default {
	    return -code error "bad option name\"$option_name\" options must start with a \"-\""
          }
        }
    }
    if {[llength $args]} {
        set argsDict [dict create {*}$args]
    } else {
        set argsDict [dict create]
    }
    set cmd [list $widget_type $path]
    if {[llength $options] > 0} {
        lappend cmd {*}$options
    }
#puts stderr "cmd0![::info command $widget_type]!$path![::info command $path]!"
#puts stderr "cmd1!$cmd!"
#    set my_comp [uplevel 3 $cmd]
    set my_comp [uplevel #0 $cmd]
#puts stderr 111![::info command $path]!
    ::itcl::setcomponent $this $comp $my_comp
    set opts [uplevel 1 info delegated options]
    foreach entry $opts {
        foreach {optName compName} $entry break
	if {$compName eq $my_comp} {
	    set optInfos [uplevel 1 info delegated option $optName]
	    set realOptName [lindex $optInfos 4]
	    # strip off the "-" at the beginning
	    set myOptName [string range $realOptName 1 end]
            set my_opt_val [option get $my_win $myOptName *]
            if {$my_opt_val ne ""} {
                $my_comp configure -$myOptName $my_opt_val
            }
	}
    }
    set my_class $widget_type
    set my_parent_class [uplevel 1 namespace current]
    if {[catch {
        set myOptions [namespace eval $my_class {info classoptions}]
    } msg]} {
        set myOptions [list]
    }
    foreach entry [$path configure] {
        foreach {opt dummy1 dummy2 dummy3} $entry break
        lappend myOptions $opt
    }
#puts stderr "OPTS!$myOptions!"
    addToItclOptions $widget_type $my_comp_object $myOptions $argsDict
#puts stderr END!$path![::info command $path]!
}

proc itcl_initoptions {args} {
puts stderr "ITCL_INITOPT!$args!"
}

# ======================= initoptions ===========================

proc initoptions {args} {
    upvar win win
    upvar itcl_hull itcl_hull
    upvar itcl_option_components itcl_option_components

#puts stderr "INITOPT!!$win!"
    if {[llength $args]} {
        set argsDict [dict create {*}$args]
    } else {
        set argsDict [dict create]
    }
    set my_class [uplevel 1 namespace current]
    set myOptions [namespace eval $my_class {info classoptions}]
    if {[dict exists $::itcl::internal::dicts::classComponents $my_class]} {
        set class_info_dict [dict get $::itcl::internal::dicts::classComponents $my_class]
#    set myOptions [lsort -unique [namespace eval $my_class {info options}]]
        foreach comp [uplevel 1 info components] {
           if {[dict exists $class_info_dict $comp -keptoptions]} {
               foreach my_opt [dict get $class_info_dict $comp -keptoptions] {
                   if {[lsearch $myOptions $my_opt] < 0} {
#puts stderr "KEOPT!$my_opt!"
                       lappend myOptions $my_opt
                   }
               }
           }
        }
    } else {
        set class_info_dict [list]
    }
#puts stderr "OPTS!$win!$my_class![join [lsort $myOptions]] \n]!"
    set opt_lst [list configure]
    set my_win $win
    foreach opt [lsort $myOptions] {
	set found 0
        if {[catch {
            set resource [uplevel 1 info option $opt -resource]
            set class [uplevel 1 info option $opt -class]
            set default_val [uplevel 1 info option $opt -default]
	    set found 1
        } msg]} {
#            puts stderr "MSG!$opt!$msg!"
        }
#puts stderr "OPT!$opt!$found!"
	if {$found} {
           if {[catch {
               set val [uplevel #0 ::option get $my_win $resource $class]
           } msg]} {
               set val ""
           }
           if {[::dict exists $argsDict $opt]} {
               # we have an explicitly set option
               set val [::dict get $argsDict $opt]
           } else {
	       if {[string length $val] == 0} {
                   set val $default_val
	       }
           }
           set ::itcl::internal::variables::${win}::itcl_options($opt) $val
           set ::itcl::internal::variables::${win}::__itcl_option_infos($opt) [list $resource $class $default_val]
#puts stderr "OPT1!$opt!$val!"
#	   uplevel 1 [list set itcl_options($opt) [list $val]]
           if {[catch {uplevel 1 $my_win configure $opt [list $val]} msg]} {
puts stderr "initoptions ERR!$msg!$my_class!$my_win!configure!$opt!$val!"
	   }
        }
        foreach comp [dict keys $class_info_dict] {
#puts stderr "OPT1!$opt!$comp![dict get $class_info_dict $comp]!"
            if {[dict exists $class_info_dict $comp -keptoptions]} {
                if {[lsearch [dict get $class_info_dict $comp -keptoptions] $opt] >= 0} {
                    if {$found == 0} {
                        # we use the option value of the first component for setting
                        # the option, as the components are traversed in the dict
                        # depending on the ordering of the component creation!!
                        set my_info [uplevel 1 \[set $comp\] configure $opt]
                        set resource [lindex $my_info 1]
                        set class [lindex $my_info 2]
                        set default_val [lindex $my_info 3]
                        set found 2
                        set val [uplevel #0 ::option get $my_win $resource $class]
                        if {[::dict exists $argsDict $opt]} {
                            # we have an explicitly set option
                            set val [::dict get $argsDict $opt]
                        } else {
	                    if {[string length $val] == 0} {
                                set val $default_val
	                    }
                        }
#puts stderr "OPT2!$opt!$val!"
		        set ::itcl::internal::variables::${win}::itcl_options($opt) $val
		        set ::itcl::internal::variables::${win}::__itcl_option_infos($opt) [list $resource $class $default_val]
#	                uplevel 1 [list set itcl_options($opt) [list $val]]
                    }
                    if {[catch {uplevel 1 \[set $comp\] configure $opt [list $val]} msg]} {
puts stderr "initoptions ERR2!$msg!$my_class!$comp!configure!$opt!$val!"
	            }
		    if {![uplevel 1 info exists itcl_option_components($opt)]} {
                        set itcl_option_components($opt) [list]
		    }
		    if {[lsearch [set itcl_option_components($opt)] $comp] < 0} {
		        if {![catch {
		            set optval [uplevel 1 [list set itcl_options($opt)]]
                        } msg3]} {
                                uplevel 1 \[set $comp\] configure $opt $optval
                        }
                        lappend itcl_option_components($opt) $comp
		    }
                }
            }
        }
    }
#    uplevel 1 $opt_lst
}

# ======================= setoptions ===========================

proc setoptions {args} {

#puts stderr "setOPT!!$args!"
    if {[llength $args]} {
        set argsDict [dict create {*}$args]
    } else {
        set argsDict [dict create]
    }
    set my_class [uplevel 1 namespace current]
    set myOptions [namespace eval $my_class {info options}]
#puts stderr "OPTS!$win!$my_class![join [lsort $myOptions]] \n]!"
    set opt_lst [list configure]
    foreach opt [lsort $myOptions] {
	set found 0
        if {[catch {
            set resource [uplevel 1 info option $opt -resource]
            set class [uplevel 1 info option $opt -class]
            set default_val [uplevel 1 info option $opt -default]
	    set found 1
        } msg]} {
#            puts stderr "MSG!$opt!$msg!"
        }
#puts stderr "OPT!$opt!$found!"
	if {$found} {
           set val ""
           if {[::dict exists $argsDict $opt]} {
               # we have an explicitly set option
               set val [::dict get $argsDict $opt]
           } else {
	       if {[string length $val] == 0} {
                   set val $default_val
	       }
           }
	   set myObj [uplevel 1 set this]
#puts stderr "myObj!$myObj!"
           set ::itcl::internal::variables::${myObj}::itcl_options($opt) $val
           set ::itcl::internal::variables::${myObj}::__itcl_option_infos($opt) [list $resource $class $default_val]
#puts stderr "OPT1!$opt!$val!"
	   uplevel 1 [list set itcl_options($opt) [list $val]]
#           if {[catch {uplevel 1 $myObj configure $opt [list $val]} msg]} {
#puts stderr "initoptions ERR!$msg!$my_class!$my_win!configure!$opt!$val!"
#	   }
        }
    }
#    uplevel 1 $opt_lst
}

# ========================= keepcomponentoption ======================
#  Invoked by Tcl during evaluating constructor whenever
#  the "keepcomponentoption" command is invoked to list the options
#  to be kept when an ::itcl::extendedclass component has been setup
#  for an object.
#
#  It checks, for all arguments, if the opt is an option of that class
#  and of that component. If that is the case it adds the component name
#  to the list of components for that option.
#  The variable is the object variable: itcl_option_components($opt)
#
#  Handles the following syntax:
#
#    keepcomponentoption <componentName> <optionName> ?<optionName> ...?
#
# ======================================================================


proc keepcomponentoption {args} {
    upvar win win
    upvar itcl_hull itcl_hull

    set usage "wrong # args, should be: keepcomponentoption componentName optionName ?optionName ...?"

#puts stderr "KEEP!$args![uplevel 1 namespace current]!"
    if {[llength $args] < 2} {
        puts stderr $usage
	return -code error
    }
    set my_hull [uplevel 1 set itcl_hull]
    set my_class [uplevel 1 namespace current]
    set comp [lindex $args 0]
    set args [lrange $args 1 end]
    set class_info_dict [dict get $::itcl::internal::dicts::classComponents $my_class]
    if {![dict exists $class_info_dict $comp]} {
        puts stderr "keepcomponentoption cannot find component \"$comp\""
	return -code error
    }
    set class_comp_dict [dict get $class_info_dict $comp]
    if {![dict exists $class_comp_dict -keptoptions]} {
        dict set class_comp_dict -keptoptions [list]
    }
    foreach opt $args {
#puts stderr "KEEP!$opt!"
	if {[string range $opt 0 0] ne "-"} {
            puts stderr "keepcomponentoption: option must begin with a \"-\"!"
	    return -code error
	}
        if {[lsearch [dict get $class_comp_dict -keptoptions] $opt] < 0} {
            dict lappend class_comp_dict -keptoptions $opt
	}
    }
    if {![info exists ::itcl::internal::component_objects([lindex [uplevel 1 info context] 1])]} {
        set comp_object $::itcl::internal::component_objects([lindex [uplevel 1 info context] 1])
    } else {
        set comp_object "unknown_comp_obj_$comp!"
    }
    dict set class_info_dict $comp $class_comp_dict
    dict set ::itcl::internal::dicts::classComponents $my_class $class_info_dict
puts stderr "CLDI!$class_comp_dict!"
    addToItclOptions $my_class $comp_object $args [list]
}

proc ignorecomponentoption {args} {
puts stderr "IGNORE_COMPONENT_OPTION!$args!"
}

proc renamecomponentoption {args} {
puts stderr "rename_COMPONENT_OPTION!$args!"
}

proc addoptioncomponent {args} {
puts stderr "ADD_OPTION_COMPONENT!$args!"
}

proc ignoreoptioncomponent {args} {
puts stderr "IGNORE_OPTION_COMPONENT!$args!"
}

proc renameoptioncomponent {args} {
puts stderr "RENAME_OPTION_COMPONENT!$args!"
}

proc getEclassOptions {args} {
    upvar win win

#puts stderr "getEclassOptions!$args!$win![uplevel 1 namespace current]!"
#parray ::itcl::internal::variables::${win}::itcl_options
    set result [list]
    foreach opt [array names ::itcl::internal::variables::${win}::itcl_options] {
        if {[catch {
            foreach {res cls def} [set ::itcl::internal::variables::${win}::__itcl_option_infos($opt)] break
            lappend result [list $opt $res $cls $def [set ::itcl::internal::variables::${win}::itcl_options($opt)]]
        } msg]} {
        }
    }
    return $result
}

proc eclassConfigure {args} {
    upvar win win

#puts stderr "+++ eclassConfigure!$args!"
    if {[llength $args] > 1} {
        foreach {opt val}  $args break
        if {[::info exists ::itcl::internal::variables::${win}::itcl_options($opt)]} {
            set ::itcl::internal::variables::${win}::itcl_options($opt) $val
	    return
        }
    } else {
        foreach {opt}  $args break
        if {[::info exists ::itcl::internal::variables::${win}::itcl_options($opt)]} {
#puts stderr "OP![set ::itcl::internal::variables::${win}::itcl_options($opt)]!"
            foreach {res cls def} [set ::itcl::internal::variables::${win}::__itcl_option_infos($opt)] break
            return [list $opt $res $cls $def [set ::itcl::internal::variables::${win}::itcl_options($opt)]]
        }
    }
    return -code error
}

}