]> cvs.zerfleddert.de Git - micropolis/blob - res/tk.tlb
Import Micropolis from http://www.donhopkins.com/home/micropolis/
[micropolis] / res / tk.tlb
1 #@package: button.tcl tk_butEnter tk_butLeave tk_butDown tk_butUp
2
3 # button.tcl --
4 #
5 # This file contains Tcl procedures used to manage Tk buttons.
6 #
7 # $Header: /user6/ouster/wish/scripts/RCS/button.tcl,v 1.7 92/07/28 15:41:13 ouster Exp $ SPRITE (Berkeley)
8 #
9 # Copyright 1992 Regents of the University of California
10 # Permission to use, copy, modify, and distribute this
11 # software and its documentation for any purpose and without
12 # fee is hereby granted, provided that this copyright
13 # notice appears in all copies. The University of California
14 # makes no representations about the suitability of this
15 # software for any purpose. It is provided "as is" without
16 # express or implied warranty.
17 #
18
19 # The procedure below is invoked when the mouse pointer enters a
20 # button widget. It records the button we're in and changes the
21 # state of the button to active unless the button is disabled.
22
23 proc tk_butEnter w {
24 global tk_priv tk_strictMotif
25 if {[lindex [$w config -state] 4] != "disabled"} {
26 if {!$tk_strictMotif} {
27 $w config -state active
28 }
29 set tk_priv(window) $w
30 }
31 }
32
33 # The procedure below is invoked when the mouse pointer leaves a
34 # button widget. It changes the state of the button back to
35 # inactive.
36
37 proc tk_butLeave w {
38 global tk_priv tk_strictMotif
39 if {[lindex [$w config -state] 4] != "disabled"} {
40 if {!$tk_strictMotif} {
41 $w config -state normal
42 }
43 }
44 set tk_priv(window) ""
45 }
46
47 # The procedure below is invoked when the mouse button is pressed in
48 # a button/radiobutton/checkbutton widget. It records information
49 # (a) to indicate that the mouse is in the button, and
50 # (b) to save the button's relief so it can be restored later.
51
52 proc tk_butDown w {
53 global tk_priv
54 set tk_priv(relief) [lindex [$w config -relief] 4]
55 if {[lindex [$w config -state] 4] != "disabled"} {
56 $w config -relief sunken
57 }
58 }
59
60 # The procedure below is invoked when the mouse button is released
61 # for a button/radiobutton/checkbutton widget. It restores the
62 # button's relief and invokes the command as long as the mouse
63 # hasn't left the button.
64
65 proc tk_butUp w {
66 global tk_priv
67 $w config -relief $tk_priv(relief)
68 if {($w == $tk_priv(window))
69 && ([lindex [$w config -state] 4] != "disabled")} {
70 uplevel #0 [list $w invoke]
71 }
72 }
73 #@package: listbox.tcl tk_listboxSingleSelect
74
75 # listbox.tcl --
76 #
77 # This file contains Tcl procedures used to manage Tk listboxes.
78 #
79 # $Header: /user6/ouster/wish/scripts/RCS/listbox.tcl,v 1.2 92/06/03 15:21:28 ouster Exp $ SPRITE (Berkeley)
80 #
81 # Copyright 1992 Regents of the University of California
82 # Permission to use, copy, modify, and distribute this
83 # software and its documentation for any purpose and without
84 # fee is hereby granted, provided that this copyright
85 # notice appears in all copies. The University of California
86 # makes no representations about the suitability of this
87 # software for any purpose. It is provided "as is" without
88 # express or implied warranty.
89 #
90
91 # The procedure below may be invoked to change the behavior of
92 # listboxes so that only a single item may be selected at once.
93 # The arguments give one or more windows whose behavior should
94 # be changed; if one of the arguments is "Listbox" then the default
95 # behavior is changed for all listboxes.
96
97 proc tk_listboxSingleSelect args {
98 foreach w $args {
99 bind $w <B1-Motion> {%W select from [%W nearest %y]}
100 bind $w <Shift-1> {%W select from [%W nearest %y]}
101 bind $w <Shift-B1-Motion> {%W select from [%W nearest %y]}
102 }
103 }
104 #@package: tkerror.tcl tkerror
105
106 # This file contains a default version of the tkError procedure. It
107 # just prints out a stack trace.
108
109 proc tkerror err {
110 global errorInfo
111 puts stdout "$errorInfo"
112 }
113 #@package: text.tcl tk_textSelectTo tk_textBackspace tk_textIndexCloser tk_textResetAnchor
114
115 # text.tcl --
116 #
117 # This file contains Tcl procedures used to manage Tk entries.
118 #
119 # $Header: /user6/ouster/wish/scripts/RCS/text.tcl,v 1.2 92/07/16 16:26:33 ouster Exp $ SPRITE (Berkeley)
120 #
121 # Copyright 1992 Regents of the University of California
122 # Permission to use, copy, modify, and distribute this
123 # software and its documentation for any purpose and without
124 # fee is hereby granted, provided that this copyright
125 # notice appears in all copies. The University of California
126 # makes no representations about the suitability of this
127 # software for any purpose. It is provided "as is" without
128 # express or implied warranty.
129 #
130
131 # The procedure below is invoked when dragging one end of the selection.
132 # The arguments are the text window name and the index of the character
133 # that is to be the new end of the selection.
134
135 proc tk_textSelectTo {w index} {
136 global tk_priv
137
138 case $tk_priv(selectMode) {
139 char {
140 if [$w compare $index < anchor] {
141 set first $index
142 set last anchor
143 } else {
144 set first anchor
145 set last [$w index $index+1c]
146 }
147 }
148 word {
149 if [$w compare $index < anchor] {
150 set first [$w index "$index wordstart"]
151 set last [$w index "anchor wordend"]
152 } else {
153 set first [$w index "anchor wordstart"]
154 set last [$w index "$index wordend"]
155 }
156 }
157 line {
158 if [$w compare $index < anchor] {
159 set first [$w index "$index linestart"]
160 set last [$w index "anchor lineend + 1c"]
161 } else {
162 set first [$w index "anchor linestart"]
163 set last [$w index "$index lineend + 1c"]
164 }
165 }
166 }
167 $w tag remove sel 0.0 $first
168 $w tag add sel $first $last
169 $w tag remove sel $last end
170 }
171
172 # The procedure below is invoked to backspace over one character in
173 # a text widget. The name of the widget is passed as argument.
174
175 proc tk_textBackspace w {
176 $w delete insert-1c insert
177 }
178
179 # The procedure below compares three indices, a, b, and c. Index b must
180 # be less than c. The procedure returns 1 if a is closer to b than to c,
181 # and 0 otherwise. The "w" argument is the name of the text widget in
182 # which to do the comparison.
183
184 proc tk_textIndexCloser {w a b c} {
185 set a [$w index $a]
186 set b [$w index $b]
187 set c [$w index $c]
188 if [$w compare $a <= $b] {
189 return 1
190 }
191 if [$w compare $a >= $c] {
192 return 0
193 }
194 scan $a "%d.%d" lineA chA
195 scan $b "%d.%d" lineB chB
196 scan $c "%d.%d" lineC chC
197 if {$chC == 0} {
198 incr lineC -1
199 set chC [string length [$w get $lineC.0 $lineC.end]]
200 }
201 if {$lineB != $lineC} {
202 return [expr {($lineA-$lineB) < ($lineC-$lineA)}]
203 }
204 return [expr {($chA-$chB) < ($chC-$chA)}]
205 }
206
207 # The procedure below is called to reset the selection anchor to
208 # whichever end is FARTHEST from the index argument.
209
210 proc tk_textResetAnchor {w index} {
211 global tk_priv
212 if {[$w tag ranges sel] == ""} {
213 set tk_priv(selectMode) char
214 $w mark set anchor $index
215 return
216 }
217 if [tk_textIndexCloser $w $index sel.first sel.last] {
218 if {$tk_priv(selectMode) == "char"} {
219 $w mark set anchor sel.last
220 } else {
221 $w mark set anchor sel.last-1c
222 }
223 } else {
224 $w mark set anchor sel.first
225 }
226 }
227 #@package: menu.tcl tk_menus tk_bindForTraversal tk_mbPost tk_mbUnpost tk_traverseToMenu tk_traverseWithinMenu tk_getMenuButtons tk_nextMenu tk_nextMenuEntry tk_invokeMenu tk_firstMenu
228
229 # menu.tcl --
230 #
231 # This file contains Tcl procedures used to manage Tk menus and
232 # menubuttons. Most of the code here is dedicated to support for
233 # menu traversal via the keyboard.
234 #
235 # $Header: /user6/ouster/wish/scripts/RCS/menu.tcl,v 1.11 92/08/08 14:49:55 ouster Exp $ SPRITE (Berkeley)
236 #
237 # Copyright 1992 Regents of the University of California
238 # Permission to use, copy, modify, and distribute this
239 # software and its documentation for any purpose and without
240 # fee is hereby granted, provided that this copyright
241 # notice appears in all copies. The University of California
242 # makes no representations about the suitability of this
243 # software for any purpose. It is provided "as is" without
244 # express or implied warranty.
245 #
246
247 # The procedure below is publically available. It is used to indicate
248 # the menus associated with a particular top-level window, for purposes
249 # of keyboard menu traversal. Its first argument is the path name of
250 # a top-level window, and any additional arguments are the path names of
251 # the menu buttons associated with that top-level window, in the order
252 # they should be traversed. If no menu buttons are named, the procedure
253 # returns the current list of menus for w. If a single empty string is
254 # supplied, then the menu list for w is cancelled. Otherwise, tk_menus
255 # sets the menu list for w to the menu buttons.
256
257 proc tk_menus {w args} {
258 global tk_priv
259
260 if {$args == ""} {
261 if [catch {set result [set tk_priv(menusFor$w)]}] {
262 return ""
263 }
264 return $result
265 }
266
267 if {$args == "{}"} {
268 catch {unset tk_priv(menusFor$w)}
269 return ""
270 }
271
272 set tk_priv(menusFor$w) $args
273 }
274
275 # The procedure below is publically available. It takes any number of
276 # arguments taht are names of widgets or classes. It sets up bindings
277 # for the widgets or classes so that keyboard menu traversal is possible
278 # when the input focus is in those widgets or classes.
279
280 proc tk_bindForTraversal args {
281 foreach w $args {
282 bind $w <Alt-KeyPress> {tk_traverseToMenu %W %A}
283 bind $w <F10> {tk_firstMenu %W}
284 }
285 }
286
287 # The procedure below does all of the work of posting a menu (including
288 # unposting any other menu that might currently be posted). The "w"
289 # argument is the name of the menubutton for the menu to be posted.
290 # Note: if $w is disabled then the procedure does nothing.
291
292 proc tk_mbPost {w} {
293 global tk_priv tk_strictMotif
294 if {[lindex [$w config -state] 4] == "disabled"} {
295 return
296 }
297 set cur $tk_priv(posted)
298 if {$cur == $w} {
299 return
300 }
301 if {$cur != ""} tk_mbUnpost
302 set tk_priv(relief) [lindex [$w config -relief] 4]
303 $w config -relief raised
304 set tk_priv(cursor) [lindex [$w config -cursor] 4]
305 $w config -cursor arrow
306 $w post
307 grab -global $w
308 set tk_priv(posted) $w
309 if {$tk_priv(focus) == ""} {
310 set tk_priv(focus) [focus]
311 }
312 set menu [lindex [$w config -menu] 4]
313 set tk_priv(activeBg) [lindex [$menu config -activebackground] 4]
314 set tk_priv(activeFg) [lindex [$menu config -activeforeground] 4]
315 if $tk_strictMotif {
316 $menu config -activebackground [lindex [$menu config -background] 4]
317 $menu config -activeforeground [lindex [$menu config -foreground] 4]
318 }
319 focus $menu
320 }
321
322 # The procedure below does all the work of unposting the menubutton that's
323 # currently posted. It takes no arguments.
324
325 proc tk_mbUnpost {} {
326 global tk_priv
327 if {$tk_priv(posted) != ""} {
328 $tk_priv(posted) config -relief $tk_priv(relief)
329 $tk_priv(posted) config -cursor $tk_priv(cursor)
330 $tk_priv(posted) config -activebackground $tk_priv(activeBg)
331 $tk_priv(posted) config -activeforeground $tk_priv(activeFg)
332 $tk_priv(posted) unpost
333 grab none
334 focus $tk_priv(focus)
335 set tk_priv(focus) ""
336 set menu [lindex [$tk_priv(posted) config -menu] 4]
337 $menu config -activebackground $tk_priv(activeBg)
338 $menu config -activeforeground $tk_priv(activeFg)
339 set tk_priv(posted) {}
340 }
341 }
342
343 # The procedure below is invoked to implement keyboard traversal to
344 # a menu button. It takes two arguments: the name of a window where
345 # a keystroke originated, and the ascii character that was typed.
346 # This procedure finds a menu bar by looking upward for a top-level
347 # window, then looking for a window underneath that named "menu".
348 # Then it searches through all the subwindows of "menu" for a menubutton
349 # with an underlined character matching char. If one is found, it
350 # posts that menu.
351
352 proc tk_traverseToMenu {w char} {
353 global tk_priv
354 if {$char == ""} {
355 return
356 }
357 set char [string tolower $char]
358
359 foreach mb [tk_getMenuButtons $w] {
360 if {[winfo class $mb] == "Menubutton"} {
361 set char2 [string index [lindex [$mb config -text] 4] \
362 [lindex [$mb config -underline] 4]]
363 if {[string compare $char [string tolower $char2]] == 0} {
364 tk_mbPost $mb
365 [lindex [$mb config -menu] 4] activate 0
366 return
367 }
368 }
369 }
370 }
371
372 # The procedure below is used to implement keyboard traversal within
373 # the posted menu. It takes two arguments: the name of the menu to
374 # be traversed within, and an ASCII character. It searches for an
375 # entry in the menu that has that character underlined. If such an
376 # entry is found, it is invoked and the menu is unposted.
377
378 proc tk_traverseWithinMenu {w char} {
379 if {$char == ""} {
380 return
381 }
382 set char [string tolower $char]
383 set last [$w index last]
384 for {set i 0} {$i <= $last} {incr i} {
385 if [catch {set char2 [string index \
386 [lindex [$w entryconfig $i -label] 4] \
387 [lindex [$w entryconfig $i -underline] 4]]}] {
388 continue
389 }
390 if {[string compare $char [string tolower $char2]] == 0} {
391 tk_mbUnpost
392 $w invoke $i
393 return
394 }
395 }
396 }
397
398 # The procedure below takes a single argument, which is the name of
399 # a window. It returns a list containing path names for all of the
400 # menu buttons associated with that window's top-level window, or an
401 # empty list if there are none.
402
403 proc tk_getMenuButtons w {
404 global tk_priv
405 set top [winfo toplevel $w]
406 if [catch {set buttons [set tk_priv(menusFor$top)]}] {
407 return ""
408 }
409 return $buttons
410 }
411
412 # The procedure below is used to traverse to the next or previous
413 # menu in a menu bar. It takes one argument, which is a count of
414 # how many menu buttons forward or backward (if negative) to move.
415 # If there is no posted menu then this procedure has no effect.
416
417 proc tk_nextMenu count {
418 global tk_priv
419 if {$tk_priv(posted) == ""} {
420 return
421 }
422 set buttons [tk_getMenuButtons $tk_priv(posted)]
423 set length [llength $buttons]
424 for {set i 0} 1 {incr i} {
425 if {$i >= $length} {
426 return
427 }
428 if {[lindex $buttons $i] == $tk_priv(posted)} {
429 break
430 }
431 }
432 incr i $count
433 while 1 {
434 while {$i < 0} {
435 incr i $length
436 }
437 while {$i >= $length} {
438 incr i -$length
439 }
440 set mb [lindex $buttons $i]
441 if {[lindex [$mb configure -state] 4] != "disabled"} {
442 break
443 }
444 incr i $count
445 }
446 tk_mbUnpost
447 tk_mbPost $mb
448 [lindex [$mb config -menu] 4] activate 0
449 }
450
451 # The procedure below is used to traverse to the next or previous entry
452 # in the posted menu. It takes one argument, which is 1 to go to the
453 # next entry or -1 to go to the previous entry. Disabled entries are
454 # skipped in this process.
455
456 proc tk_nextMenuEntry count {
457 global tk_priv
458 if {$tk_priv(posted) == ""} {
459 return
460 }
461 set menu [lindex [$tk_priv(posted) config -menu] 4]
462 set length [expr [$menu index last]+1]
463 set i [$menu index active]
464 if {$i == "none"} {
465 set i 0
466 } else {
467 incr i $count
468 }
469 while 1 {
470 while {$i < 0} {
471 incr i $length
472 }
473 while {$i >= $length} {
474 incr i -$length
475 }
476 if {[catch {$menu entryconfigure $i -state} state] == 0} {
477 if {[lindex $state 4] != "disabled"} {
478 break
479 }
480 }
481 incr i $count
482 }
483 $menu activate $i
484 }
485
486 # The procedure below invokes the active entry in the posted menu,
487 # if there is one. Otherwise it does nothing.
488
489 proc tk_invokeMenu {menu} {
490 set i [$menu index active]
491 if {$i != "none"} {
492 tk_mbUnpost
493 update idletasks
494 $menu invoke $i
495 }
496 }
497
498 # The procedure below is invoked to keyboard-traverse to the first
499 # menu for a given source window. The source window is passed as
500 # parameter.
501
502 proc tk_firstMenu w {
503 set mb [lindex [tk_getMenuButtons $w] 0]
504 if {$mb != ""} {
505 tk_mbPost $mb
506 [lindex [$mb config -menu] 4] activate 0
507 }
508 }
509
510 # The procedure below is invoked when a button-1-down event is
511 # received by a menu button. If the mouse is in the menu button
512 # then it posts the button's menu. If the mouse isn't in the
513 # button's menu, then it deactivates any active entry in the menu.
514 # Remember, event-sharing can cause this procedure to be invoked
515 # for two different menu buttons on the same event.
516
517 proc tk_mbButtonDown w {
518 global tk_priv
519 if {[lindex [$w config -state] 4] == "disabled"} {
520 return
521 }
522 if {$tk_priv(inMenuButton) == $w} {
523 tk_mbPost $w
524 }
525 set menu [lindex [$tk_priv(posted) config -menu] 4]
526 if {$tk_priv(window) != $menu} {
527 $menu activate none
528 }
529 }
530 #@package: entry.tcl tk_entryBackspace tk_entryBackword tk_entrySeeCaret
531
532 # entry.tcl --
533 #
534 # This file contains Tcl procedures used to manage Tk entries.
535 #
536 # $Header: /user6/ouster/wish/scripts/RCS/entry.tcl,v 1.2 92/05/23 16:40:57 ouster Exp $ SPRITE (Berkeley)
537 #
538 # Copyright 1992 Regents of the University of California
539 # Permission to use, copy, modify, and distribute this
540 # software and its documentation for any purpose and without
541 # fee is hereby granted, provided that this copyright
542 # notice appears in all copies. The University of California
543 # makes no representations about the suitability of this
544 # software for any purpose. It is provided "as is" without
545 # express or implied warranty.
546 #
547
548 # The procedure below is invoked to backspace over one character
549 # in an entry widget. The name of the widget is passed as argument.
550
551 proc tk_entryBackspace w {
552 set x [expr {[$w index cursor] - 1}]
553 if {$x != -1} {$w delete $x}
554 }
555
556 # The procedure below is invoked to backspace over one word in an
557 # entry widget. The name of the widget is passed as argument.
558
559 proc tk_entryBackword w {
560 set string [$w get]
561 set curs [expr [$w index cursor]-1]
562 if {$curs < 0} return
563 for {set x $curs} {$x > 0} {incr x -1} {
564 if {([string first [string index $string $x] " \t"] < 0)
565 && ([string first [string index $string [expr $x-1]] " \t"]
566 >= 0)} {
567 break
568 }
569 }
570 $w delete $x $curs
571 }
572
573 # The procedure below is invoked after insertions. If the caret is not
574 # visible in the window then the procedure adjusts the entry's view to
575 # bring the caret back into the window again.
576
577 proc tk_entrySeeCaret w {
578 set c [$w index cursor]
579 set left [$w index @0]
580 if {$left > $c} {
581 $w view $c
582 return
583 }
584 while {[$w index @[expr [winfo width $w]-5]] < $c} {
585 set left [expr $left+1]
586 $w view $left
587 }
588 }
Impressum, Datenschutz