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