1 | # tk.tcl -- |
---|
2 | # |
---|
3 | # Initialization script normally executed in the interpreter for each |
---|
4 | # Tk-based application. Arranges class bindings for widgets. |
---|
5 | # |
---|
6 | # RCS: @(#) $Id: tk.tcl,v 1.20 2000/03/24 19:38:57 ericm Exp $ |
---|
7 | # |
---|
8 | # Copyright (c) 1992-1994 The Regents of the University of California. |
---|
9 | # Copyright (c) 1994-1996 Sun Microsystems, Inc. |
---|
10 | # Copyright (c) 1998-2000 Scriptics Corporation. |
---|
11 | # |
---|
12 | # See the file "license.terms" for information on usage and redistribution |
---|
13 | # of this file, and for a DISCLAIMER OF ALL WARRANTIES. |
---|
14 | |
---|
15 | # Insist on running with compatible versions of Tcl and Tk. |
---|
16 | |
---|
17 | package require -exact Tk 8.3 |
---|
18 | package require -exact Tcl 8.3 |
---|
19 | |
---|
20 | # Add Tk's directory to the end of the auto-load search path, if it |
---|
21 | # isn't already on the path: |
---|
22 | |
---|
23 | if {[info exists auto_path] && [string compare {} $tk_library] && \ |
---|
24 | [lsearch -exact $auto_path $tk_library] < 0} { |
---|
25 | lappend auto_path $tk_library |
---|
26 | } |
---|
27 | |
---|
28 | # Turn off strict Motif look and feel as a default. |
---|
29 | |
---|
30 | set tk_strictMotif 0 |
---|
31 | |
---|
32 | # Create a ::tk namespace |
---|
33 | |
---|
34 | namespace eval ::tk { |
---|
35 | } |
---|
36 | |
---|
37 | # ::tk::PlaceWindow -- |
---|
38 | # place a toplevel at a particular position |
---|
39 | # Arguments: |
---|
40 | # toplevel name of toplevel window |
---|
41 | # ?placement? pointer ?center? ; places $w centered on the pointer |
---|
42 | # widget widgetPath ; centers $w over widget_name |
---|
43 | # defaults to placing toplevel in the middle of the screen |
---|
44 | # ?anchor? center or widgetPath |
---|
45 | # Results: |
---|
46 | # Returns nothing |
---|
47 | # |
---|
48 | proc ::tk::PlaceWindow {w {place ""} {anchor ""}} { |
---|
49 | wm withdraw $w |
---|
50 | update idletasks |
---|
51 | set checkBounds 1 |
---|
52 | if {[string equal -len [string length $place] $place "pointer"]} { |
---|
53 | ## place at POINTER (centered if $anchor == center) |
---|
54 | if {[string equal -len [string length $anchor] $anchor "center"]} { |
---|
55 | set x [expr {[winfo pointerx $w]-[winfo reqwidth $w]/2}] |
---|
56 | set y [expr {[winfo pointery $w]-[winfo reqheight $w]/2}] |
---|
57 | } else { |
---|
58 | set x [winfo pointerx $w] |
---|
59 | set y [winfo pointery $w] |
---|
60 | } |
---|
61 | } elseif {[string equal -len [string length $place] $place "widget"] && \ |
---|
62 | [winfo exists $anchor] && [winfo ismapped $anchor]} { |
---|
63 | ## center about WIDGET $anchor, widget must be mapped |
---|
64 | set x [expr {[winfo rootx $anchor] + \ |
---|
65 | ([winfo width $anchor]-[winfo reqwidth $w])/2}] |
---|
66 | set y [expr {[winfo rooty $anchor] + \ |
---|
67 | ([winfo height $anchor]-[winfo reqheight $w])/2}] |
---|
68 | } else { |
---|
69 | set x [expr {([winfo screenwidth $w]-[winfo reqwidth $w])/2}] |
---|
70 | set y [expr {([winfo screenheight $w]-[winfo reqheight $w])/2}] |
---|
71 | set checkBounds 0 |
---|
72 | } |
---|
73 | if {$checkBounds} { |
---|
74 | if {$x < 0} { |
---|
75 | set x 0 |
---|
76 | } elseif {$x > ([winfo screenwidth $w]-[winfo reqwidth $w])} { |
---|
77 | set x [expr {[winfo screenwidth $w]-[winfo reqwidth $w]}] |
---|
78 | } |
---|
79 | if {$y < 0} { |
---|
80 | set y 0 |
---|
81 | } elseif {$y > ([winfo screenheight $w]-[winfo reqheight $w])} { |
---|
82 | set y [expr {[winfo screenheight $w]-[winfo reqheight $w]}] |
---|
83 | } |
---|
84 | } |
---|
85 | wm geometry $w +$x+$y |
---|
86 | wm deiconify $w |
---|
87 | } |
---|
88 | |
---|
89 | # ::tk::SetFocusGrab -- |
---|
90 | # swap out current focus and grab temporarily (for dialogs) |
---|
91 | # Arguments: |
---|
92 | # grab new window to grab |
---|
93 | # focus window to give focus to |
---|
94 | # Results: |
---|
95 | # Returns nothing |
---|
96 | # |
---|
97 | proc ::tk::SetFocusGrab {grab {focus {}}} { |
---|
98 | set index "$grab,$focus" |
---|
99 | upvar ::tk::FocusGrab($index) data |
---|
100 | |
---|
101 | lappend data [focus] |
---|
102 | set oldGrab [grab current $grab] |
---|
103 | lappend data $oldGrab |
---|
104 | if {[winfo exists $oldGrab]} { |
---|
105 | lappend data [grab status $oldGrab] |
---|
106 | } |
---|
107 | grab $grab |
---|
108 | if {[winfo exists $focus]} { |
---|
109 | focus $focus |
---|
110 | } |
---|
111 | } |
---|
112 | |
---|
113 | # ::tk::RestoreFocusGrab -- |
---|
114 | # restore old focus and grab (for dialogs) |
---|
115 | # Arguments: |
---|
116 | # grab window that had taken grab |
---|
117 | # focus window that had taken focus |
---|
118 | # destroy destroy|withdraw - how to handle the old grabbed window |
---|
119 | # Results: |
---|
120 | # Returns nothing |
---|
121 | # |
---|
122 | proc ::tk::RestoreFocusGrab {grab focus {destroy destroy}} { |
---|
123 | set index "$grab,$focus" |
---|
124 | foreach {oldFocus oldGrab oldStatus} $::tk::FocusGrab($index) { break } |
---|
125 | unset ::tk::FocusGrab($index) |
---|
126 | |
---|
127 | catch {focus $oldFocus} |
---|
128 | grab release $grab |
---|
129 | if {[string equal $destroy "withdraw"]} { |
---|
130 | wm withdraw $grab |
---|
131 | } else { |
---|
132 | destroy $grab |
---|
133 | } |
---|
134 | if {[winfo exists $oldGrab] && [winfo ismapped $oldGrab]} { |
---|
135 | if {[string equal $oldStatus "global"]} { |
---|
136 | grab -global $oldGrab |
---|
137 | } else { |
---|
138 | grab $oldGrab |
---|
139 | } |
---|
140 | } |
---|
141 | } |
---|
142 | |
---|
143 | # tkScreenChanged -- |
---|
144 | # This procedure is invoked by the binding mechanism whenever the |
---|
145 | # "current" screen is changing. The procedure does two things. |
---|
146 | # First, it uses "upvar" to make global variable "tkPriv" point at an |
---|
147 | # array variable that holds state for the current display. Second, |
---|
148 | # it initializes the array if it didn't already exist. |
---|
149 | # |
---|
150 | # Arguments: |
---|
151 | # screen - The name of the new screen. |
---|
152 | |
---|
153 | proc tkScreenChanged screen { |
---|
154 | set x [string last . $screen] |
---|
155 | if {$x > 0} { |
---|
156 | set disp [string range $screen 0 [expr {$x - 1}]] |
---|
157 | } else { |
---|
158 | set disp $screen |
---|
159 | } |
---|
160 | |
---|
161 | uplevel #0 upvar #0 tkPriv.$disp tkPriv |
---|
162 | global tkPriv |
---|
163 | global tcl_platform |
---|
164 | |
---|
165 | if {[info exists tkPriv]} { |
---|
166 | set tkPriv(screen) $screen |
---|
167 | return |
---|
168 | } |
---|
169 | array set tkPriv { |
---|
170 | activeMenu {} |
---|
171 | activeItem {} |
---|
172 | afterId {} |
---|
173 | buttons 0 |
---|
174 | buttonWindow {} |
---|
175 | dragging 0 |
---|
176 | focus {} |
---|
177 | grab {} |
---|
178 | initPos {} |
---|
179 | inMenubutton {} |
---|
180 | listboxPrev {} |
---|
181 | menuBar {} |
---|
182 | mouseMoved 0 |
---|
183 | oldGrab {} |
---|
184 | popup {} |
---|
185 | postedMb {} |
---|
186 | pressX 0 |
---|
187 | pressY 0 |
---|
188 | prevPos 0 |
---|
189 | selectMode char |
---|
190 | } |
---|
191 | set tkPriv(screen) $screen |
---|
192 | set tkPriv(tearoff) [string equal $tcl_platform(platform) "unix"] |
---|
193 | set tkPriv(window) {} |
---|
194 | } |
---|
195 | |
---|
196 | # Do initial setup for tkPriv, so that it is always bound to something |
---|
197 | # (otherwise, if someone references it, it may get set to a non-upvar-ed |
---|
198 | # value, which will cause trouble later). |
---|
199 | |
---|
200 | tkScreenChanged [winfo screen .] |
---|
201 | |
---|
202 | # tkEventMotifBindings -- |
---|
203 | # This procedure is invoked as a trace whenever tk_strictMotif is |
---|
204 | # changed. It is used to turn on or turn off the motif virtual |
---|
205 | # bindings. |
---|
206 | # |
---|
207 | # Arguments: |
---|
208 | # n1 - the name of the variable being changed ("tk_strictMotif"). |
---|
209 | |
---|
210 | proc tkEventMotifBindings {n1 dummy dummy} { |
---|
211 | upvar $n1 name |
---|
212 | |
---|
213 | if {$name} { |
---|
214 | set op delete |
---|
215 | } else { |
---|
216 | set op add |
---|
217 | } |
---|
218 | |
---|
219 | event $op <<Cut>> <Control-Key-w> |
---|
220 | event $op <<Copy>> <Meta-Key-w> |
---|
221 | event $op <<Paste>> <Control-Key-y> |
---|
222 | } |
---|
223 | |
---|
224 | #---------------------------------------------------------------------- |
---|
225 | # Define common dialogs on platforms where they are not implemented |
---|
226 | # using compiled code. |
---|
227 | #---------------------------------------------------------------------- |
---|
228 | |
---|
229 | if {[string equal [info commands tk_chooseColor] ""]} { |
---|
230 | proc tk_chooseColor {args} { |
---|
231 | return [eval tkColorDialog $args] |
---|
232 | } |
---|
233 | } |
---|
234 | if {[string equal [info commands tk_getOpenFile] ""]} { |
---|
235 | proc tk_getOpenFile {args} { |
---|
236 | if {$::tk_strictMotif} { |
---|
237 | return [eval tkMotifFDialog open $args] |
---|
238 | } else { |
---|
239 | return [eval ::tk::dialog::file::tkFDialog open $args] |
---|
240 | } |
---|
241 | } |
---|
242 | } |
---|
243 | if {[string equal [info commands tk_getSaveFile] ""]} { |
---|
244 | proc tk_getSaveFile {args} { |
---|
245 | if {$::tk_strictMotif} { |
---|
246 | return [eval tkMotifFDialog save $args] |
---|
247 | } else { |
---|
248 | return [eval ::tk::dialog::file::tkFDialog save $args] |
---|
249 | } |
---|
250 | } |
---|
251 | } |
---|
252 | if {[string equal [info commands tk_messageBox] ""]} { |
---|
253 | proc tk_messageBox {args} { |
---|
254 | return [eval tkMessageBox $args] |
---|
255 | } |
---|
256 | } |
---|
257 | if {[string equal [info command tk_chooseDirectory] ""]} { |
---|
258 | proc tk_chooseDirectory {args} { |
---|
259 | return [eval ::tk::dialog::file::chooseDir::tkChooseDirectory $args] |
---|
260 | } |
---|
261 | } |
---|
262 | |
---|
263 | #---------------------------------------------------------------------- |
---|
264 | # Define the set of common virtual events. |
---|
265 | #---------------------------------------------------------------------- |
---|
266 | |
---|
267 | switch $tcl_platform(platform) { |
---|
268 | "unix" { |
---|
269 | event add <<Cut>> <Control-Key-x> <Key-F20> |
---|
270 | event add <<Copy>> <Control-Key-c> <Key-F16> |
---|
271 | event add <<Paste>> <Control-Key-v> <Key-F18> |
---|
272 | event add <<PasteSelection>> <ButtonRelease-2> |
---|
273 | # Some OS's define a goofy (as in, not <Shift-Tab>) keysym |
---|
274 | # that is returned when the user presses <Shift-Tab>. In order for |
---|
275 | # tab traversal to work, we have to add these keysyms to the |
---|
276 | # PrevWindow event. |
---|
277 | # The info exists is necessary, because tcl_platform(os) doesn't |
---|
278 | # exist in safe interpreters. |
---|
279 | if {[info exists tcl_platform(os)]} { |
---|
280 | switch $tcl_platform(os) { |
---|
281 | "IRIX" - |
---|
282 | "Linux" { event add <<PrevWindow>> <ISO_Left_Tab> } |
---|
283 | "HP-UX" { event add <<PrevWindow>> <hpBackTab> } |
---|
284 | } |
---|
285 | } |
---|
286 | trace variable tk_strictMotif w tkEventMotifBindings |
---|
287 | set tk_strictMotif $tk_strictMotif |
---|
288 | } |
---|
289 | "windows" { |
---|
290 | event add <<Cut>> <Control-Key-x> <Shift-Key-Delete> |
---|
291 | event add <<Copy>> <Control-Key-c> <Control-Key-Insert> |
---|
292 | event add <<Paste>> <Control-Key-v> <Shift-Key-Insert> |
---|
293 | event add <<PasteSelection>> <ButtonRelease-2> |
---|
294 | } |
---|
295 | "macintosh" { |
---|
296 | event add <<Cut>> <Control-Key-x> <Key-F2> |
---|
297 | event add <<Copy>> <Control-Key-c> <Key-F3> |
---|
298 | event add <<Paste>> <Control-Key-v> <Key-F4> |
---|
299 | event add <<PasteSelection>> <ButtonRelease-2> |
---|
300 | event add <<Clear>> <Clear> |
---|
301 | } |
---|
302 | } |
---|
303 | |
---|
304 | # ---------------------------------------------------------------------- |
---|
305 | # Read in files that define all of the class bindings. |
---|
306 | # ---------------------------------------------------------------------- |
---|
307 | |
---|
308 | if {[string compare $tcl_platform(platform) "macintosh"] && \ |
---|
309 | [string compare {} $tk_library]} { |
---|
310 | source [file join $tk_library button.tcl] |
---|
311 | source [file join $tk_library entry.tcl] |
---|
312 | source [file join $tk_library listbox.tcl] |
---|
313 | source [file join $tk_library menu.tcl] |
---|
314 | source [file join $tk_library scale.tcl] |
---|
315 | source [file join $tk_library scrlbar.tcl] |
---|
316 | source [file join $tk_library text.tcl] |
---|
317 | } |
---|
318 | |
---|
319 | # ---------------------------------------------------------------------- |
---|
320 | # Default bindings for keyboard traversal. |
---|
321 | # ---------------------------------------------------------------------- |
---|
322 | |
---|
323 | event add <<PrevWindow>> <Shift-Tab> |
---|
324 | bind all <Tab> {tkTabToWindow [tk_focusNext %W]} |
---|
325 | bind all <<PrevWindow>> {tkTabToWindow [tk_focusPrev %W]} |
---|
326 | |
---|
327 | # tkCancelRepeat -- |
---|
328 | # This procedure is invoked to cancel an auto-repeat action described |
---|
329 | # by tkPriv(afterId). It's used by several widgets to auto-scroll |
---|
330 | # the widget when the mouse is dragged out of the widget with a |
---|
331 | # button pressed. |
---|
332 | # |
---|
333 | # Arguments: |
---|
334 | # None. |
---|
335 | |
---|
336 | proc tkCancelRepeat {} { |
---|
337 | global tkPriv |
---|
338 | after cancel $tkPriv(afterId) |
---|
339 | set tkPriv(afterId) {} |
---|
340 | } |
---|
341 | |
---|
342 | # tkTabToWindow -- |
---|
343 | # This procedure moves the focus to the given widget. If the widget |
---|
344 | # is an entry, it selects the entire contents of the widget. |
---|
345 | # |
---|
346 | # Arguments: |
---|
347 | # w - Window to which focus should be set. |
---|
348 | |
---|
349 | proc tkTabToWindow {w} { |
---|
350 | if {[string equal [winfo class $w] Entry]} { |
---|
351 | $w selection range 0 end |
---|
352 | $w icursor end |
---|
353 | } |
---|
354 | focus $w |
---|
355 | } |
---|