cvs.zerfleddert.de Git - micropolis/blob - 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 }