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