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