3 # Initialization script normally executed in the interpreter for each Tk-based
4 # application. Arranges class bindings for widgets.
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.
10 # See the file "license.terms" for information on usage and redistribution of
11 # this file, and for a DISCLAIMER OF ALL WARRANTIES.
13 package require
Tcl 8.5 ;# Guard against [source] in an 8.4- interp before
14 ;# using 8.5 [package] features.
15 # Insist on running with compatible version of Tcl
16 package require
Tcl 8.5.0
17 # Verify that we have Tk binary and script components from the same release
18 package require
-exact Tk
8.5.13
20 # Create a ::tk namespace
22 # Set up the msgcat commands
23 namespace eval msgcat {
24 namespace export mc mcmax
25 if {[interp issafe
] ||
[catch {package require
msgcat}]} {
26 # The msgcat package is not available. Supply our own minimal
29 return [format $src {*}$args]
33 foreach string $args {
34 set len
[string length
$string]
42 # Get the commands from the msgcat package that Tk uses.
43 namespace import
::msgcat::mc
44 namespace import
::msgcat::mcmax
45 ::msgcat::mcload [file join $::tk_library msgs
]
48 namespace import
::tk::msgcat::*
50 # and a ::ttk namespace
51 namespace eval ::ttk {
52 if {$::tk_library ne
""} {
53 # avoid file join to work in safe interps, but this is also x-plat ok
54 variable library
$::tk_library/ttk
58 # Add Ttk & Tk's directory to the end of the auto-load search path, if it
59 # isn't already on the path:
61 if {[info exists
::auto_path] && ($::tk_library ne
"")
62 && ($::tk_library ni
$::auto_path)} {
63 lappend ::auto_path $::tk_library $::ttk::library
66 # Turn off strict Motif look and feel as a default.
68 set ::tk_strictMotif 0
70 # Turn on useinputmethods (X Input Methods) by default. We catch this because
71 # safe interpreters may not allow the call.
73 catch {tk useinputmethods
1}
75 # ::tk::PlaceWindow --
76 # Place a toplevel at a particular position
78 # toplevel name of toplevel window
79 # ?placement? pointer ?center? ; places $w centered on the pointer
80 # widget widgetPath ; centers $w over widget_name
81 # defaults to placing toplevel in the middle of the screen
82 # ?anchor? center or widgetPath
86 proc ::tk::PlaceWindow {w
{place ""} {anchor
""}} {
91 set x
[expr {([winfo screenwidth
$w]-[winfo reqwidth
$w])/2}]
92 set y
[expr {([winfo screenheight
$w]-[winfo reqheight
$w])/2}]
94 } elseif
{[string equal
-length [string length
$place] $place "pointer"]} {
95 ## place at POINTER (centered if $anchor == center)
96 if {[string equal
-length [string length
$anchor] $anchor "center"]} {
97 set x
[expr {[winfo pointerx
$w]-[winfo reqwidth
$w]/2}]
98 set y
[expr {[winfo pointery
$w]-[winfo reqheight
$w]/2}]
100 set x
[winfo pointerx
$w]
101 set y
[winfo pointery
$w]
103 } elseif
{[string equal
-length [string length
$place] $place "widget"] && \
104 [winfo exists
$anchor] && [winfo ismapped
$anchor]} {
105 ## center about WIDGET $anchor, widget must be mapped
106 set x
[expr {[winfo rootx
$anchor] + \
107 ([winfo width
$anchor]-[winfo reqwidth
$w])/2}]
108 set y
[expr {[winfo rooty
$anchor] + \
109 ([winfo height
$anchor]-[winfo reqheight
$w])/2}]
111 set x
[expr {([winfo screenwidth
$w]-[winfo reqwidth
$w])/2}]
112 set y
[expr {([winfo screenheight
$w]-[winfo reqheight
$w])/2}]
116 if {$x < [winfo vrootx
$w]} {
117 set x
[winfo vrootx
$w]
118 } elseif
{$x > ([winfo vrootx
$w]+[winfo vrootwidth
$w]-[winfo reqwidth
$w])} {
119 set x
[expr {[winfo vrootx
$w]+[winfo vrootwidth
$w]-[winfo reqwidth
$w]}]
121 if {$y < [winfo vrooty
$w]} {
122 set y
[winfo vrooty
$w]
123 } elseif
{$y > ([winfo vrooty
$w]+[winfo vrootheight
$w]-[winfo reqheight
$w])} {
124 set y
[expr {[winfo vrooty
$w]+[winfo vrootheight
$w]-[winfo reqheight
$w]}]
126 if {[tk windowingsystem
] eq
"aqua"} {
127 # Avoid the native menu bar which sits on top of everything.
128 if {$y < 22} { set y
22 }
131 wm maxsize
$w [winfo vrootwidth
$w] [winfo vrootheight
$w]
132 wm geometry
$w +$x+$y
136 # ::tk::SetFocusGrab --
137 # Swap out current focus and grab temporarily (for dialogs)
139 # grab new window to grab
140 # focus window to give focus to
144 proc ::tk::SetFocusGrab {grab {focus {}}} {
145 set index
"$grab,$focus"
146 upvar ::tk::FocusGrab($index) data
149 set oldGrab
[grab current
$grab]
150 lappend data
$oldGrab
151 if {[winfo exists
$oldGrab]} {
152 lappend data
[grab status
$oldGrab]
154 # The "grab" command will fail if another application already holds the
157 if {[winfo exists
$focus]} {
162 # ::tk::RestoreFocusGrab --
163 # Restore old focus and grab (for dialogs)
165 # grab window that had taken grab
166 # focus window that had taken focus
167 # destroy destroy|withdraw - how to handle the old grabbed window
171 proc ::tk::RestoreFocusGrab {grab focus {destroy destroy}} {
172 set index
"$grab,$focus"
173 if {[info exists
::tk::FocusGrab($index)]} {
174 foreach {oldFocus oldGrab oldStatus
} $::tk::FocusGrab($index) { break }
175 unset ::tk::FocusGrab($index)
180 catch {focus $oldFocus}
182 if {$destroy eq
"withdraw"} {
187 if {[winfo exists
$oldGrab] && [winfo ismapped
$oldGrab]} {
188 if {$oldStatus eq
"global"} {
189 grab -global $oldGrab
196 # ::tk::GetSelection --
197 # This tries to obtain the default selection. On Unix, we first try and get
198 # a UTF8_STRING, a type supported by modern Unix apps for passing Unicode
199 # data safely. We fall back on the default STRING type otherwise. On
200 # Windows, only the STRING type is necessary.
202 # w The widget for which the selection will be retrieved.
203 # Important for the -displayof property.
204 # sel The source of the selection (PRIMARY or CLIPBOARD)
206 # Returns the selection, or an error if none could be found
208 if {[tk windowingsystem
] ne
"win32"} {
209 proc ::tk::GetSelection {w
{sel PRIMARY
}} {
210 if {[catch {selection get
-displayof $w -selection $sel \
211 -type UTF8_STRING
} txt
] \
212 && [catch {selection get
-displayof $w -selection $sel} txt
]} {
213 return -code error "could not find default selection"
219 proc ::tk::GetSelection {w
{sel PRIMARY
}} {
220 if {[catch {selection get
-displayof $w -selection $sel} txt
]} {
221 return -code error "could not find default selection"
228 # ::tk::ScreenChanged --
229 # This procedure is invoked by the binding mechanism whenever the "current"
230 # screen is changing. The procedure does two things. First, it uses "upvar"
231 # to make variable "::tk::Priv" point at an array variable that holds state
232 # for the current display. Second, it initializes the array if it didn't
236 # screen - The name of the new screen.
238 proc ::tk::ScreenChanged {screen
} {
239 set x
[string last .
$screen]
241 set disp
[string range
$screen 0 [expr {$x - 1}]]
246 # Ensure that namespace separators never occur in the display name (as
247 # they cause problems in variable names). Double-colons exist in some VNC
248 # display names. [Bug 2912473]
249 set disp
[string map
{:: _doublecolon_
} $disp]
251 uplevel #0 [list 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 changed.
294 # It is used to turn on or turn off the motif virtual bindings.
297 # n1 - the name of the variable being changed ("::tk_strictMotif").
299 proc ::tk::EventMotifBindings {n1 dummy dummy
} {
308 event $op <<Cut
>> <Control-Key-w
>
309 event $op <<Copy
>> <Meta-Key-w
>
310 event $op <<Paste
>> <Control-Key-y
>
311 event $op <<Undo
>> <Control-underscore
>
314 #----------------------------------------------------------------------
315 # Define common dialogs on platforms where they are not implemented using
317 #----------------------------------------------------------------------
319 if {![llength [info commands
tk_chooseColor]]} {
320 proc ::tk_chooseColor {args
} {
321 return [tk::dialog::color:: {*}$args]
324 if {![llength [info commands
tk_getOpenFile]]} {
325 proc ::tk_getOpenFile {args
} {
326 if {$::tk_strictMotif} {
327 return [tk::MotifFDialog open {*}$args]
329 return [::tk::dialog::file:: open {*}$args]
333 if {![llength [info commands
tk_getSaveFile]]} {
334 proc ::tk_getSaveFile {args
} {
335 if {$::tk_strictMotif} {
336 return [tk::MotifFDialog save
{*}$args]
338 return [::tk::dialog::file:: save
{*}$args]
342 if {![llength [info commands
tk_messageBox]]} {
343 proc ::tk_messageBox {args
} {
344 return [tk::MessageBox {*}$args]
347 if {![llength [info command
tk_chooseDirectory]]} {
348 proc ::tk_chooseDirectory {args
} {
349 return [::tk::dialog::file::chooseDir:: {*}$args]
353 #----------------------------------------------------------------------
354 # Define the set of common virtual events.
355 #----------------------------------------------------------------------
357 switch -exact -- [tk windowingsystem
] {
359 event add
<<Cut
>> <Control-Key-x
> <Key-F20
> <Control-Lock-Key-X
>
360 event add
<<Copy
>> <Control-Key-c
> <Key-F16
> <Control-Lock-Key-C
>
361 event add
<<Paste
>> <Control-Key-v
> <Key-F18
> <Control-Lock-Key-V
>
362 event add
<<PasteSelection
>> <ButtonRelease-2
>
363 event add
<<Undo
>> <Control-Key-z
> <Control-Lock-Key-Z
>
364 event add
<<Redo
>> <Control-Key-Z
> <Control-Lock-Key-z
>
365 # Some OS's define a goofy (as in, not <Shift-Tab>) keysym that is
366 # returned when the user presses <Shift-Tab>. In order for tab
367 # traversal to work, we have to add these keysyms to the PrevWindow
368 # event. We use catch just in case the keysym isn't recognized. This
369 # is needed for XFree86 systems
370 catch { event add
<<PrevWindow
>> <ISO_Left_Tab
> }
371 # This seems to be correct on *some* HP systems.
372 catch { event add
<<PrevWindow
>> <hpBackTab
> }
374 trace add
variable ::tk_strictMotif write
::tk::EventMotifBindings
375 set ::tk_strictMotif $::tk_strictMotif
376 # On unix, we want to always display entry/text selection, regardless
377 # of which window has focus
378 set ::tk::AlwaysShowSelection 1
381 event add
<<Cut
>> <Control-Key-x
> <Shift-Key-Delete
> \
383 event add
<<Copy
>> <Control-Key-c
> <Control-Key-Insert
> \
385 event add
<<Paste
>> <Control-Key-v
> <Shift-Key-Insert
> \
387 event add
<<PasteSelection
>> <ButtonRelease-2
>
388 event add
<<Undo
>> <Control-Key-z
> <Control-Lock-Key-Z
>
389 event add
<<Redo
>> <Control-Key-y
> <Control-Lock-Key-Y
>
392 event add
<<Cut
>> <Command-Key-x
> <Key-F2
> <Control-Lock-Key-X
>
393 event add
<<Copy
>> <Command-Key-c
> <Key-F3
> <Control-Lock-Key-C
>
394 event add
<<Paste
>> <Command-Key-v
> <Key-F4
> <Control-Lock-Key-V
>
395 event add
<<PasteSelection
>> <ButtonRelease-2
>
396 event add
<<Clear
>> <Clear
>
397 event add
<<Undo
>> <Command-Key-z
> <Control-Lock-Key-Z
>
398 event add
<<Redo
>> <Command-Key-y
> <Control-Lock-Key-Y
>
402 # ----------------------------------------------------------------------
403 # Read in files that define all of the class bindings.
404 # ----------------------------------------------------------------------
406 if {$::tk_library ne
""} {
407 proc ::tk::SourceLibFile {file} {
408 namespace eval :: [list source [file join $::tk_library $file.tcl
]]
410 namespace eval ::tk {
413 SourceLibFile
listbox
415 SourceLibFile
panedwindow
417 SourceLibFile scrlbar
418 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 by
433 # ::tk::Priv(afterId). It's used by several widgets to auto-scroll the widget
434 # when the mouse is dragged out of the widget with a button pressed.
439 proc ::tk::CancelRepeat {} {
441 after cancel
$Priv(afterId
)
445 # ::tk::TabToWindow --
446 # This procedure moves the focus to the given widget.
447 # It sends a <<TraverseOut>> virtual event to the previous focus window, if
448 # any, before changing the focus, and a <<TraverseIn>> event to the new focus
452 # w - Window to which focus should be set.
454 proc ::tk::TabToWindow {w
} {
457 event generate
$focus <<TraverseOut
>>
460 event generate
$w <<TraverseIn
>>
463 # ::tk::UnderlineAmpersand --
464 # This procedure takes some text with ampersand and returns text w/o ampersand
465 # and position of the ampersand. Double ampersands are converted to single
466 # ones. Position returned is -1 when there is no ampersand.
468 proc ::tk::UnderlineAmpersand {text} {
469 set s
[string map
{&& & & \ufeff} $text]
470 set idx
[string first
\ufeff $s]
471 return [list [string map
{\ufeff {}} $s] $idx]
474 # ::tk::SetAmpText --
475 # Given widget path and text with "magic ampersands", sets -text and
476 # -underline options for the widget
478 proc ::tk::SetAmpText {widget
text} {
479 lassign
[UnderlineAmpersand
$text] newtext under
480 $widget configure
-text $newtext -underline $under
484 # Creates new widget, turning -text option into -text and -underline options,
485 # returned by ::tk::UnderlineAmpersand.
487 proc ::tk::AmpWidget {class path args
} {
489 foreach {opt val
} $args {
490 if {$opt eq
"-text"} {
491 lassign
[UnderlineAmpersand
$val] newtext under
492 lappend options -text $newtext -underline $under
494 lappend options $opt $val
497 set result
[$class $path {*}$options]
498 if {[string match
"*button" $class]} {
499 bind $path <<AltUnderlined
>> [list $path invoke
]
504 # ::tk::AmpMenuArgs --
505 # Processes arguments for a menu entry, turning -label option into -label and
506 # -underline options, returned by ::tk::UnderlineAmpersand.
508 proc ::tk::AmpMenuArgs {widget add type args
} {
510 foreach {opt val
} $args {
511 if {$opt eq
"-label"} {
512 lassign
[UnderlineAmpersand
$val] newlabel under
513 lappend options -label $newlabel -underline $under
515 lappend options $opt $val
518 $widget add
$type {*}$options
521 # ::tk::FindAltKeyTarget --
522 # Search recursively through the hierarchy of visible widgets to find button
523 # or label which has $char as underlined character
525 proc ::tk::FindAltKeyTarget {path char
} {
526 switch -- [winfo class
$path] {
528 TButton
- TLabel
- TCheckbutton
{
529 if {[string equal
-nocase $char \
530 [string index
[$path cget
-text] [$path cget
-underline]]]} {
537 foreach child
[concat [grid slaves
$path] \
538 [pack slaves
$path] [place slaves
$path]] {
539 set target
[FindAltKeyTarget
$child $char]
549 # ::tk::AltKeyInDialog --
550 # <Alt-Key> event handler for standard dialogs. Sends <<AltUnderlined>> to
551 # button or label which has appropriate underlined character
553 proc ::tk::AltKeyInDialog {path key
} {
554 set target
[FindAltKeyTarget
$path $key]
555 if { $target eq
""} return
556 event generate
$target <<AltUnderlined
>>
560 # Replacement for mcmax, used for texts with "magic ampersand" in it.
563 proc ::tk::mcmaxamp {args
} {
566 # Should we run [mc] in caller's namespace?
567 lassign
[UnderlineAmpersand
[mc
$arg]] msg
568 set length
[string length
$msg]
569 if {$length > $maxlen} {
576 # For now, turn off the custom mdef proc for the mac:
578 if {[tk windowingsystem
] eq
"aqua"} {
579 namespace eval ::tk::mac {
580 variable useCustomMDEF
0
584 # Run the Ttk themed widget set initialization
585 if {$::ttk::library ne
""} {
586 uplevel \#0 [list source [file join $::ttk::library ttk.tcl]]