3 # Initialization script normally executed in the interpreter for each
4 # Tk-based application. Arranges class bindings for widgets.
6 # RCS: @(#) $Id: tk.tcl,v 1.73.2.12 2009/11/03 20:15:25 dgp Exp $
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.
12 # See the file "license.terms" for information on usage and redistribution
13 # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
15 package require
Tcl 8.5 ;# Guard against [source] in an 8.4- interp
16 ;# before using 8.5 [package] features.
17 # Insist on running with compatible version of Tcl
18 package require
Tcl 8.5.0
19 # Verify that we have Tk binary and script components from the same release
20 package require
-exact Tk
8.5.8
22 # Create a ::tk namespace
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
29 # minimal replacement.
31 return [format $src {*}$args]
35 foreach string $args {
36 set len
[string length
$string]
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
]
50 namespace import
::tk::msgcat::*
52 # and a ::ttk namespace
53 namespace 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
60 # Add Ttk & Tk's directory to the end of the auto-load search path, if it
61 # isn't already on the path:
63 if {[info exists
::auto_path] && ($::tk_library ne
"")
64 && ($::tk_library ni
$::auto_path)} {
65 lappend ::auto_path $::tk_library $::ttk::library
68 # Turn off strict Motif look and feel as a default.
70 set ::tk_strictMotif 0
72 # Turn on useinputmethods (X Input Methods) by default.
73 # We catch this because safe interpreters may not allow the call.
75 catch {tk useinputmethods
1}
77 # ::tk::PlaceWindow --
78 # place a toplevel at a particular position
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
88 proc ::tk::PlaceWindow {w
{place ""} {anchor
""}} {
93 set x
[expr {([winfo screenwidth
$w]-[winfo reqwidth
$w])/2}]
94 set y
[expr {([winfo screenheight
$w]-[winfo reqheight
$w])/2}]
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}]
102 set x
[winfo pointerx
$w]
103 set y
[winfo pointery
$w]
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}]
113 set x
[expr {([winfo screenwidth
$w]-[winfo reqwidth
$w])/2}]
114 set y
[expr {([winfo screenheight
$w]-[winfo reqheight
$w])/2}]
117 if {[tk windowingsystem
] eq
"win32"} {
118 # Bug 533519: win32 multiple desktops may produce negative geometry.
124 } elseif
{$x > ([winfo screenwidth
$w]-[winfo reqwidth
$w])} {
125 set x
[expr {[winfo screenwidth
$w]-[winfo reqwidth
$w]}]
129 } elseif
{$y > ([winfo screenheight
$w]-[winfo reqheight
$w])} {
130 set y
[expr {[winfo screenheight
$w]-[winfo reqheight
$w]}]
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 }
137 wm geometry
$w +$x+$y
141 # ::tk::SetFocusGrab --
142 # swap out current focus and grab temporarily (for dialogs)
144 # grab new window to grab
145 # focus window to give focus to
149 proc ::tk::SetFocusGrab {grab {focus {}}} {
150 set index
"$grab,$focus"
151 upvar ::tk::FocusGrab($index) data
154 set oldGrab
[grab current
$grab]
155 lappend data
$oldGrab
156 if {[winfo exists
$oldGrab]} {
157 lappend data
[grab status
$oldGrab]
159 # The "grab" command will fail if another application
160 # already holds the grab. So catch it.
162 if {[winfo exists
$focus]} {
167 # ::tk::RestoreFocusGrab --
168 # restore old focus and grab (for dialogs)
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
176 proc ::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)
185 catch {focus $oldFocus}
187 if {$destroy eq
"withdraw"} {
192 if {[winfo exists
$oldGrab] && [winfo ismapped
$oldGrab]} {
193 if {$oldStatus eq
"global"} {
194 grab -global $oldGrab
201 # ::tk::GetSelection --
202 # This tries to obtain the default selection. On Unix, we first try
203 # and get a UTF8_STRING, a type supported by modern Unix apps for
204 # passing Unicode data safely. We fall back on the default STRING
205 # type otherwise. On Windows, only the STRING type is necessary.
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)
211 # Returns the selection, or an error if none could be found
213 if {$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"
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"
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.
241 # screen - The name of the new screen.
243 proc ::tk::ScreenChanged screen
{
244 set x
[string last .
$screen]
246 set disp
[string range
$screen 0 [expr {$x - 1}]]
251 uplevel #0 upvar #0 ::tk::Priv.$disp ::tk::Priv
255 if {[info exists Priv
]} {
256 set Priv
(screen
) $screen
281 set Priv
(screen
) $screen
282 set Priv
(tearoff
) [string equal
[tk windowingsystem
] "x11"]
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).
290 tk::ScreenChanged [winfo screen .
]
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
298 # n1 - the name of the variable being changed ("::tk_strictMotif").
300 proc ::tk::EventMotifBindings {n1 dummy dummy
} {
309 event $op <<Cut
>> <Control-Key-w
>
310 event $op <<Copy
>> <Meta-Key-w
>
311 event $op <<Paste
>> <Control-Key-y
>
312 event $op <<Undo
>> <Control-underscore
>
315 #----------------------------------------------------------------------
316 # Define common dialogs on platforms where they are not implemented
317 # using compiled code.
318 #----------------------------------------------------------------------
320 if {![llength [info commands
tk_chooseColor]]} {
321 proc ::tk_chooseColor {args
} {
322 return [tk::dialog::color:: {*}$args]
325 if {![llength [info commands
tk_getOpenFile]]} {
326 proc ::tk_getOpenFile {args
} {
327 if {$::tk_strictMotif} {
328 return [tk::MotifFDialog open {*}$args]
330 return [::tk::dialog::file:: open {*}$args]
334 if {![llength [info commands
tk_getSaveFile]]} {
335 proc ::tk_getSaveFile {args
} {
336 if {$::tk_strictMotif} {
337 return [tk::MotifFDialog save
{*}$args]
339 return [::tk::dialog::file:: save
{*}$args]
343 if {![llength [info commands
tk_messageBox]]} {
344 proc ::tk_messageBox {args
} {
345 return [tk::MessageBox {*}$args]
348 if {![llength [info command
tk_chooseDirectory]]} {
349 proc ::tk_chooseDirectory {args
} {
350 return [::tk::dialog::file::chooseDir:: {*}$args]
354 #----------------------------------------------------------------------
355 # Define the set of common virtual events.
356 #----------------------------------------------------------------------
358 switch -exact -- [tk windowingsystem
] {
360 event add
<<Cut
>> <Control-Key-x
> <Key-F20
> <Control-Lock-Key-X
>
361 event add
<<Copy
>> <Control-Key-c
> <Key-F16
> <Control-Lock-Key-C
>
362 event add
<<Paste
>> <Control-Key-v
> <Key-F18
> <Control-Lock-Key-V
>
363 event add
<<PasteSelection
>> <ButtonRelease-2
>
364 event add
<<Undo
>> <Control-Key-z
> <Control-Lock-Key-Z
>
365 event add
<<Redo
>> <Control-Key-Z
> <Control-Lock-Key-z
>
366 # Some OS's define a goofy (as in, not <Shift-Tab>) keysym
367 # that is returned when the user presses <Shift-Tab>. In order for
368 # tab traversal to work, we have to add these keysyms to the
370 # We use catch just in case the keysym isn't recognized.
371 # This is needed for XFree86 systems
372 catch { event add
<<PrevWindow
>> <ISO_Left_Tab
> }
373 # This seems to be correct on *some* HP systems.
374 catch { event add
<<PrevWindow
>> <hpBackTab
> }
376 trace add
variable ::tk_strictMotif write
::tk::EventMotifBindings
377 set ::tk_strictMotif $::tk_strictMotif
378 # On unix, we want to always display entry/text selection,
379 # regardless of which window has focus
380 set ::tk::AlwaysShowSelection 1
383 event add
<<Cut
>> <Control-Key-x
> <Shift-Key-Delete
> \
385 event add
<<Copy
>> <Control-Key-c
> <Control-Key-Insert
> \
387 event add
<<Paste
>> <Control-Key-v
> <Shift-Key-Insert
> \
389 event add
<<PasteSelection
>> <ButtonRelease-2
>
390 event add
<<Undo
>> <Control-Key-z
> <Control-Lock-Key-Z
>
391 event add
<<Redo
>> <Control-Key-y
> <Control-Lock-Key-Y
>
394 event add
<<Cut
>> <Command-Key-x
> <Key-F2
> <Control-Lock-Key-X
>
395 event add
<<Copy
>> <Command-Key-c
> <Key-F3
> <Control-Lock-Key-C
>
396 event add
<<Paste
>> <Command-Key-v
> <Key-F4
> <Control-Lock-Key-V
>
397 event add
<<PasteSelection
>> <ButtonRelease-2
>
398 event add
<<Clear
>> <Clear
>
399 event add
<<Undo
>> <Command-Key-z
> <Control-Lock-Key-Z
>
400 event add
<<Redo
>> <Command-Key-y
> <Control-Lock-Key-Y
>
403 # ----------------------------------------------------------------------
404 # Read in files that define all of the class bindings.
405 # ----------------------------------------------------------------------
407 if {$::tk_library ne
""} {
408 proc ::tk::SourceLibFile {file} {
409 namespace eval :: [list source [file join $::tk_library $file.tcl
]]
411 namespace eval ::tk {
414 SourceLibFile
listbox
416 SourceLibFile
panedwindow
418 SourceLibFile scrlbar
419 SourceLibFile
spinbox
423 # ----------------------------------------------------------------------
424 # Default bindings for keyboard traversal.
425 # ----------------------------------------------------------------------
427 event add
<<PrevWindow
>> <Shift-Tab
>
428 bind all
<Tab
> {tk::TabToWindow [tk_focusNext %W
]}
429 bind all
<<PrevWindow
>> {tk::TabToWindow [tk_focusPrev %W
]}
431 # ::tk::CancelRepeat --
432 # This procedure is invoked to cancel an auto-repeat action described
433 # by ::tk::Priv(afterId). It's used by several widgets to auto-scroll
434 # the widget when the mouse is dragged out of the widget with a
440 proc ::tk::CancelRepeat {} {
442 after cancel
$Priv(afterId
)
446 # ::tk::TabToWindow --
447 # This procedure moves the focus to the given widget.
448 # It sends a <<TraverseOut>> virtual event to the previous focus window,
449 # if any, before changing the focus, and a <<TraverseIn>> event
450 # to the new focus window afterwards.
453 # w - Window to which focus should be set.
455 proc ::tk::TabToWindow {w
} {
458 event generate
$focus <<TraverseOut
>>
461 event generate
$w <<TraverseIn
>>
464 # ::tk::UnderlineAmpersand --
465 # This procedure takes some text with ampersand and returns
466 # text w/o ampersand and position of the ampersand.
467 # Double ampersands are converted to single ones.
468 # Position returned is -1 when there is no ampersand.
470 proc ::tk::UnderlineAmpersand {text} {
471 set idx
[string first
"&" $text]
475 while {[string match
"&" [string index
$text [expr {$idx + 1}]]]} {
476 set base
[expr {$idx + 2}]
477 set idx
[string first
"&" [string range
$text $base end
]]
481 set underline
[expr {$underline + $idx + 1}]
487 regsub -all -- {&([^
&])} $text {\1} text
489 return [list $text $idx]
492 # ::tk::SetAmpText --
493 # Given widget path and text with "magic ampersands",
494 # sets -text and -underline options for the widget
496 proc ::tk::SetAmpText {widget
text} {
497 lassign
[UnderlineAmpersand
$text] newtext under
498 $widget configure
-text $newtext -underline $under
502 # Creates new widget, turning -text option into -text and
503 # -underline options, returned by ::tk::UnderlineAmpersand.
505 proc ::tk::AmpWidget {class path args
} {
507 foreach {opt val
} $args {
508 if {$opt eq
"-text"} {
509 lassign
[UnderlineAmpersand
$val] newtext under
510 lappend options -text $newtext -underline $under
512 lappend options $opt $val
515 set result
[$class $path {*}$options]
516 if {[string match
"*button" $class]} {
517 bind $path <<AltUnderlined
>> [list $path invoke
]
522 # ::tk::AmpMenuArgs --
523 # Processes arguments for a menu entry, turning -label option into
524 # -label and -underline options, returned by ::tk::UnderlineAmpersand.
526 proc ::tk::AmpMenuArgs {widget add type args
} {
528 foreach {opt val
} $args {
529 if {$opt eq
"-label"} {
530 lassign
[UnderlineAmpersand
$val] newlabel under
531 lappend options -label $newlabel -underline $under
533 lappend options $opt $val
536 $widget add
$type {*}$options
539 # ::tk::FindAltKeyTarget --
540 # search recursively through the hierarchy of visible widgets
541 # to find button or label which has $char as underlined character
543 proc ::tk::FindAltKeyTarget {path char
} {
544 switch -- [winfo class
$path] {
546 TButton
- TLabel
- TCheckbutton
{
547 if {[string equal
-nocase $char \
548 [string index
[$path cget
-text] [$path cget
-underline]]]} {
555 foreach child
[concat [grid slaves
$path] \
556 [pack slaves
$path] [place slaves
$path]] {
557 set target
[FindAltKeyTarget
$child $char]
567 # ::tk::AltKeyInDialog --
568 # <Alt-Key> event handler for standard dialogs. Sends <<AltUnderlined>>
569 # to button or label which has appropriate underlined character
571 proc ::tk::AltKeyInDialog {path key
} {
572 set target
[FindAltKeyTarget
$path $key]
573 if { $target eq
""} return
574 event generate
$target <<AltUnderlined
>>
578 # Replacement for mcmax, used for texts with "magic ampersand" in it.
581 proc ::tk::mcmaxamp {args
} {
584 # Should we run [mc] in caller's namespace?
585 lassign
[UnderlineAmpersand
[mc
$arg]] msg
586 set length
[string length
$msg]
587 if {$length > $maxlen} {
593 # For now, turn off the custom mdef proc for the mac:
595 if {[tk windowingsystem
] eq
"aqua"} {
596 namespace eval ::tk::mac {
601 # Run the Ttk themed widget set initialization
602 if {$::ttk::library ne
""} {
603 uplevel \#0 [list source $::ttk::library/ttk.tcl]