From 6101c7baf07340632b03eaf31da112dda8eb450b Mon Sep 17 00:00:00 2001 From: dkf Date: Thu, 15 Nov 2001 14:02:46 +0000 Subject: tk_setPalette now works correctly under CDE, + an image demo update --- ChangeLog | 8 ++++++++ library/demos/image2.tcl | 48 ++++++++++++++++++++++++++++++++++++------------ library/palette.tcl | 21 ++++++++++++++++----- 3 files changed, 60 insertions(+), 17 deletions(-) diff --git a/ChangeLog b/ChangeLog index 564fa10..c7fc3e1 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,5 +1,13 @@ 2001-11-15 Donal K. Fellows + * library/demos/image2.tcl: Many improvements to this + image-viewing demo; now uses labelframes and tk_chooseDirectory + + * library/palette.tcl (::tk::RecolorTree): Made this work better + with CDE, which does some extremely annoying things with the + option database that interact badly with Tk's way of handling + options. + * doc/text.n: Overhauled the documentation of undo to make it easier to understand. * library/tk.tcl (::tk::EventMotifBindings): Added Emacs-like undo 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 "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 "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 "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] -- cgit v0.12