tk_setPalette now works correctly under CDE, + an image demo update

2 files changed, 52 insertions, 17 deletions

diff --git a/library/demos/image2.tcl b/library/demos/image2.tcl
index 6d3be0f..e7195e6 100644
--- a/library/demos/image2.tcl
+++ b/library/demos/image2.tcl
@@ -3,7 +3,7 @@
 # This demonstration script creates a simple collection of widgets
 # that allow you to select and view images in a Tk label.
 #
-# RCS: @(#) $Id: image2.tcl,v 1.3 2001/08/10 08:33:35 dkf Exp $
+# RCS: @(#) $Id: image2.tcl,v 1.4 2001/11/15 14:02:47 dkf Exp $
 
 if {![info exists widgetDemo]} {
     error "This script should be run from the \"widget\" demo."
@@ -25,6 +25,23 @@ proc loadDir w {
     }
 }
 
+# loadDir --
+# This procedure pops up a dialog to ask for a directory to load into
+# the listobx and (if the user presses OK) reloads the directory
+# listbox from the directory named in the demo's entry.
+#
+# Arguments:
+# w -			Name of the toplevel window of the demo.
+
+proc selectAndLoadDir w {
+    global dirName
+    set dir [tk_chooseDirectory -initialdir $dirName -parent $w -mustexist 1]
+    if {[string length $dir] != 0} {
+	set dirName $dir
+	loadDir $w
+    }
+}
+
 # loadImage --
 # Given the name of the toplevel window of the demo and the mouse
 # position, extracts the directory entry under the mouse and loads
@@ -57,14 +74,18 @@ button $w.buttons.dismiss -text Dismiss -command "destroy $w"
 button $w.buttons.code -text "See Code" -command "showCode $w"
 pack $w.buttons.dismiss $w.buttons.code -side left -expand 1
 
-label $w.dirLabel -text "Directory:"
+frame $w.mid
+pack $w.mid -fill both -expand 1
+
+labelframe $w.dir -text "Directory:"
 set dirName [file join $tk_library demos images]
-entry $w.dirName -width 30 -textvariable dirName
-bind $w.dirName <Return> "loadDir $w"
-frame $w.spacer1 -height 3m -width 20
-label $w.fileLabel -text "File:"
-frame $w.f
-pack $w.dirLabel $w.dirName $w.spacer1 $w.fileLabel $w.f -side top -anchor w
+entry $w.dir.e -width 30 -textvariable dirName
+button $w.dir.b -pady 0 -padx 2m -text "Select Dir." \
+	-command "selectAndLoadDir $w"
+bind $w.dir.e <Return> "loadDir $w"
+pack $w.dir.e -side left -fill y -padx 2m -pady 2m
+pack $w.dir.b -side left -fill y -padx {0 2m} -pady 2m
+labelframe $w.f -text "File:" -padx 2m -pady 2m
 
 listbox $w.f.list -width 20 -height 10 -yscrollcommand "$w.f.scroll set"
 scrollbar $w.f.scroll -command "$w.f.list yview"
@@ -74,7 +95,10 @@ bind $w.f.list <Double-1> "loadImage $w %x %y"
 
 catch {image delete image2a}
 image create photo image2a
-frame $w.spacer2 -height 3m -width 20
-label $w.imageLabel -text "Image:"
-label $w.image -image image2a
-pack $w.spacer2 $w.imageLabel $w.image -side top -anchor w
+labelframe $w.image -text "Image:"
+label $w.image.image -image image2a
+pack $w.image.image -padx 2m -pady 2m
+
+grid $w.dir -        -sticky w -padx 1m -pady 1m -in $w.mid
+grid $w.f   $w.image -sticky nw -padx 1m -pady 1m -in $w.mid
+grid columnconfigure $w.mid 1 -weight 1
diff --git a/library/palette.tcl b/library/palette.tcl
index f278268..7542ef5 100644
--- a/library/palette.tcl
+++ b/library/palette.tcl
@@ -3,7 +3,7 @@
 # This file contains procedures that change the color palette used
 # by Tk.
 #
-# RCS: @(#) $Id: palette.tcl,v 1.6 2001/08/01 16:21:11 dgp Exp $
+# RCS: @(#) $Id: palette.tcl,v 1.7 2001/11/15 14:02:47 dkf Exp $
 #
 # Copyright (c) 1995-1997 Sun Microsystems, Inc.
 #
@@ -98,8 +98,11 @@ proc ::tk_setPalette {args} {
     # defaults are currently for this platform.
     toplevel .___tk_set_palette
     wm withdraw .___tk_set_palette
-    foreach q {button canvas checkbutton entry frame label listbox \
-	    menubutton menu message radiobutton scale scrollbar text} {
+    foreach q {
+	button canvas checkbutton entry frame label labelframe
+	listbox menubutton menu message radiobutton scale scrollbar
+	spinbox text
+    } {
 	$q .___tk_set_palette.$q
     }
 
@@ -150,14 +153,22 @@ proc ::tk_setPalette {args} {
 proc ::tk::RecolorTree {w colors} {
     upvar $colors c
     set result {}
+    set prototype .___tk_set_palette.[string tolower [winfo class $w]]
+    if {![winfo exists $prototype]} {
+	unset prototype
+    }
     foreach dbOption [array names c] {
 	set option -[string tolower $dbOption]
+	set class [string replace $dbOption 0 0 [string toupper \
+		[string index $dbOption 0]]]
 	if {![catch {$w config $option} value]} {
 	    # if the option database has a preference for this
 	    # dbOption, then use it, otherwise use the defaults
 	    # for the widget.
-	    set defaultcolor [option get $w $dbOption widgetDefault]
-	    if {[string match {} $defaultcolor]} {
+	    set defaultcolor [option get $w $dbOption $class]
+	    if {[string match {} $defaultcolor] || \
+		    ([info exists prototype] && \
+		    [$prototype cget $option] ne "$defaultcolor")} {
 		set defaultcolor [winfo rgb . [lindex $value 3]]
 	    } else {
 		set defaultcolor [winfo rgb . $defaultcolor]