Fix [Bug 2116837].

2 files changed, 64 insertions, 41 deletions

diff --git a/ChangeLog b/ChangeLog
index 2b40cbd..32f055a 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,8 @@
+2009-04-10  Donal K. Fellows  <dkf@users.sf.net>
+
+	* library/tk.tcl: [Bug 2116837]: Add event definitions to handle the
+	standard virtual events when Caps Lock is on.
+
 2009-04-08  Donal K. Fellows  <dkf@users.sf.net>
 
 	* library/demos/widget (addFormattedText): Stop marking demonstrations
diff --git a/library/tk.tcl b/library/tk.tcl
index 6299d01..3a31128 100644
--- a/library/tk.tcl
+++ b/library/tk.tcl
@@ -3,7 +3,7 @@
 # Initialization script normally executed in the interpreter for each
 # Tk-based application.  Arranges class bindings for widgets.
 #
-# RCS: @(#) $Id: tk.tcl,v 1.83 2009/01/16 20:55:12 dgp Exp $
+# RCS: @(#) $Id: tk.tcl,v 1.84 2009/04/10 10:16:24 dkf Exp $
 #
 # Copyright (c) 1992-1994 The Regents of the University of California.
 # Copyright (c) 1994-1996 Sun Microsystems, Inc.
@@ -26,7 +26,7 @@ namespace eval ::tk {
             # The msgcat package is not available.  Supply our own
             # minimal replacement.
             proc mc {src args} {
-                return [format $src {*}$args]
+                tailcall format $src {*}$args
             }
             proc mcmax {args} {
                 set max 0
@@ -59,7 +59,8 @@ namespace eval ::ttk {
 # isn't already on the path:
 
 if {[info exists ::auto_path] && ($::tk_library ne "")
-    && ($::tk_library ni $::auto_path)} {
+    && ($::tk_library ni $::auto_path)
+} then {
     lappend ::auto_path $::tk_library $::ttk::library
 }
 
@@ -129,7 +130,9 @@ proc ::tk::PlaceWindow {w {place ""} {anchor ""}} {
 	}
 	if {[tk windowingsystem] eq "aqua"} {
 	    # Avoid the native menu bar which sits on top of everything.
-	    if {$y < 22} { set y 22 }
+	    if {$y < 22} {
+		set y 22
+	    }
 	}
     }
     wm geometry $w +$x+$y
@@ -210,9 +213,11 @@ proc ::tk::RestoreFocusGrab {grab focus {destroy destroy}} {
 #
 if {$tcl_platform(platform) eq "unix"} {
     proc ::tk::GetSelection {w {sel PRIMARY}} {
-	if {[catch {selection get -displayof $w -selection $sel \
-		-type UTF8_STRING} txt] \
-		&& [catch {selection get -displayof $w -selection $sel} txt]} {
+	if {[catch {
+	    selection get -displayof $w -selection $sel -type UTF8_STRING
+	} txt] && [catch {
+	    selection get -displayof $w -selection $sel
+	} txt]} then {
 	    return -code error "could not find default selection"
 	} else {
 	    return $txt
@@ -220,7 +225,9 @@ if {$tcl_platform(platform) eq "unix"} {
     }
 } else {
     proc ::tk::GetSelection {w {sel PRIMARY}} {
-	if {[catch {selection get -displayof $w -selection $sel} txt]} {
+	if {[catch {
+	    selection get -displayof $w -selection $sel
+	} txt]} then {
 	    return -code error "could not find default selection"
 	} else {
 	    return $txt
@@ -317,35 +324,35 @@ proc ::tk::EventMotifBindings {n1 dummy dummy} {
 
 if {![llength [info commands tk_chooseColor]]} {
     proc ::tk_chooseColor {args} {
-	return [tk::dialog::color:: {*}$args]
+	tailcall ::tk::dialog::color:: {*}$args
     }
 }
 if {![llength [info commands tk_getOpenFile]]} {
     proc ::tk_getOpenFile {args} {
 	if {$::tk_strictMotif} {
-	    return [tk::MotifFDialog open {*}$args]
+	    tailcall ::tk::MotifFDialog open {*}$args
 	} else {
-	    return [::tk::dialog::file:: open {*}$args]
+	    tailcall ::tk::dialog::file:: open {*}$args
 	}
     }
 }
 if {![llength [info commands tk_getSaveFile]]} {
     proc ::tk_getSaveFile {args} {
 	if {$::tk_strictMotif} {
-	    return [tk::MotifFDialog save {*}$args]
+	    tailcall ::tk::MotifFDialog save {*}$args
 	} else {
-	    return [::tk::dialog::file:: save {*}$args]
+	    tailcall ::tk::dialog::file:: save {*}$args
 	}
     }
 }
 if {![llength [info commands tk_messageBox]]} {
     proc ::tk_messageBox {args} {
-	return [tk::MessageBox {*}$args]
+	tailcall ::tk::MessageBox {*}$args
     }
 }
 if {![llength [info command tk_chooseDirectory]]} {
     proc ::tk_chooseDirectory {args} {
-	return [::tk::dialog::file::chooseDir:: {*}$args]
+	tailcall ::tk::dialog::file::chooseDir:: {*}$args
     }
 }
 
@@ -355,17 +362,22 @@ if {![llength [info command tk_chooseDirectory]]} {
 
 switch -exact -- [tk windowingsystem] {
     "x11" {
-	event add <<Cut>> <Control-Key-x> <Key-F20> 
-	event add <<Copy>> <Control-Key-c> <Key-F16>
-	event add <<Paste>> <Control-Key-v> <Key-F18>
+	event add <<Cut>> <Control-Key-x> <Key-F20> <Control-Lock-Key-X>
+	event add <<Copy>> <Control-Key-c> <Key-F16> <Control-Lock-Key-C>
+	event add <<Paste>> <Control-Key-v> <Key-F18> <Control-Lock-Key-V>
 	event add <<PasteSelection>> <ButtonRelease-2>
-	event add <<Undo>> <Control-Key-z>
-	event add <<Redo>> <Control-Key-Z>
-	# Some OS's define a goofy (as in, not <Shift-Tab>) keysym
-	# that is returned when the user presses <Shift-Tab>.  In order for
-	# tab traversal to work, we have to add these keysyms to the 
-	# PrevWindow event.
-	# We use catch just in case the keysym isn't recognized.
+	event add <<Undo>> <Control-Key-z> <Control-Lock-Key-Z>
+	event add <<Redo>> <Control-Key-Z> <Control-Lock-Key-z>
+	event add <<ContextMenu>> <Button-3>
+	if {$tk_platform(os) eq "Darwin"} {
+	    event add <<ContextMenu>> <Button-2>
+	}
+
+	# Some OS's define a goofy (as in, not <Shift-Tab>) keysym that is
+	# returned when the user presses <Shift-Tab>. In order for tab
+	# traversal to work, we have to add these keysyms to the PrevWindow
+	# event. We use catch just in case the keysym isn't recognized.
+
 	# This is needed for XFree86 systems
 	catch { event add <<PrevWindow>> <ISO_Left_Tab> }
 	# This seems to be correct on *some* HP systems.
@@ -378,21 +390,26 @@ switch -exact -- [tk windowingsystem] {
 	set ::tk::AlwaysShowSelection 1
     }
     "win32" {
-	event add <<Cut>> <Control-Key-x> <Shift-Key-Delete>
-	event add <<Copy>> <Control-Key-c> <Control-Key-Insert>
-	event add <<Paste>> <Control-Key-v> <Shift-Key-Insert>
+	event add <<Cut>> <Control-Key-x> <Shift-Key-Delete> \
+	    <Control-Lock-Key-X>
+	event add <<Copy>> <Control-Key-c> <Control-Key-Insert> \
+	    <Control-Lock-Key-C>
+	event add <<Paste>> <Control-Key-v> <Shift-Key-Insert> \
+	    <Control-Lock-Key-V>
 	event add <<PasteSelection>> <ButtonRelease-2>
-  	event add <<Undo>> <Control-Key-z>
-	event add <<Redo>> <Control-Key-y>
+  	event add <<Undo>> <Control-Key-z> <Control-Lock-Key-Z>
+	event add <<Redo>> <Control-Key-y> <Control-Lock-Key-Y>
+	event add <<ContextMenu>> <Button-3>
     }
     "aqua" {
-	event add <<Cut>> <Command-Key-x> <Key-F2> 
-	event add <<Copy>> <Command-Key-c> <Key-F3>
-	event add <<Paste>> <Command-Key-v> <Key-F4>
+	event add <<Cut>> <Command-Key-x> <Key-F2> <Control-Lock-Key-X>
+	event add <<Copy>> <Command-Key-c> <Key-F3> <Control-Lock-Key-C>
+	event add <<Paste>> <Command-Key-v> <Key-F4> <Control-Lock-Key-V>
 	event add <<PasteSelection>> <ButtonRelease-2>
 	event add <<Clear>> <Clear>
-  	event add <<Undo>> <Command-Key-z>
-	event add <<Redo>> <Command-Key-y>
+  	event add <<Undo>> <Command-Key-z> <Control-Lock-Key-Z>
+	event add <<Redo>> <Command-Key-y> <Control-Lock-Key-Y>
+	event add <<ContextMenu>> <Button-2>
     }
 }
 # ----------------------------------------------------------------------
@@ -421,7 +438,8 @@ if {$::tk_library ne ""} {
 # ----------------------------------------------------------------------
 
 event add <<PrevWindow>> <Shift-Tab>
-bind all <Tab> {tk::TabToWindow [tk_focusNext %W]}
+event add <<NextWindow>> <Tab>
+bind all <<NextWindow>> {tk::TabToWindow [tk_focusNext %W]}
 bind all <<PrevWindow>> {tk::TabToWindow [tk_focusPrev %W]}
 
 # ::tk::CancelRepeat --
@@ -473,10 +491,9 @@ proc ::tk::UnderlineAmpersand {text} {
 	    set idx  [string first "&" [string range $text $base end]]
 	    if {$idx < 0} {
 		break
-	    } else {
-		set underline [expr {$underline + $idx + 1}]
-		incr idx $base
 	    }
+	    set underline [expr {$underline + $idx + 1}]
+	    incr idx $base
 	}
     }
     if {$idx >= 0} {
@@ -566,8 +583,9 @@ proc ::tk::FindAltKeyTarget {path char} {
 #
 proc ::tk::AltKeyInDialog {path key} {
     set target [FindAltKeyTarget $path $key]
-    if { $target eq ""} return
-    event generate $target <<AltUnderlined>>
+    if {$target ne ""} {
+	event generate $target <<AltUnderlined>>
+    }
 }
 
 # ::tk::mcmaxamp --