merge 8.6bug_450bb0ecad

11 files changed, 237 insertions, 37 deletions

diff --git a/library/button.tcl b/library/button.tcl
index b2bafb2..80d8bf9 100644
--- a/library/button.tcl
+++ b/library/button.tcl
@@ -597,12 +597,25 @@ proc ::tk::ButtonUp w {
 # w -		The name of the widget.
 
 proc ::tk::ButtonInvoke w {
-    if {[$w cget -state] ne "disabled"} {
+    if {[winfo exists $w] && [$w cget -state] ne "disabled"} {
 	set oldRelief [$w cget -relief]
 	set oldState [$w cget -state]
 	$w configure -state active -relief sunken
-	update idletasks
-	after 100
+	after 100 [list ::tk::ButtonInvokeEnd $w $oldState $oldRelief]
+    }
+}
+
+# ::tk::ButtonInvokeEnd --
+# The procedure below is called after a button is invoked through
+# the keyboard.  It simulate a release of the button via the mouse.
+#
+# Arguments:
+# w -         The name of the widget.
+# oldState -  Old state to be set back.
+# oldRelief - Old relief to be set back.
+
+proc ::tk::ButtonInvokeEnd {w oldState oldRelief} {
+    if {[winfo exists $w]} {
 	$w configure -state $oldState -relief $oldRelief
 	uplevel #0 [list $w invoke]
     }
diff --git a/library/demos/ixset b/library/demos/ixset
index ee6e072..13235de 100644
--- a/library/demos/ixset
+++ b/library/demos/ixset
@@ -9,7 +9,6 @@ exec wish "$0" ${1+"$@"}
 #   91/11/23 : pda@masi.ibp.fr, jt@ratp.fr : design
 #   92/08/01 : pda@masi.ibp.fr : cleaning
 
-package require Tcl 8.4
 package require Tk
 
 #
diff --git a/library/demos/rmt b/library/demos/rmt
index 51886de..00bdc9d 100644
--- a/library/demos/rmt
+++ b/library/demos/rmt
@@ -7,7 +7,6 @@ exec wish "$0" ${1+"$@"}
 # Tk applications.  It allows you to select an application and
 # then type commands to that application.
 
-package require Tcl 8.4
 package require Tk
 
 wm title . "Tk Remote Controller"
diff --git a/library/demos/states.tcl b/library/demos/states.tcl
index 92b1f1e..aeb3d5b 100644
--- a/library/demos/states.tcl
+++ b/library/demos/states.tcl
@@ -19,6 +19,17 @@ positionWindow $w
 label $w.msg -font $font -wraplength 4i -justify left -text "A listbox containing the 50 states is displayed below, along with a scrollbar.  You can scan the list either using the scrollbar or by scanning.  To scan, press button 2 in the widget and drag up or down."
 pack $w.msg -side top
 
+labelframe $w.justif -text Justification
+foreach c {Left Center Right} {
+    set lower [string tolower $c]
+    radiobutton $w.justif.$lower -text $c -variable just \
+        -relief flat -value $lower -anchor w \
+        -command "$w.frame.list configure -justify \$just" \
+        -tristatevalue "multi"
+    pack $w.justif.$lower -side left -pady 2 -fill x
+}
+pack $w.justif
+
 ## See Code / Dismiss buttons
 set btns [addSeeDismiss $w.buttons $w]
 pack $btns -side bottom -fill x
diff --git a/library/demos/timer b/library/demos/timer
index e10b840..6b61ca4 100644
--- a/library/demos/timer
+++ b/library/demos/timer
@@ -5,7 +5,6 @@ exec wish "$0" ${1+"$@"}
 # timer --
 # This script generates a counter with start and stop buttons.
 
-package require Tcl 8.4
 package require Tk
 
 label .counter -text 0.00 -relief raised -width 10 -padx 2m -pady 1m
diff --git a/library/demos/widget b/library/demos/widget
index 7604341..1d838ad 100644
--- a/library/demos/widget
+++ b/library/demos/widget
@@ -10,7 +10,6 @@ exec wish "$0" ${1+"$@"}
 # separate ".tcl" files is this directory, which are sourced by this script as
 # needed.
 
-package require Tcl	8.5
 package require Tk	8.5
 package require msgcat
 
diff --git a/library/megawidget.tcl b/library/megawidget.tcl
index 9b9be92..aeb1263 100644
--- a/library/megawidget.tcl
+++ b/library/megawidget.tcl
@@ -29,14 +29,13 @@ package require Tk 8.6
 }
 
 ::oo::class create ::tk::MegawidgetClass {
-    variable w hull OptionSpecification options IdleCallbacks
+    variable w hull options IdleCallbacks
     constructor args {
 	# Extract the "widget name" from the object name
 	set w [namespace tail [self]]
 
 	# Configure things
-	set OptionSpecification [my GetSpecs]
-	my configure {*}$args
+	tclParseConfigSpec [my varname options] [my GetSpecs] "" $args
 
 	# Move the object out of the way of the hull widget
 	rename [self] _tmp
@@ -46,7 +45,7 @@ package require Tk 8.6
 	bind $hull <Destroy> [list [namespace which my] destroy]
 
 	# Rename things into their final places
-	rename ::$w theFrame
+	rename ::$w theWidget
 	rename [self] ::$w
 
 	# Make the contents
@@ -63,28 +62,165 @@ package require Tk 8.6
 	}
     }
 
+    ####################################################################
+    #
+    # MegawidgetClass::configure --
+    #
+    #	Implementation of 'configure' for megawidgets. Emulates the operation
+    #	of the standard Tk configure method fairly closely, which makes things
+    #	substantially more complex than they otherwise would be.
+    #
+    #	This method assumes that the 'GetSpecs' method returns a description
+    #	of all the specifications of the options (i.e., as Tk returns except
+    #	with the actual values removed). It also assumes that the 'options'
+    #	array in the class holds all options; it is up to subclasses to set
+    #	traces on that array if they want to respond to configuration changes.
+    #
+    #	TODO: allow unambiguous abbreviations.
+    #
     method configure args {
-	tclParseConfigSpec [my varname options] $OptionSpecification "" $args
+	# Configure behaves differently depending on the number of arguments
+	set argc [llength $args]
+	if {$argc == 0} {
+	    return [lmap spec [my GetSpecs] {
+		lappend spec $options([lindex $spec 0])
+	    }]
+	} elseif {$argc == 1} {
+	    set opt [lindex $args 0]
+	    if {[info exists options($opt)]} {
+		set spec [lsearch -inline -index 0 -exact [my GetSpecs] $opt]
+		return [linsert $spec end $options($opt)]
+	    }
+	} elseif {$argc == 2} {
+	    # Special case for where we're setting a single option. This
+	    # avoids some of the costly operations. We still do the [array
+	    # get] as this gives a sufficiently-consistent trace.
+	    set opt [lindex $args 0]
+	    if {[dict exists [array get options] $opt]} {
+		# Actually set the new value of the option. Use a catch to
+		# allow a megawidget user to throw an error from a write trace
+		# on the options array to reject invalid values.
+		try {
+		    array set options $args
+		} on error {ret info} {
+		    # Rethrow the error to get a clean stack trace
+		    return -code error -errorcode [dict get $info -errorcode] $ret
+		}
+		return
+	    }
+	} elseif {$argc % 2 == 0} {
+	    # Check that all specified options exist. Any unknown option will
+	    # cause the merged dictionary to be bigger than the options array
+	    set merge [dict merge [array get options] $args]
+	    if {[dict size $merge] == [array size options]} {
+		# Actually set the new values of the options. Use a catch to
+		# allow a megawidget user to throw an error from a write trace
+		# on the options array to reject invalid values
+		try {
+		    array set options $args
+		} on error {ret info} {
+		    # Rethrow the error to get a clean stack trace
+		    return -code error -errorcode [dict get $info -errorcode] $ret
+		}
+		return
+	    }
+	    # Due to the order of the merge, the unknown options will be at
+	    # the end of the dict. This makes the first unknown option easy to
+	    # find.
+	    set opt [lindex [dict keys $merge] [array size options]]
+	} else {
+	    set opt [lindex $args end]
+	    return -code error -errorcode [list TK VALUE_MISSING] \
+		"value for \"$opt\" missing"
+	}
+	return -code error -errorcode [list TK LOOKUP OPTION $opt] \
+	    "bad option \"$opt\": must be [tclListValidFlags options]"
     }
+
+    ####################################################################
+    #
+    # MegawidgetClass::cget --
+    #
+    #	Implementation of 'cget' for megawidgets. Emulates the operation of
+    #	the standard Tk cget method fairly closely.
+    #
+    #	This method assumes that the 'options' array in the class holds all
+    #	options; it is up to subclasses to set traces on that array if they
+    #	want to respond to configuration reads.
+    #
+    #	TODO: allow unambiguous abbreviations.
+    #
     method cget option {
 	return $options($option)
     }
 
+    ####################################################################
+    #
+    # MegawidgetClass::TraceOption --
+    #
+    #	Sets up the tracing of an element of the options variable.
+    #
+    method TraceOption {option method args} {
+	set callback [list my $method {*}$args]
+	trace add variable options($option) write [namespace code $callback]
+    }
+
+    ####################################################################
+    #
+    # MegawidgetClass::GetSpecs --
+    #
+    #	Return a list of descriptions of options supported by this
+    #	megawidget. Each option is described by the 4-tuple list, consisting
+    #	of the name of the option, the "option database" name, the "option
+    #	database" class-name, and the default value of the option. These are
+    #	the same values returned by calling the configure method of a widget,
+    #	except without the current values of the options.
+    #
     method GetSpecs {} {
 	return {
 	    {-takefocus takeFocus TakeFocus {}}
 	}
     }
 
+    ####################################################################
+    #
+    # MegawidgetClass::CreateHull --
+    #
+    #	Creates the real main widget of the megawidget. This is often a frame
+    #	or toplevel widget, but isn't always (lightweight megawidgets might
+    #	use a content widget directly).
+    #
+    #	The name of the hull widget is given by the 'w' instance variable. The
+    #	name should be written into the 'hull' instance variable. The command
+    #	created by this method will be renamed.
+    #
     method CreateHull {} {
 	return -code error -errorcode {TCL OO ABSTRACT_METHOD} \
 	    "method must be overridden"
     }
+
+    ####################################################################
+    #
+    # MegawidgetClass::Create --
+    #
+    #	Creates the content of the megawidget. The name of the widget to
+    #	create the content in will be in the 'hull' instance variable.
+    #
     method Create {} {
 	return -code error -errorcode {TCL OO ABSTRACT_METHOD} \
 	    "method must be overridden"
     }
 
+    ####################################################################
+    #
+    # MegawidgetClass::WhenIdle --
+    #
+    #	Arrange for a method to be called on the current instance when Tk is
+    #	idle. Only one such method call per method will be queued; subsequent
+    #	queuing actions before the callback fires will be silently ignored.
+    #	The additional args will be passed to the callback, and the callbacks
+    #	will be properly cancelled if the widget is destroyed.
+    #
     method WhenIdle {method args} {
 	if {![info exists IdleCallbacks($method)]} {
 	    set IdleCallbacks($method) [after idle [list \
@@ -97,6 +233,15 @@ package require Tk 8.6
     }
 }
 
+####################################################################
+#
+# tk::SimpleWidget --
+#
+#	Simple megawidget class that makes it easy create widgets that behave
+#	like a ttk widget. It creates the hull as a ttk::frame and maps the
+#	state manipulation methods of the overall megawidget to the equivalent
+#	operations on the ttk::frame.
+#
 ::tk::Megawidget create ::tk::SimpleWidget {} {
     variable w hull options
     method GetSpecs {} {
@@ -107,12 +252,12 @@ package require Tk 8.6
     }
     method CreateHull {} {
 	set hull [::ttk::frame $w -cursor $options(-cursor)]
-	trace add variable options(-cursor) write \
-	    [namespace code {my UpdateCursorOption}]
+	my TraceOption -cursor UpdateCursorOption
     }
     method UpdateCursorOption args {
 	$hull configure -cursor $options(-cursor)
     }
+    # Not fixed names, so can't forward
     method state args {
 	tailcall $hull state {*}$args
     }
@@ -121,6 +266,13 @@ package require Tk 8.6
     }
 }
 
+####################################################################
+#
+# tk::FocusableWidget --
+#
+#	Simple megawidget class that makes a ttk-like widget that has a focus
+#	ring.
+#
 ::tk::Megawidget create ::tk::FocusableWidget ::tk::SimpleWidget {
     variable w hull options
     method GetSpecs {} {
@@ -133,8 +285,7 @@ package require Tk 8.6
 	ttk::frame $w
 	set hull [ttk::entry $w.cHull -takefocus 0 -cursor $options(-cursor)]
 	pack $hull -expand yes -fill both -ipadx 2 -ipady 2
-	trace add variable options(-cursor) write \
-	    [namespace code {my UpdateCursorOption}]
+	my TraceOption -cursor UpdateCursorOption
     }
 }
 
diff --git a/library/scrlbar.tcl b/library/scrlbar.tcl
index b7be014..6f1caa2 100644
--- a/library/scrlbar.tcl
+++ b/library/scrlbar.tcl
@@ -430,6 +430,9 @@ proc ::tk::ScrollTopBottom {w x y} {
 
 proc ::tk::ScrollButton2Down {w x y} {
     variable ::tk::Priv
+    if {![winfo exists $w]} {
+        return
+    }
     set element [$w identify $x $y]
     if {[string match {arrow[12]} $element]} {
 	ScrollButtonDown $w $x $y
@@ -443,7 +446,9 @@ proc ::tk::ScrollButton2Down {w x y} {
     # slider drag.
 
     update idletasks
-    $w configure -activerelief sunken
-    $w activate slider
-    ScrollStartDrag $w $x $y
+    if {[winfo exists $w]} {
+        $w configure -activerelief sunken
+        $w activate slider
+        ScrollStartDrag $w $x $y
+    }
 }
diff --git a/library/spinbox.tcl b/library/spinbox.tcl
index 6a5f829..1965ed8 100644
--- a/library/spinbox.tcl
+++ b/library/spinbox.tcl
@@ -86,10 +86,12 @@ bind Spinbox <B1-Motion> {
     ::tk::spinbox::Motion %W %x %y
 }
 bind Spinbox <Double-1> {
+    ::tk::spinbox::ArrowPress %W %x %y
     set tk::Priv(selectMode) word
     ::tk::spinbox::MouseSelect %W %x sel.first
 }
 bind Spinbox <Triple-1> {
+    ::tk::spinbox::ArrowPress %W %x %y
     set tk::Priv(selectMode) line
     ::tk::spinbox::MouseSelect %W %x 0
 }
@@ -299,6 +301,10 @@ bind Spinbox <B2-Motion> {
 proc ::tk::spinbox::Invoke {w elem} {
     variable ::tk::Priv
 
+    if {![winfo exists $w]} {
+      return
+    }
+
     if {![info exists Priv(outsideElement)]} {
 	$w invoke $elem
 	incr Priv(repeated)
@@ -328,6 +334,35 @@ proc ::tk::spinbox::ClosestGap {w x} {
     incr pos
 }
 
+# ::tk::spinbox::ArrowPress --
+# This procedure is invoked to handle button-1 presses in buttonup
+# or buttondown elements of spinbox widgets.
+#
+# Arguments:
+# w -		The spinbox window in which the button was pressed.
+# x -		The x-coordinate of the button press.
+# y -		The y-coordinate of the button press.
+
+proc ::tk::spinbox::ArrowPress {w x y} {
+    variable ::tk::Priv
+
+    if {[$w cget -state] ne "disabled" && \
+            [string match "button*" $Priv(element)]} {
+        $w selection element $Priv(element)
+        set Priv(repeated) 0
+        set Priv(relief) [$w cget -$Priv(element)relief]
+        catch {after cancel $Priv(afterId)}
+        set delay [$w cget -repeatdelay]
+        if {$delay > 0} {
+            set Priv(afterId) [after $delay \
+                    [list ::tk::spinbox::Invoke $w $Priv(element)]]
+        }
+        if {[info exists Priv(outsideElement)]} {
+            unset Priv(outsideElement)
+        }
+    }
+}
+
 # ::tk::spinbox::ButtonDown --
 # This procedure is invoked to handle button-1 presses in spinbox
 # widgets.  It moves the insertion cursor, sets the selection anchor,
@@ -336,6 +371,7 @@ proc ::tk::spinbox::ClosestGap {w x} {
 # Arguments:
 # w -		The spinbox window in which the button was pressed.
 # x -		The x-coordinate of the button press.
+# y -		The y-coordinate of the button press.
 
 proc ::tk::spinbox::ButtonDown {w x y} {
     variable ::tk::Priv
@@ -350,20 +386,7 @@ proc ::tk::spinbox::ButtonDown {w x y} {
 
     switch -exact $Priv(element) {
 	"buttonup" - "buttondown" {
-	    if {"disabled" ne [$w cget -state]} {
-		$w selection element $Priv(element)
-		set Priv(repeated) 0
-		set Priv(relief) [$w cget -$Priv(element)relief]
-		catch {after cancel $Priv(afterId)}
-		set delay [$w cget -repeatdelay]
-		if {$delay > 0} {
-		    set Priv(afterId) [after $delay \
-			    [list ::tk::spinbox::Invoke $w $Priv(element)]]
-		}
-		if {[info exists Priv(outsideElement)]} {
-		    unset Priv(outsideElement)
-		}
-	    }
+	    ::tk::spinbox::ArrowPress $w $x $y
 	}
 	"entry" {
 	    set Priv(selectMode) char
@@ -388,6 +411,7 @@ proc ::tk::spinbox::ButtonDown {w x y} {
 # Arguments:
 # w -		The spinbox window in which the button was pressed.
 # x -		The x-coordinate of the button press.
+# y -		The y-coordinate of the button press.
 
 proc ::tk::spinbox::ButtonUp {w x y} {
     variable ::tk::Priv
@@ -491,6 +515,8 @@ proc ::tk::spinbox::Paste {w x} {
 #
 # Arguments:
 # w -		The spinbox window.
+# x -		The x-coordinate of the mouse.
+# y -		The y-coordinate of the mouse.
 
 proc ::tk::spinbox::Motion {w x y} {
     variable ::tk::Priv
diff --git a/library/tk.tcl b/library/tk.tcl
index 946ab7e..54d8ffb 100644
--- a/library/tk.tcl
+++ b/library/tk.tcl
@@ -10,10 +10,8 @@
 # See the file "license.terms" for information on usage and redistribution of
 # this file, and for a DISCLAIMER OF ALL WARRANTIES.
 
-# Insist on running with compatible version of Tcl
-package require Tcl 8.6
 # Verify that we have Tk binary and script components from the same release
-package require -exact Tk  8.6.4
+package require -exact Tk  8.6.5
 
 # Create a ::tk namespace
 namespace eval ::tk {
diff --git a/library/ttk/menubutton.tcl b/library/ttk/menubutton.tcl
index 093bb02..2be064c 100644
--- a/library/ttk/menubutton.tcl
+++ b/library/ttk/menubutton.tcl
@@ -57,7 +57,7 @@ if {[tk windowingsystem] eq "x11"} {
     bind TMenubutton <ButtonPress-1>  \
 	{ %W state pressed ; ttk::menubutton::Popdown %W }
     bind TMenubutton <ButtonRelease-1>  \
-	{ %W state !pressed }
+	{ if {[winfo exists %W]} { %W state !pressed } }
 }
 
 # PostPosition --