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
|
# this fragment was taken from BWidget 1.8 release, slightly modified
proc MainFrame::_create_menubar { path descmenu } {
variable _widget
global tcl_platform
set top $_widget($path,top)
foreach {v x} {mbfnt -menubarfont mefnt -menuentryfont} {
if {[string length [Widget::getoption $path $x]]} {
set $v [list -font [Widget::getoption $path $x]]
} else {
set $v ""
}
}
if {$tcl_platform(platform) == "unix"} {
set menuopts [list -background [Widget::getoption $path -background] \
-borderwidth 1]
} else {
set menuopts [list]
}
set menubar [eval [list menu $top.menubar -tearoff 0] $menuopts $mbfnt]
$top configure -menu $menubar
set count 0
foreach {name tags menuid tearoff entries} $descmenu {
set opt [_parse_name $name]
if {[string length $menuid]
&& ![info exists _widget($path,menuid,$menuid)] } {
# menu has identifier
# we use it for its pathname, to enable special menu entries
# (help, system, ...)
set menu $menubar.$menuid
} else {
set menu $menubar.menu$count
}
eval [list $menubar add cascade] $opt [list -menu $menu]
eval [list menu $menu -tearoff $tearoff] $menuopts $mefnt
foreach tag $tags {
lappend _widget($path,tags,$tag) $menubar $count
# ericm@scriptics: Add a tagstate tracker
if { ![info exists _widget($path,tagstate,$tag)] } {
set _widget($path,tagstate,$tag) 1
}
}
# ericm@scriptics: Add mapping from menu items to tags
set _widget($path,menutags,[list $menubar $count]) $tags
if { [string length $menuid] } {
# menu has identifier
set _widget($path,menuid,$menuid) $menu
}
_create_entries $path $menu $menuopts $entries
incr count
}
}
# ----------------------------------------------------------------------------
# Command MainFrame::_create_entries
# ----------------------------------------------------------------------------
proc MainFrame::_create_entries { path menu menuopts entries } {
variable _widget
set count [$menu cget -tearoff]
set registered 0
foreach entry $entries {
set len [llength $entry]
set type [lindex $entry 0]
if { [string equal $type "separator"] } {
$menu add separator
incr count
continue
}
# entry name and tags
set opt [_parse_name [lindex $entry 1]]
set tags [lindex $entry 2]
foreach tag $tags {
lappend _widget($path,tags,$tag) $menu $count
# ericm@scriptics: Add a tagstate tracker
if { ![info exists _widget($path,tagstate,$tag)] } {
set _widget($path,tagstate,$tag) 1
}
}
# ericm@scriptics: Add mapping from menu items to tags
set _widget($path,menutags,[list $menu $count]) $tags
if {[string equal $type "cascade"] || [string equal $type "cascad"]} {
set menuid [lindex $entry 3]
set tearoff [lindex $entry 4]
set submenu $menu.menu$count
eval [list $menu add cascade] $opt [list -menu $submenu]
eval [list menu $submenu -tearoff $tearoff] $menuopts
if { [string length $menuid] } {
# menu has identifier
set _widget($path,menuid,$menuid) $submenu
}
_create_entries $path $submenu $menuopts [lindex $entry 5]
incr count
continue
}
# entry help description
set desc [lindex $entry 3]
if { [string length $desc] } {
if { !$registered } {
DynamicHelp::register $menu menu [Widget::getoption $path -textvariable]
set registered 1
}
DynamicHelp::register $menu menuentry $count $desc
}
# entry accelerator
set accel [_parse_accelerator [lindex $entry 4]]
if { [llength $accel] } {
lappend opt -accelerator [lindex $accel 0]
bind $_widget($path,top) [lindex $accel 1] [list $menu invoke $count]
}
# user options
set useropt [lrange $entry 5 end]
if { [string equal $type "command"] ||
[string equal $type "radiobutton"] ||
[string equal $type "checkbutton"] } {
eval [list $menu add $type] $opt $useropt
} else {
return -code error "invalid menu type \"$type\""
}
incr count
}
}
|