|
|
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.