![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to tk.tlb CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [Micropolis - Activity] / micropolis / res|
Return to tk.tlb CVS log | Up to [Micropolis - Activity] / micropolis / res |
1.1 root 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: }
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.