util/X86LINUX64/lib/tk8.6/tk.tcl

   1 # tk.tcl --
   2 #
   3 # Initialization script normally executed in the interpreter for each Tk-based
   4 # application.  Arranges class bindings for widgets.
   5 #
   6 # Copyright (c) 1992-1994 The Regents of the University of California.
   7 # Copyright (c) 1994-1996 Sun Microsystems, Inc.
   8 # Copyright (c) 1998-2000 Ajuba Solutions.
   9 #
  10 # See the file "license.terms" for information on usage and redistribution of
  11 # this file, and for a DISCLAIMER OF ALL WARRANTIES.
  12
  13 # Insist on running with compatible version of Tcl
  14 package require Tcl 8.6
  15 # Verify that we have Tk binary and script components from the same release
  16 package require -exact Tk  8.6.4
  17 \f
  18 # Create a ::tk namespace
  19 namespace eval ::tk {
  20     # Set up the msgcat commands
  21     namespace eval msgcat {
  22         namespace export mc mcmax
  23         if {[interp issafe] || [catch {package require msgcat}]} {
  24             # The msgcat package is not available.  Supply our own
  25             # minimal replacement.
  26             proc mc {src args} {
  27                 return [format $src {*}$args]
  28             }
  29             proc mcmax {args} {
  30                 set max 0
  31                 foreach string $args {
  32                     set len [string length $string]
  33                     if {$len>$max} {
  34                         set max $len
  35                     }
  36                 }
  37                 return $max
  38             }
  39         } else {
  40             # Get the commands from the msgcat package that Tk uses.
  41             namespace import ::msgcat::mc
  42             namespace import ::msgcat::mcmax
  43             ::msgcat::mcload [file join $::tk_library msgs]
  44         }
  45     }
  46     namespace import ::tk::msgcat::*
  47 }
  48 # and a ::ttk namespace
  49 namespace eval ::ttk {
  50     if {$::tk_library ne ""} {
  51         # avoid file join to work in safe interps, but this is also x-plat ok
  52         variable library $::tk_library/ttk
  53     }
  54 }
  55
  56 # Add Ttk & Tk's directory to the end of the auto-load search path, if it
  57 # isn't already on the path:
  58
  59 if {[info exists ::auto_path] && ($::tk_library ne "")
  60     && ($::tk_library ni $::auto_path)
  61 } then {
  62     lappend ::auto_path $::tk_library $::ttk::library
  63 }
  64
  65 # Turn off strict Motif look and feel as a default.
  66
  67 set ::tk_strictMotif 0
  68
  69 # Turn on useinputmethods (X Input Methods) by default.
  70 # We catch this because safe interpreters may not allow the call.
  71
  72 catch {tk useinputmethods 1}
  73 \f
  74 # ::tk::PlaceWindow --
  75 #   place a toplevel at a particular position
  76 # Arguments:
  77 #   toplevel    name of toplevel window
  78 #   ?placement? pointer ?center? ; places $w centered on the pointer
  79 #               widget widgetPath ; centers $w over widget_name
  80 #               defaults to placing toplevel in the middle of the screen
  81 #   ?anchor?    center or widgetPath
  82 # Results:
  83 #   Returns nothing
  84 #
  85 proc ::tk::PlaceWindow {w {place ""} {anchor ""}} {
  86     wm withdraw $w
  87     update idletasks
  88     set checkBounds 1
  89     if {$place eq ""} {
  90         set x [expr {([winfo screenwidth $w]-[winfo reqwidth $w])/2}]
  91         set y [expr {([winfo screenheight $w]-[winfo reqheight $w])/2}]
  92         set checkBounds 0
  93     } elseif {[string equal -length [string length $place] $place "pointer"]} {
  94         ## place at POINTER (centered if $anchor == center)
  95         if {[string equal -length [string length $anchor] $anchor "center"]} {
  96             set x [expr {[winfo pointerx $w]-[winfo reqwidth $w]/2}]
  97             set y [expr {[winfo pointery $w]-[winfo reqheight $w]/2}]
  98         } else {
  99             set x [winfo pointerx $w]
 100             set y [winfo pointery $w]
 101         }
 102     } elseif {[string equal -length [string length $place] $place "widget"] && \
 103             [winfo exists $anchor] && [winfo ismapped $anchor]} {
 104         ## center about WIDGET $anchor, widget must be mapped
 105         set x [expr {[winfo rootx $anchor] + \
 106                 ([winfo width $anchor]-[winfo reqwidth $w])/2}]
 107         set y [expr {[winfo rooty $anchor] + \
 108                 ([winfo height $anchor]-[winfo reqheight $w])/2}]
 109     } else {
 110         set x [expr {([winfo screenwidth $w]-[winfo reqwidth $w])/2}]
 111         set y [expr {([winfo screenheight $w]-[winfo reqheight $w])/2}]
 112         set checkBounds 0
 113     }
 114     if {$checkBounds} {
 115         if {$x < [winfo vrootx $w]} {
 116             set x [winfo vrootx $w]
 117         } elseif {$x > ([winfo vrootx $w]+[winfo vrootwidth $w]-[winfo reqwidth $w])} {
 118             set x [expr {[winfo vrootx $w]+[winfo vrootwidth $w]-[winfo reqwidth $w]}]
 119         }
 120         if {$y < [winfo vrooty $w]} {
 121             set y [winfo vrooty $w]
 122         } elseif {$y > ([winfo vrooty $w]+[winfo vrootheight $w]-[winfo reqheight $w])} {
 123             set y [expr {[winfo vrooty $w]+[winfo vrootheight $w]-[winfo reqheight $w]}]
 124         }
 125         if {[tk windowingsystem] eq "aqua"} {
 126             # Avoid the native menu bar which sits on top of everything.
 127             if {$y < 22} {
 128                 set y 22
 129             }
 130         }
 131     }
 132     wm maxsize $w [winfo vrootwidth $w] [winfo vrootheight $w]
 133     wm geometry $w +$x+$y
 134     wm deiconify $w
 135 }
 136 \f
 137 # ::tk::SetFocusGrab --
 138 #   swap out current focus and grab temporarily (for dialogs)
 139 # Arguments:
 140 #   grab        new window to grab
 141 #   focus       window to give focus to
 142 # Results:
 143 #   Returns nothing
 144 #
 145 proc ::tk::SetFocusGrab {grab {focus {}}} {
 146     set index "$grab,$focus"
 147     upvar ::tk::FocusGrab($index) data
 148
 149     lappend data [focus]
 150     set oldGrab [grab current $grab]
 151     lappend data $oldGrab
 152     if {[winfo exists $oldGrab]} {
 153         lappend data [grab status $oldGrab]
 154     }
 155     # The "grab" command will fail if another application
 156     # already holds the grab.  So catch it.
 157     catch {grab $grab}
 158     if {[winfo exists $focus]} {
 159         focus $focus
 160     }
 161 }
 162
 163 # ::tk::RestoreFocusGrab --
 164 #   restore old focus and grab (for dialogs)
 165 # Arguments:
 166 #   grab        window that had taken grab
 167 #   focus       window that had taken focus
 168 #   destroy     destroy|withdraw - how to handle the old grabbed window
 169 # Results:
 170 #   Returns nothing
 171 #
 172 proc ::tk::RestoreFocusGrab {grab focus {destroy destroy}} {
 173     set index "$grab,$focus"
 174     if {[info exists ::tk::FocusGrab($index)]} {
 175         foreach {oldFocus oldGrab oldStatus} $::tk::FocusGrab($index) { break }
 176         unset ::tk::FocusGrab($index)
 177     } else {
 178         set oldGrab ""
 179     }
 180
 181     catch {focus $oldFocus}
 182     grab release $grab
 183     if {$destroy eq "withdraw"} {
 184         wm withdraw $grab
 185     } else {
 186         destroy $grab
 187     }
 188     if {[winfo exists $oldGrab] && [winfo ismapped $oldGrab]} {
 189         if {$oldStatus eq "global"} {
 190             grab -global $oldGrab
 191         } else {
 192             grab $oldGrab
 193         }
 194     }
 195 }
 196 \f
 197 # ::tk::GetSelection --
 198 #   This tries to obtain the default selection.  On Unix, we first try
 199 #   and get a UTF8_STRING, a type supported by modern Unix apps for
 200 #   passing Unicode data safely.  We fall back on the default STRING
 201 #   type otherwise.  On Windows, only the STRING type is necessary.
 202 # Arguments:
 203 #   w   The widget for which the selection will be retrieved.
 204 #       Important for the -displayof property.
 205 #   sel The source of the selection (PRIMARY or CLIPBOARD)
 206 # Results:
 207 #   Returns the selection, or an error if none could be found
 208 #
 209 if {[tk windowingsystem] ne "win32"} {
 210     proc ::tk::GetSelection {w {sel PRIMARY}} {
 211         if {[catch {
 212             selection get -displayof $w -selection $sel -type UTF8_STRING
 213         } txt] && [catch {
 214             selection get -displayof $w -selection $sel
 215         } txt]} then {
 216             return -code error -errorcode {TK SELECTION NONE} \
 217                 "could not find default selection"
 218         } else {
 219             return $txt
 220         }
 221     }
 222 } else {
 223     proc ::tk::GetSelection {w {sel PRIMARY}} {
 224         if {[catch {
 225             selection get -displayof $w -selection $sel
 226         } txt]} then {
 227             return -code error -errorcode {TK SELECTION NONE} \
 228                 "could not find default selection"
 229         } else {
 230             return $txt
 231         }
 232     }
 233 }
 234 \f
 235 # ::tk::ScreenChanged --
 236 # This procedure is invoked by the binding mechanism whenever the
 237 # "current" screen is changing.  The procedure does two things.
 238 # First, it uses "upvar" to make variable "::tk::Priv" point at an
 239 # array variable that holds state for the current display.  Second,
 240 # it initializes the array if it didn't already exist.
 241 #
 242 # Arguments:
 243 # screen -              The name of the new screen.
 244
 245 proc ::tk::ScreenChanged screen {
 246     # Extract the display name.
 247     set disp [string range $screen 0 [string last . $screen]-1]
 248
 249     # Ensure that namespace separators never occur in the display name (as
 250     # they cause problems in variable names). Double-colons exist in some VNC
 251     # display names. [Bug 2912473]
 252     set disp [string map {:: _doublecolon_} $disp]
 253
 254     uplevel #0 [list upvar #0 ::tk::Priv.$disp ::tk::Priv]
 255     variable ::tk::Priv
 256     global tcl_platform
 257
 258     if {[info exists Priv]} {
 259         set Priv(screen) $screen
 260         return
 261     }
 262     array set Priv {
 263         activeMenu      {}
 264         activeItem      {}
 265         afterId         {}
 266         buttons         0
 267         buttonWindow    {}
 268         dragging        0
 269         focus           {}
 270         grab            {}
 271         initPos         {}
 272         inMenubutton    {}
 273         listboxPrev     {}
 274         menuBar         {}
 275         mouseMoved      0
 276         oldGrab         {}
 277         popup           {}
 278         postedMb        {}
 279         pressX          0
 280         pressY          0
 281         prevPos         0
 282         selectMode      char
 283     }
 284     set Priv(screen) $screen
 285     set Priv(tearoff) [string equal [tk windowingsystem] "x11"]
 286     set Priv(window) {}
 287 }
 288
 289 # Do initial setup for Priv, so that it is always bound to something
 290 # (otherwise, if someone references it, it may get set to a non-upvar-ed
 291 # value, which will cause trouble later).
 292
 293 tk::ScreenChanged [winfo screen .]
 294 \f
 295 # ::tk::EventMotifBindings --
 296 # This procedure is invoked as a trace whenever ::tk_strictMotif is
 297 # changed.  It is used to turn on or turn off the motif virtual
 298 # bindings.
 299 #
 300 # Arguments:
 301 # n1 - the name of the variable being changed ("::tk_strictMotif").
 302
 303 proc ::tk::EventMotifBindings {n1 dummy dummy} {
 304     upvar $n1 name
 305
 306     if {$name} {
 307         set op delete
 308     } else {
 309         set op add
 310     }
 311
 312     event $op <<Cut>> <Control-Key-w> <Control-Lock-Key-W> <Shift-Key-Delete>
 313     event $op <<Copy>> <Meta-Key-w> <Meta-Lock-Key-W> <Control-Key-Insert>
 314     event $op <<Paste>> <Control-Key-y> <Control-Lock-Key-Y> <Shift-Key-Insert>
 315     event $op <<Undo>> <Control-underscore>
 316     event $op <<PrevChar>> <Control-Key-b> <Control-Lock-Key-B>
 317     event $op <<NextChar>> <Control-Key-f> <Control-Lock-Key-F>
 318     event $op <<PrevLine>> <Control-Key-p> <Control-Lock-Key-P>
 319     event $op <<NextLine>> <Control-Key-n> <Control-Lock-Key-N>
 320     event $op <<LineStart>> <Control-Key-a> <Control-Lock-Key-A>
 321     event $op <<LineEnd>> <Control-Key-e> <Control-Lock-Key-E>
 322     event $op <<SelectPrevChar>> <Control-Key-B> <Control-Lock-Key-b>
 323     event $op <<SelectNextChar>> <Control-Key-F> <Control-Lock-Key-f>
 324     event $op <<SelectPrevLine>> <Control-Key-P> <Control-Lock-Key-p>
 325     event $op <<SelectNextLine>> <Control-Key-N> <Control-Lock-Key-n>
 326     event $op <<SelectLineStart>> <Control-Key-A> <Control-Lock-Key-a>
 327     event $op <<SelectLineEnd>> <Control-Key-E> <Control-Lock-Key-e>
 328 }
 329 \f
 330 #----------------------------------------------------------------------
 331 # Define common dialogs on platforms where they are not implemented
 332 # using compiled code.
 333 #----------------------------------------------------------------------
 334
 335 if {![llength [info commands tk_chooseColor]]} {
 336     proc ::tk_chooseColor {args} {
 337         return [::tk::dialog::color:: {*}$args]
 338     }
 339 }
 340 if {![llength [info commands tk_getOpenFile]]} {
 341     proc ::tk_getOpenFile {args} {
 342         if {$::tk_strictMotif} {
 343             return [::tk::MotifFDialog open {*}$args]
 344         } else {
 345             return [::tk::dialog::file:: open {*}$args]
 346         }
 347     }
 348 }
 349 if {![llength [info commands tk_getSaveFile]]} {
 350     proc ::tk_getSaveFile {args} {
 351         if {$::tk_strictMotif} {
 352             return [::tk::MotifFDialog save {*}$args]
 353         } else {
 354             return [::tk::dialog::file:: save {*}$args]
 355         }
 356     }
 357 }
 358 if {![llength [info commands tk_messageBox]]} {
 359     proc ::tk_messageBox {args} {
 360         return [::tk::MessageBox {*}$args]
 361     }
 362 }
 363 if {![llength [info command tk_chooseDirectory]]} {
 364     proc ::tk_chooseDirectory {args} {
 365         return [::tk::dialog::file::chooseDir:: {*}$args]
 366     }
 367 }
 368 \f
 369 #----------------------------------------------------------------------
 370 # Define the set of common virtual events.
 371 #----------------------------------------------------------------------
 372
 373 switch -exact -- [tk windowingsystem] {
 374     "x11" {
 375         event add <<Cut>>               <Control-Key-x> <Key-F20> <Control-Lock-Key-X>
 376         event add <<Copy>>              <Control-Key-c> <Key-F16> <Control-Lock-Key-C>
 377         event add <<Paste>>             <Control-Key-v> <Key-F18> <Control-Lock-Key-V>
 378         event add <<PasteSelection>>    <ButtonRelease-2>
 379         event add <<Undo>>              <Control-Key-z> <Control-Lock-Key-Z>
 380         event add <<Redo>>              <Control-Key-Z> <Control-Lock-Key-z>
 381         event add <<ContextMenu>>       <Button-3>
 382         # On Darwin/Aqua, buttons from left to right are 1,3,2.  On Darwin/X11 with recent
 383         # XQuartz as the X server, they are 1,2,3; other X servers may differ.
 384
 385         event add <<SelectAll>>         <Control-Key-slash>
 386         event add <<SelectNone>>        <Control-Key-backslash>
 387         event add <<NextChar>>          <Right>
 388         event add <<SelectNextChar>>    <Shift-Right>
 389         event add <<PrevChar>>          <Left>
 390         event add <<SelectPrevChar>>    <Shift-Left>
 391         event add <<NextWord>>          <Control-Right>
 392         event add <<SelectNextWord>>    <Control-Shift-Right>
 393         event add <<PrevWord>>          <Control-Left>
 394         event add <<SelectPrevWord>>    <Control-Shift-Left>
 395         event add <<LineStart>>         <Home>
 396         event add <<SelectLineStart>>   <Shift-Home>
 397         event add <<LineEnd>>           <End>
 398         event add <<SelectLineEnd>>     <Shift-End>
 399         event add <<PrevLine>>          <Up>
 400         event add <<NextLine>>          <Down>
 401         event add <<SelectPrevLine>>    <Shift-Up>
 402         event add <<SelectNextLine>>    <Shift-Down>
 403         event add <<PrevPara>>          <Control-Up>
 404         event add <<NextPara>>          <Control-Down>
 405         event add <<SelectPrevPara>>    <Control-Shift-Up>
 406         event add <<SelectNextPara>>    <Control-Shift-Down>
 407         event add <<ToggleSelection>>   <Control-ButtonPress-1>
 408
 409         # Some OS's define a goofy (as in, not <Shift-Tab>) keysym that is
 410         # returned when the user presses <Shift-Tab>. In order for tab
 411         # traversal to work, we have to add these keysyms to the PrevWindow
 412         # event. We use catch just in case the keysym isn't recognized.
 413
 414         # This is needed for XFree86 systems
 415         catch { event add <<PrevWindow>> <ISO_Left_Tab> }
 416         # This seems to be correct on *some* HP systems.
 417         catch { event add <<PrevWindow>> <hpBackTab> }
 418
 419         trace add variable ::tk_strictMotif write ::tk::EventMotifBindings
 420         set ::tk_strictMotif $::tk_strictMotif
 421         # On unix, we want to always display entry/text selection,
 422         # regardless of which window has focus
 423         set ::tk::AlwaysShowSelection 1
 424     }
 425     "win32" {
 426         event add <<Cut>>               <Control-Key-x> <Shift-Key-Delete> <Control-Lock-Key-X>
 427         event add <<Copy>>              <Control-Key-c> <Control-Key-Insert> <Control-Lock-Key-C>
 428         event add <<Paste>>             <Control-Key-v> <Shift-Key-Insert> <Control-Lock-Key-V>
 429         event add <<PasteSelection>>    <ButtonRelease-2>
 430         event add <<Undo>>              <Control-Key-z> <Control-Lock-Key-Z>
 431         event add <<Redo>>              <Control-Key-y> <Control-Lock-Key-Y>
 432         event add <<ContextMenu>>       <Button-3>
 433
 434         event add <<SelectAll>>         <Control-Key-slash> <Control-Key-a> <Control-Lock-Key-A>
 435         event add <<SelectNone>>        <Control-Key-backslash>
 436         event add <<NextChar>>          <Right>
 437         event add <<SelectNextChar>>    <Shift-Right>
 438         event add <<PrevChar>>          <Left>
 439         event add <<SelectPrevChar>>    <Shift-Left>
 440         event add <<NextWord>>          <Control-Right>
 441         event add <<SelectNextWord>>    <Control-Shift-Right>
 442         event add <<PrevWord>>          <Control-Left>
 443         event add <<SelectPrevWord>>    <Control-Shift-Left>
 444         event add <<LineStart>>         <Home>
 445         event add <<SelectLineStart>>   <Shift-Home>
 446         event add <<LineEnd>>           <End>
 447         event add <<SelectLineEnd>>     <Shift-End>
 448         event add <<PrevLine>>          <Up>
 449         event add <<NextLine>>          <Down>
 450         event add <<SelectPrevLine>>    <Shift-Up>
 451         event add <<SelectNextLine>>    <Shift-Down>
 452         event add <<PrevPara>>          <Control-Up>
 453         event add <<NextPara>>          <Control-Down>
 454         event add <<SelectPrevPara>>    <Control-Shift-Up>
 455         event add <<SelectNextPara>>    <Control-Shift-Down>
 456         event add <<ToggleSelection>>   <Control-ButtonPress-1>
 457     }
 458     "aqua" {
 459         event add <<Cut>>               <Command-Key-x> <Key-F2> <Command-Lock-Key-X>
 460         event add <<Copy>>              <Command-Key-c> <Key-F3> <Command-Lock-Key-C>
 461         event add <<Paste>>             <Command-Key-v> <Key-F4> <Command-Lock-Key-V>
 462         event add <<PasteSelection>>    <ButtonRelease-3>
 463         event add <<Clear>>             <Clear>
 464         event add <<ContextMenu>>       <Button-2>
 465
 466         # Official bindings
 467         # See http://support.apple.com/kb/HT1343
 468         event add <<SelectAll>>         <Command-Key-a>
 469         event add <<SelectNone>>        <Option-Command-Key-a>
 470         event add <<Undo>>              <Command-Key-z> <Command-Lock-Key-Z>
 471         event add <<Redo>>              <Shift-Command-Key-z> <Shift-Command-Lock-Key-z>
 472         event add <<NextChar>>          <Right> <Control-Key-f> <Control-Lock-Key-F>
 473         event add <<SelectNextChar>>    <Shift-Right> <Shift-Control-Key-F> <Shift-Control-Lock-Key-F>
 474         event add <<PrevChar>>          <Left> <Control-Key-b> <Control-Lock-Key-B>
 475         event add <<SelectPrevChar>>    <Shift-Left> <Shift-Control-Key-B> <Shift-Control-Lock-Key-B>
 476         event add <<NextWord>>          <Option-Right>
 477         event add <<SelectNextWord>>    <Shift-Option-Right>
 478         event add <<PrevWord>>          <Option-Left>
 479         event add <<SelectPrevWord>>    <Shift-Option-Left>
 480         event add <<LineStart>>         <Home> <Command-Left> <Control-Key-a> <Control-Lock-Key-A>
 481         event add <<SelectLineStart>>   <Shift-Home> <Shift-Command-Left> <Shift-Control-Key-A> <Shift-Control-Lock-Key-A>
 482         event add <<LineEnd>>           <End> <Command-Right> <Control-Key-e> <Control-Lock-Key-E>
 483         event add <<SelectLineEnd>>     <Shift-End> <Shift-Command-Right> <Shift-Control-Key-E> <Shift-Control-Lock-Key-E>
 484         event add <<PrevLine>>          <Up> <Control-Key-p> <Control-Lock-Key-P>
 485         event add <<SelectPrevLine>>    <Shift-Up> <Shift-Control-Key-P> <Shift-Control-Lock-Key-P>
 486         event add <<NextLine>>          <Down> <Control-Key-n> <Control-Lock-Key-N>
 487         event add <<SelectNextLine>>    <Shift-Down> <Shift-Control-Key-N> <Shift-Control-Lock-Key-N>
 488         # Not official, but logical extensions of above. Also derived from
 489         # bindings present in MS Word on OSX.
 490         event add <<PrevPara>>          <Option-Up>
 491         event add <<NextPara>>          <Option-Down>
 492         event add <<SelectPrevPara>>    <Shift-Option-Up>
 493         event add <<SelectNextPara>>    <Shift-Option-Down>
 494         event add <<ToggleSelection>>   <Command-ButtonPress-1>
 495     }
 496 }
 497 \f
 498 # ----------------------------------------------------------------------
 499 # Read in files that define all of the class bindings.
 500 # ----------------------------------------------------------------------
 501
 502 if {$::tk_library ne ""} {
 503     proc ::tk::SourceLibFile {file} {
 504         namespace eval :: [list source [file join $::tk_library $file.tcl]]
 505     }
 506     namespace eval ::tk {
 507         SourceLibFile icons
 508         SourceLibFile button
 509         SourceLibFile entry
 510         SourceLibFile listbox
 511         SourceLibFile menu
 512         SourceLibFile panedwindow
 513         SourceLibFile scale
 514         SourceLibFile scrlbar
 515         SourceLibFile spinbox
 516         SourceLibFile text
 517     }
 518 }
 519
 520 # ----------------------------------------------------------------------
 521 # Default bindings for keyboard traversal.
 522 # ----------------------------------------------------------------------
 523
 524 event add <<PrevWindow>> <Shift-Tab>
 525 event add <<NextWindow>> <Tab>
 526 bind all <<NextWindow>> {tk::TabToWindow [tk_focusNext %W]}
 527 bind all <<PrevWindow>> {tk::TabToWindow [tk_focusPrev %W]}
 528 \f
 529 # ::tk::CancelRepeat --
 530 # This procedure is invoked to cancel an auto-repeat action described
 531 # by ::tk::Priv(afterId).  It's used by several widgets to auto-scroll
 532 # the widget when the mouse is dragged out of the widget with a
 533 # button pressed.
 534 #
 535 # Arguments:
 536 # None.
 537
 538 proc ::tk::CancelRepeat {} {
 539     variable ::tk::Priv
 540     after cancel $Priv(afterId)
 541     set Priv(afterId) {}
 542 }
 543 \f
 544 # ::tk::TabToWindow --
 545 # This procedure moves the focus to the given widget.
 546 # It sends a <<TraverseOut>> virtual event to the previous focus window,
 547 # if any, before changing the focus, and a <<TraverseIn>> event
 548 # to the new focus window afterwards.
 549 #
 550 # Arguments:
 551 # w - Window to which focus should be set.
 552
 553 proc ::tk::TabToWindow {w} {
 554     set focus [focus]
 555     if {$focus ne ""} {
 556         event generate $focus <<TraverseOut>>
 557     }
 558     focus $w
 559     event generate $w <<TraverseIn>>
 560 }
 561 \f
 562 # ::tk::UnderlineAmpersand --
 563 #       This procedure takes some text with ampersand and returns text w/o
 564 #       ampersand and position of the ampersand.  Double ampersands are
 565 #       converted to single ones.  Position returned is -1 when there is no
 566 #       ampersand.
 567 #
 568 proc ::tk::UnderlineAmpersand {text} {
 569     set s [string map {&& & & \ufeff} $text]
 570     set idx [string first \ufeff $s]
 571     return [list [string map {\ufeff {}} $s] $idx]
 572 }
 573
 574 # ::tk::SetAmpText --
 575 #       Given widget path and text with "magic ampersands", sets -text and
 576 #       -underline options for the widget
 577 #
 578 proc ::tk::SetAmpText {widget text} {
 579     lassign [UnderlineAmpersand $text] newtext under
 580     $widget configure -text $newtext -underline $under
 581 }
 582
 583 # ::tk::AmpWidget --
 584 #       Creates new widget, turning -text option into -text and -underline
 585 #       options, returned by ::tk::UnderlineAmpersand.
 586 #
 587 proc ::tk::AmpWidget {class path args} {
 588     set options {}
 589     foreach {opt val} $args {
 590         if {$opt eq "-text"} {
 591             lassign [UnderlineAmpersand $val] newtext under
 592             lappend options -text $newtext -underline $under
 593         } else {
 594             lappend options $opt $val
 595         }
 596     }
 597     set result [$class $path {*}$options]
 598     if {[string match "*button" $class]} {
 599         bind $path <<AltUnderlined>> [list $path invoke]
 600     }
 601     return $result
 602 }
 603
 604 # ::tk::AmpMenuArgs --
 605 #       Processes arguments for a menu entry, turning -label option into
 606 #       -label and -underline options, returned by ::tk::UnderlineAmpersand.
 607 #
 608 proc ::tk::AmpMenuArgs {widget add type args} {
 609     set options {}
 610     foreach {opt val} $args {
 611         if {$opt eq "-label"} {
 612             lassign [UnderlineAmpersand $val] newlabel under
 613             lappend options -label $newlabel -underline $under
 614         } else {
 615             lappend options $opt $val
 616         }
 617     }
 618     $widget add $type {*}$options
 619 }
 620
 621 # ::tk::FindAltKeyTarget --
 622 #       Search recursively through the hierarchy of visible widgets to find
 623 #       button or label which has $char as underlined character.
 624 #
 625 proc ::tk::FindAltKeyTarget {path char} {
 626     set class [winfo class $path]
 627     if {$class in {
 628         Button Checkbutton Label Radiobutton
 629         TButton TCheckbutton TLabel TRadiobutton
 630     } && [string equal -nocase $char \
 631             [string index [$path cget -text] [$path cget -underline]]]} {
 632         return $path
 633     }
 634     set subwins [concat [grid slaves $path] [pack slaves $path] \
 635             [place slaves $path]]
 636     if {$class eq "Canvas"} {
 637         foreach item [$path find all] {
 638             if {[$path type $item] eq "window"} {
 639                 set w [$path itemcget $item -window]
 640                 if {$w ne ""} {lappend subwins $w}
 641             }
 642         }
 643     } elseif {$class eq "Text"} {
 644         lappend subwins {*}[$path window names]
 645     }
 646     foreach child $subwins {
 647         set target [FindAltKeyTarget $child $char]
 648         if {$target ne ""} {
 649             return $target
 650         }
 651     }
 652 }
 653
 654 # ::tk::AltKeyInDialog --
 655 #       <Alt-Key> event handler for standard dialogs. Sends <<AltUnderlined>>
 656 #       to button or label which has appropriate underlined character.
 657 #
 658 proc ::tk::AltKeyInDialog {path key} {
 659     set target [FindAltKeyTarget $path $key]
 660     if {$target ne ""} {
 661         event generate $target <<AltUnderlined>>
 662     }
 663 }
 664
 665 # ::tk::mcmaxamp --
 666 #       Replacement for mcmax, used for texts with "magic ampersand" in it.
 667 #
 668
 669 proc ::tk::mcmaxamp {args} {
 670     set maxlen 0
 671     foreach arg $args {
 672         # Should we run [mc] in caller's namespace?
 673         lassign [UnderlineAmpersand [mc $arg]] msg
 674         set length [string length $msg]
 675         if {$length > $maxlen} {
 676             set maxlen $length
 677         }
 678     }
 679     return $maxlen
 680 }
 681 \f
 682 # For now, turn off the custom mdef proc for the mac:
 683
 684 if {[tk windowingsystem] eq "aqua"} {
 685     namespace eval ::tk::mac {
 686         set useCustomMDEF 0
 687     }
 688 }
 689
 690 # Run the Ttk themed widget set initialization
 691 if {$::ttk::library ne ""} {
 692     uplevel \#0 [list source $::ttk::library/ttk.tcl]
 693 }
 694 \f
 695 # Local Variables:
 696 # mode: tcl
 697 # fill-column: 78
 698 # End: