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
|
#
# windows.tk
#
# Window building/utility routines
#
proc window(open) {name} {
# check if it a mult window open
set mult [regexp -nocase {^([a-z]+)([0-9]+)$} $name a b c]
# create the window
set wname [window(create) $name]
if {$mult} {
# build the window - call directly to force load of tcl code
$b\(build) $c $wname
} else {
# build the window - call directly to force load of tcl code
$name\(build) $wname
# make it a fixed size
window(fix_size) $wname
}
#bind all <Control-C> interrupt
# put windows in the same group as command
wm group $wname .cmd
# for load purposes 8/20/97 BAM
return $name
}
proc window(geometry) {name geom} {
wm geometry [build_Wname $name] $geom
}
proc window(mult_open) {name} {
# find an unused number for the window!
# set i 1
# start at zero for compatibility with DsTool 2 code...
set i 0
while {[winfo exists [build_Wname $name$i]]} {
incr i
}
window(open) $name$i
# for load purposes 8/20/97 BAM
return $name$i
}
proc window(create) name {
global COLOR
# assign a tk name
set wname [build_Wname $name]
# if window already exists, deiconify and bring to front
if [winfo exists $wname] {
wm deiconify $wname
raise $wname
return $wname
}
# create new window
build_Toplevel $name
# create bindings
bind $wname <Enter> "window(exec) $name enter"
bind $wname <Leave> "window(exec) $name leave"
# catch close event from window manager
wm protocol $wname WM_DELETE_WINDOW "window(dismiss) $name"
# register it in our listings of windows
window(register) $name
# return the tk name
return $wname
}
proc window(register) name {
global window
lappend window(names) $name
}
proc window(deregister) name {
global window
set n [lsearch $window(names) $name]
if {$n < 0} {
puts "Error - dismissed window $name not in my window register!"
puts " Register: $window(names)"
} else {
set window(names) [lreplace $window(names) $n $n]
}
}
proc window(rebuild) {} {
global window
begin_wait "Rebuilding all windows"
foreach n $window(names) {
set wname [build_Wname $n]
window(exec) $n build $wname
if {[winfo exists $wname]} {
wm geometry $wname {}
}
}
end_wait
}
proc window(dismiss) name {
set wname [build_Wname $name]
if [winfo exists $wname] {
window(exec) $name leave
window(deregister) $name
window(exec) $name dismiss
destroy $wname
} else {
puts "Window $name does not exist."
}
}
proc window(exec) {name procname args} {
set mult [regexp -nocase {^([a-z]+)([0-9]+)$} $name a b c]
if {$mult} {
if { [llength [info procs "$b\($procname)"] ] == 1} {
eval [concat "$b\($procname)" $c $args]
}
} else {
if { [llength [info procs "$name\($procname)"] ] == 1} {
eval [concat "$name\($procname)" $args]
}
}
}
proc window(fix_size) {wname} {
#regexp {^([0-9]*)\x([0-9]*)\+} [wm geometry $name] ttt width height
#wm minsize $name $width $height
#wm maxsize $name $width $height
wm resizable $wname 0 0
}
proc window(refresh_all) {} {
oneD(refresh_all)
twoD(refresh_all)
}
# proc window(destroy_almost_all)
#
# Destroys and deregisters all windows, except the command window.
# This procedure is usually used when loading a file.
#
proc window(destroy_almost_all) {} {
global window
for {set i [expr [llength $window(names)]-1]} {$i>0} {incr i -1} {
if {[lindex $window(names) $i] != "filesl"} {
window(dismiss) [lindex $window(names) $i]
}
}
}
# proc window(rebuild_nonview)
#
# Rebuilds all windows, except the twoD and oneD view windows.
# This procedure is used e.g. after loading a file which might have changed
# some of the attributes underlying the Popup menus.
#
proc window(rebuild_nonview) {} {
global window
for {set i 0} {$i < [llength $window(names)]} {incr i} {
puts [lindex $window(names) $i]
if {[regexp -nocase {^([a-z]+)([0-9]+)$} [lindex $window(names) $i] a b c] == 0} {
puts [lindex $window(names) $i]
window(open) [lindex $window(names) $i]
}
}
}
|
