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.46.2.6 2006/09/25 17:28:20 andreas_kupries 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 # Insist on running with compatible versions of Tcl and Tk.
16 package require
-exact Tk
8.4
17 package require
-exact Tcl 8.4
19 # Create a ::tk namespace
21 # Set up the msgcat commands
22 namespace eval msgcat {
23 namespace export mc mcmax
24 if {[interp issafe
] ||
[catch {package require
msgcat}]} {
25 # The msgcat package is not available. Supply our own
26 # minimal replacement.
28 return [eval [list format $src] $args]
32 foreach string $args {
33 set len
[string length
$string]
41 # Get the commands from the msgcat package that Tk uses.
42 namespace import
::msgcat::mc
43 namespace import
::msgcat::mcmax
44 ::msgcat::mcload [file join $::tk_library msgs
]
47 namespace import
::tk::msgcat::*
50 # Add Tk's directory to the end of the auto-load search path, if it
51 # isn't already on the path:
53 if {[info exists
::auto_path] && $::tk_library ne
"" && \
54 [lsearch -exact $::auto_path $::tk_library] < 0} {
55 lappend ::auto_path $::tk_library
58 # Turn off strict Motif look and feel as a default.
60 set ::tk_strictMotif 0
62 # Turn on useinputmethods (X Input Methods) by default.
63 # We catch this because safe interpreters may not allow the call.
65 catch {tk useinputmethods
1}
67 # ::tk::PlaceWindow --
68 # place a toplevel at a particular position
70 # toplevel name of toplevel window
71 # ?placement? pointer ?center? ; places $w centered on the pointer
72 # widget widgetPath ; centers $w over widget_name
73 # defaults to placing toplevel in the middle of the screen
74 # ?anchor? center or widgetPath
78 proc ::tk::PlaceWindow {w
{place ""} {anchor
""}} {
82 set place_len
[string length
$place]
84 set x
[expr {([winfo screenwidth
$w]-[winfo reqwidth
$w])/2}]
85 set y
[expr {([winfo screenheight
$w]-[winfo reqheight
$w])/2}]
87 } elseif
{[string equal
-length $place_len $place "pointer"]} {
88 ## place at POINTER (centered if $anchor == center)
89 if {[string equal
-length [string length
$anchor] $anchor "center"]} {
90 set x
[expr {[winfo pointerx
$w]-[winfo reqwidth
$w]/2}]
91 set y
[expr {[winfo pointery
$w]-[winfo reqheight
$w]/2}]
93 set x
[winfo pointerx
$w]
94 set y
[winfo pointery
$w]
96 } elseif
{[string equal
-length $place_len $place "widget"] && \
97 [winfo exists
$anchor] && [winfo ismapped
$anchor]} {
98 ## center about WIDGET $anchor, widget must be mapped
99 set x
[expr {[winfo rootx
$anchor] + \
100 ([winfo width
$anchor]-[winfo reqwidth
$w])/2}]
101 set y
[expr {[winfo rooty
$anchor] + \
102 ([winfo height
$anchor]-[winfo reqheight
$w])/2}]
104 set x
[expr {([winfo screenwidth
$w]-[winfo reqwidth
$w])/2}]
105 set y
[expr {([winfo screenheight
$w]-[winfo reqheight
$w])/2}]
109 set windowingsystem
[tk windowingsystem
]
111 if {$windowingsystem eq
"win32"} {
112 # Bug 533519: win32 multiple desktops may produce negative geometry.
118 } elseif
{$x > ([winfo screenwidth
$w]-[winfo reqwidth
$w])} {
119 set x
[expr {[winfo screenwidth
$w]-[winfo reqwidth
$w]}]
123 } elseif
{$y > ([winfo screenheight
$w]-[winfo reqheight
$w])} {
124 set y
[expr {[winfo screenheight
$w]-[winfo reqheight
$w]}]
126 if {$windowingsystem eq
"macintosh" ||
$windowingsystem eq
"aqua"} {
127 # Avoid the native menu bar which sits on top of everything.
128 if {$y < 20} { set y
20 }
131 wm geometry
$w +$x+$y
135 # ::tk::SetFocusGrab --
136 # swap out current focus and grab temporarily (for dialogs)
138 # grab new window to grab
139 # focus window to give focus to
143 proc ::tk::SetFocusGrab {grab {focus {}}} {
144 set index
"$grab,$focus"
145 upvar ::tk::FocusGrab($index) data
148 set oldGrab
[grab current
$grab]
149 lappend data
$oldGrab
150 if {[winfo exists
$oldGrab]} {
151 lappend data
[grab status
$oldGrab]
153 # The "grab" command will fail if another application
154 # already holds the grab. So catch it.
156 if {[winfo exists
$focus]} {
161 # ::tk::RestoreFocusGrab --
162 # restore old focus and grab (for dialogs)
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
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)
179 catch {focus $oldFocus}
181 if {$destroy eq
"withdraw"} {
186 if {[winfo exists
$oldGrab] && [winfo ismapped
$oldGrab]} {
187 if {$oldStatus eq
"global"} {
188 grab -global $oldGrab
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.
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)
205 # Returns the selection, or an error if none could be found
207 if {$tcl_platform(platform
) eq
"unix"} {
208 proc ::tk::GetSelection {w
{sel PRIMARY
}} {
209 if {[catch {selection get
-displayof $w -selection $sel \
210 -type UTF8_STRING
} txt
] \
211 && [catch {selection get
-displayof $w -selection $sel} txt
]} {
212 return -code error "could not find default selection"
218 proc ::tk::GetSelection {w
{sel PRIMARY
}} {
219 if {[catch {selection get
-displayof $w -selection $sel} txt
]} {
220 return -code error "could not find default selection"
227 # ::tk::ScreenChanged --
228 # This procedure is invoked by the binding mechanism whenever the
229 # "current" screen is changing. The procedure does two things.
230 # First, it uses "upvar" to make variable "::tk::Priv" point at an
231 # array variable that holds state for the current display. Second,
232 # it initializes the array if it didn't already exist.
235 # screen - The name of the new screen.
237 proc ::tk::ScreenChanged screen
{
238 set x
[string last .
$screen]
240 set disp
[string range
$screen 0 [expr {$x - 1}]]
245 uplevel #0 upvar #0 ::tk::Priv.$disp ::tk::Priv
249 if {[info exists Priv
]} {
250 set Priv
(screen
) $screen
275 set Priv
(screen
) $screen
276 set Priv
(tearoff
) [string equal
[tk windowingsystem
] "x11"]
280 # Do initial setup for Priv, so that it is always bound to something
281 # (otherwise, if someone references it, it may get set to a non-upvar-ed
282 # value, which will cause trouble later).
284 tk::ScreenChanged [winfo screen .
]
286 # ::tk::EventMotifBindings --
287 # This procedure is invoked as a trace whenever ::tk_strictMotif is
288 # changed. It is used to turn on or turn off the motif virtual
292 # n1 - the name of the variable being changed ("::tk_strictMotif").
294 proc ::tk::EventMotifBindings {n1 dummy dummy
} {
303 event $op <<Cut
>> <Control-Key-w
>
304 event $op <<Copy
>> <Meta-Key-w
>
305 event $op <<Paste
>> <Control-Key-y
>
306 event $op <<Undo
>> <Control-underscore
>
309 #----------------------------------------------------------------------
310 # Define common dialogs on platforms where they are not implemented
311 # using compiled code.
312 #----------------------------------------------------------------------
314 if {[info commands
tk_chooseColor] eq
""} {
315 proc ::tk_chooseColor {args
} {
316 return [eval tk::dialog::color:: $args]
319 if {[info commands
tk_getOpenFile] eq
""} {
320 proc ::tk_getOpenFile {args
} {
321 if {$::tk_strictMotif} {
322 return [eval tk::MotifFDialog open $args]
324 return [eval ::tk::dialog::file:: open $args]
328 if {[info commands
tk_getSaveFile] eq
""} {
329 proc ::tk_getSaveFile {args
} {
330 if {$::tk_strictMotif} {
331 return [eval tk::MotifFDialog save
$args]
333 return [eval ::tk::dialog::file:: save
$args]
337 if {[info commands
tk_messageBox] eq
""} {
338 proc ::tk_messageBox {args
} {
339 return [eval tk::MessageBox $args]
342 if {[info command
tk_chooseDirectory] eq
""} {
343 proc ::tk_chooseDirectory {args
} {
344 return [eval ::tk::dialog::file::chooseDir:: $args]
348 #----------------------------------------------------------------------
349 # Define the set of common virtual events.
350 #----------------------------------------------------------------------
352 switch [tk windowingsystem
] {
354 event add
<<Cut
>> <Control-Key-x
> <Key-F20
>
355 event add
<<Copy
>> <Control-Key-c
> <Key-F16
>
356 event add
<<Paste
>> <Control-Key-v
> <Key-F18
>
357 event add
<<PasteSelection
>> <ButtonRelease-2
>
358 event add
<<Undo
>> <Control-Key-z
>
359 event add
<<Redo
>> <Control-Key-Z
>
360 # Some OS's define a goofy (as in, not <Shift-Tab>) keysym
361 # that is returned when the user presses <Shift-Tab>. In order for
362 # tab traversal to work, we have to add these keysyms to the
364 # We use catch just in case the keysym isn't recognized.
365 # This is needed for XFree86 systems
366 catch { event add
<<PrevWindow
>> <ISO_Left_Tab
> }
367 # This seems to be correct on *some* HP systems.
368 catch { event add
<<PrevWindow
>> <hpBackTab
> }
370 trace add
variable ::tk_strictMotif write
::tk::EventMotifBindings
371 set ::tk_strictMotif $::tk_strictMotif
372 # On unix, we want to always display entry/text selection,
373 # regardless of which window has focus
374 set ::tk::AlwaysShowSelection 1
377 event add
<<Cut
>> <Control-Key-x
> <Shift-Key-Delete
>
378 event add
<<Copy
>> <Control-Key-c
> <Control-Key-Insert
>
379 event add
<<Paste
>> <Control-Key-v
> <Shift-Key-Insert
>
380 event add
<<PasteSelection
>> <ButtonRelease-2
>
381 event add
<<Undo
>> <Control-Key-z
>
382 event add
<<Redo
>> <Control-Key-y
>
385 event add
<<Cut
>> <Command-Key-x
> <Key-F2
>
386 event add
<<Copy
>> <Command-Key-c
> <Key-F3
>
387 event add
<<Paste
>> <Command-Key-v
> <Key-F4
>
388 event add
<<PasteSelection
>> <ButtonRelease-2
>
389 event add
<<Clear
>> <Clear
>
390 event add
<<Undo
>> <Command-Key-z
>
391 event add
<<Redo
>> <Command-Key-y
>
394 event add
<<Cut
>> <Control-Key-x
> <Key-F2
>
395 event add
<<Copy
>> <Control-Key-c
> <Key-F3
>
396 event add
<<Paste
>> <Control-Key-v
> <Key-F4
>
397 event add
<<PasteSelection
>> <ButtonRelease-2
>
398 event add
<<Clear
>> <Clear
>
399 event add
<<Undo
>> <Control-Key-z
> <Key-F1
>
400 event add
<<Redo
>> <Control-Key-Z
>
403 # ----------------------------------------------------------------------
404 # Read in files that define all of the class bindings.
405 # ----------------------------------------------------------------------
407 if {$::tk_library ne
""} {
408 if {$tcl_platform(platform
) eq
"macintosh"} {
409 proc ::tk::SourceLibFile {file} {
412 [list source [file join $::tk_library $file.tcl
]]
414 namespace eval :: [list source -rsrc $file]
418 proc ::tk::SourceLibFile {file} {
419 namespace eval :: [list source [file join $::tk_library $file.tcl
]]
422 namespace eval ::tk {
425 SourceLibFile
listbox
427 SourceLibFile
panedwindow
429 SourceLibFile scrlbar
430 SourceLibFile
spinbox
434 # ----------------------------------------------------------------------
435 # Default bindings for keyboard traversal.
436 # ----------------------------------------------------------------------
438 event add
<<PrevWindow
>> <Shift-Tab
>
439 bind all
<Tab
> {tk::TabToWindow [tk_focusNext %W
]}
440 bind all
<<PrevWindow
>> {tk::TabToWindow [tk_focusPrev %W
]}
442 # ::tk::CancelRepeat --
443 # This procedure is invoked to cancel an auto-repeat action described
444 # by ::tk::Priv(afterId). It's used by several widgets to auto-scroll
445 # the widget when the mouse is dragged out of the widget with a
451 proc ::tk::CancelRepeat {} {
453 after cancel
$Priv(afterId
)
457 # ::tk::TabToWindow --
458 # This procedure moves the focus to the given widget. If the widget
459 # is an entry or a spinbox, it selects the entire contents of the widget.
462 # w - Window to which focus should be set.
464 proc ::tk::TabToWindow {w
} {
465 set wclass
[winfo class
$w]
467 if {$wclass eq
"Entry" ||
$wclass eq
"Spinbox"} {
468 $w selection range
0 end
474 # ::tk::UnderlineAmpersand --
475 # This procedure takes some text with ampersand and returns
476 # text w/o ampersand and position of the ampersand.
477 # Double ampersands are converted to single ones.
478 # Position returned is -1 when there is no ampersand.
480 proc ::tk::UnderlineAmpersand {text} {
481 set idx
[string first
"&" $text]
485 while {[string match
"&" [string index
$text [expr {$idx + 1}]]]} {
486 set base
[expr {$idx + 2}]
487 set idx
[string first
"&" [string range
$text $base end
]]
491 set underline
[expr {$underline + $idx + 1}]
497 regsub -all -- {&([^
&])} $text {\1} text
499 return [list $text $idx]
502 # ::tk::SetAmpText --
503 # Given widget path and text with "magic ampersands",
504 # sets -text and -underline options for the widget
506 proc ::tk::SetAmpText {widget
text} {
507 foreach {newtext under
} [::tk::UnderlineAmpersand $text] {
508 $widget configure
-text $newtext -underline $under
513 # Creates new widget, turning -text option into -text and
514 # -underline options, returned by ::tk::UnderlineAmpersand.
516 proc ::tk::AmpWidget {class path args
} {
517 set wcmd
[list $class $path]
518 foreach {opt val
} $args {
519 if {$opt eq
"-text"} {
520 foreach {newtext under
} [::tk::UnderlineAmpersand $val] {
521 lappend wcmd
-text $newtext -underline $under
524 lappend wcmd
$opt $val
528 if {$class eq
"button"} {
529 bind $path <<AltUnderlined
>> [list $path invoke
]
534 # ::tk::FindAltKeyTarget --
535 # search recursively through the hierarchy of visible widgets
536 # to find button or label which has $char as underlined character
538 proc ::tk::FindAltKeyTarget {path char
} {
539 switch [winfo class
$path] {
542 if {[string equal
-nocase $char \
543 [string index
[$path cget
-text] \
544 [$path cget
-underline]]]} {return $path} else {return {}}
548 [concat [grid slaves
$path] \
549 [pack slaves
$path] \
550 [place slaves
$path] ] {
551 if {"" ne
[set target
[::tk::FindAltKeyTarget $child $char]]} {
560 # ::tk::AltKeyInDialog --
561 # <Alt-Key> event handler for standard dialogs. Sends <<AltUnderlined>>
562 # to button or label which has appropriate underlined character
564 proc ::tk::AltKeyInDialog {path key
} {
565 set target
[::tk::FindAltKeyTarget $path $key]
566 if { $target eq
""} return
567 event generate
$target <<AltUnderlined
>>
571 # Replacement for mcmax, used for texts with "magic ampersand" in it.
574 proc ::tk::mcmaxamp {args
} {
577 set length
[string length
[lindex [::tk::UnderlineAmpersand [mc
$arg]] 0]]
578 if {$length>$maxlen} {
584 # For now, turn off the custom mdef proc for the mac:
586 if {[tk windowingsystem
] eq
"aqua"} {
587 namespace eval ::tk::mac {