This provides a new toplevel for arranging preferences or options in a common manner.
I still have some ideas for it. But right now it works fine. Some options can only be configured at creation time like -tabfont. It makes use of the BLT tabs but I tried to separate the tab functionality so that an other tab widget could be used. Any volunteers for tile ?
Oct. 14. 2005 Changes:
# Copyright (c) 2005, Rüdiger Härtel
# All Rights Reservered
#
#
# This code is freely distributable without restriction, but is
# provided as-is with no warranty expressed or implied.
#
#
# This widgets presents a framework for a
# preferences widget.
#
# Requirements:
# BLT
# autoscroll only used if package is installed
#
# Options:
# -canceltext <text> text for Cancel Button
# -command <script> script is invoked with 2
# parameter, window and cmd
# -defaulttext <text> text for Default Button
# -font
# -oktext <text> text for Ok Button
# -relief <relief>
# -tabfont <font>
# -textbackground <color>
# -textforeground <color>
# -highlightbackground <color>
# -highlightforeground <color>
# -tabstyle <style> currently: blt
# -titlefont
# -type okCancel, defaultOkCancel
#
# Commands:
# insert <index> <text> ?option value?
# configure ?option value?
# options returns a key value list of
# index and the path to the frame
#
# Insert Options:
# -title <text>
# -titleimage <image>
#
#
#
#
package require msgcat
msgcat::mcset de Ok "Ok"
msgcat::mcset de Cancel "Cancel"
msgcat::mcset de Default "Standardwerte"
namespace eval prefs {
variable widgetOptions
variable widgetCommands
variable _rcsid "\$Id: 14831,v 1.8 2005-10-15 06:00:47 jcw Exp $"
}
# ::prefs::prefs --
#
# This is the command that gets exported. It creates a new
# prefs widget.
#
# Arguments:
#
# w path of new widget to create
# args additional option/value pairs
# (eg: -background white, etc.)
#
# Results:
#
# It creates the widget and sets up all of the default bindings
#
# Returns:
#
# The name of the newly create widget
proc prefs::prefs { w args } {
namespace export prefs
variable widgetOptions
variable widgetCommands
if {![info exists widgetOptions]} {
Init
}
eval Build $w $args
}
# ::prefs::Init --
#
#
# Arguments:
#
# none
#
# Results:
#
# All state variables are set to their default values; all of
# the option database entries will exist.
#
# Returns:
#
# empty string
proc ::prefs::Init {} {
variable widgetOptions
variable widgetCommands
array set widgetOptions [list \
-canceltext {cancelText CancelText} \
-command {command Command} \
-defaulttext {defaultText DefaultText} \
-font {font Font} \
-oktext {okText OkText} \
-relief {relief Relief} \
-tabfont {tabFont TabFont} \
-textbackground {textBackground TextBackground} \
-textforeground {textForeground TextForeground} \
-highlightbackground {highlightBackground HighlightForeground} \
-highlightforeground {highlightForeground HighlightForeground} \
-tabstyle {tabStyle TabStyle} \
-titlefont {titleFont TitleFont} \
-type {type Type} \
]
set widgetCommands [list \
insert configure options
]
option add *Preferences.cancelText " Cancel " widgetDefault
option add *Preferences.defaultText " Default " widgetDefault
option add *Preferences.okText " Ok " widgetDefault
option add *Preferences.font "Helvetica 12 bold" widgetDefault
option add *Preferences.highlightBackground darkblue widgetDefault
option add *Preferences.highlightForeground white widgetDefault
option add *Preferences.tabFont "Helvetica 10" widgetDefault
option add *Preferences.titleFont "Helvetica 24" widgetDefault
option add *Preferences.tabStyle blt widgetDefault
option add *Preferences.textBackground white widgetDefault
option add *Preferences.textForeground black widgetDefault
option add *Preferences.type okCancel widgetDefault
# set class bindings
SetClassBindings
}
# ::prefs::SetClassBindings --
#
# Sets up the default bindings for the widget class
#
# this proc exists since it's The Right Thing To Do, but
# I haven't had the time to figure out how to do all the
# binding stuff on a class level. The main problem is that
# the entry widget must have focus for the insertion cursor
# to be visible. So, I either have to have the entry widget
# have the Combobox bindtag, or do some fancy juggling of
# events or some such. What a pain.
#
# Arguments:
#
# none
#
# Returns:
#
# empty string
proc ::prefs::SetClassBindings {} {
# make sure we clean up after ourselves...
bind Preferences <Destroy> [list ::prefs::DestroyHandler %W]
return ""
}
# ::prefs::Build --
#
# This does all of the work necessary to create the basic
# prefs.
#
# Arguments:
#
# w widget name
# args additional option/value pairs
#
# Results:
#
# Creates a new widget with the given name. Also creates a new
# namespace patterened after the widget name, as a child namespace
# to ::prefs
#
# Returns:
#
# the name of the widget
proc prefs::Build { w args } {
variable widgetOptions
namespace eval ::prefs::$w {
variable widgets
variable options
variable data
set widgets(foo) foo ;# coerce into an array
set options(foo) foo ;# coerce into an array
set data(foo) foo ;# coerce into an array
unset widgets(foo)
unset options(foo)
unset data(foo)
}
upvar ::prefs::${w}::widgets widgets
upvar ::prefs::${w}::options options
upvar ::prefs::${w}::data data
# create GUI
#
# +------------------------------------------+
# | +----------+ +------------------------+ |
# | | |-| | | |
# | | | | | | |
# | | | | | | |
# | | | | | | |
# | |optList | | | optFrame | |
# | | | | | | |
# | | | | | | |
# | | | | | | |
# | | | | | | |
# | | | | | | |
# | | | | | | |
# | | |-| | | |
# | +----------+ +------------------------+ |
# | |
# | +----------+ +--------+ +--------+ |
# | | Default | | Ok | | Cancel | |
# | +----------+ +--------+ +--------+ |
# +------------------------------------------+
#
# create optList and optFrame
set widgets(this) [toplevel $w -class Preferences]
# this defines all of the default options. We get the
# values from the option database. Note that if an array
# value is a list of length one it is an alias to another
# option, so we just ignore it
# if one option is given as argument use its value
# instead of the default option
foreach name [array names widgetOptions] {
if {[llength $widgetOptions($name)] == 1} continue
if { [lsearch $args $name] > -1 } {
set idx [lsearch $args $name]
set value [lindex $args [expr $idx + 1]]
set options($name) $value
} else {
set optName [lindex $widgetOptions($name) 0]
set optClass [lindex $widgetOptions($name) 1]
set value [option get $w $optName $optClass]
set options($name) $value
}
}
set pw $w.pw
set widgets(optPanedWin) [panedwindow $pw -orient horizontal \
-showhandle 0 -sashwidth 5]
set f1 [frame $pw.f1 -takefocus 0]
set widgets(optVScroll) $f1.optVS
set widgets(optHScroll) $f1.optHS
set widgets(optList) [text $f1.optList \
-cursor left_ptr \
-takefocus 0 \
-width 12 \
-height 15 \
-wrap none \
-spacing1 3 \
-spacing3 3 \
-xscroll [list $widgets(optHScroll) set]\
-yscroll [list $widgets(optVScroll) set]]
# see efftcl hierlist.tcl
set tabsize [option get $w indent Indent]
set tabsize [winfo pixels $w 10]
set tabs "15"
for {set i 1} {$i < 20} {incr i} {
lappend tabs [expr $i*$tabsize+15]
}
$widgets(optList) configure -tabs $tabs
set btags [bindtags $widgets(optList)]
set i [lsearch $btags Text]
if {$i >= 0} {
set btags [lreplace $btags $i $i]
}
bindtags $widgets(optList) $btags
## end
scrollbar $widgets(optVScroll) -orient vertical
scrollbar $widgets(optHScroll) -orient horizontal
if { [lsearch [package names] autoscroll] > -1} {
package require autoscroll
autoscroll::autoscroll $widgets(optVScroll)
autoscroll::autoscroll $widgets(optHScroll)
}
grid $widgets(optList) -row 0 -column 0 -sticky news
grid $widgets(optVScroll) -row 0 -column 1 -sticky ns
grid $widgets(optHScroll) -row 1 -column 0 -sticky ew
grid rowconfigure $f1 0 -weight 1
grid columnconfigure $f1 0 -weight 1
set widgets(optFrame) [frame $w.optFrame -takefocus 0]
$pw add $f1 -sticky news
$pw add $widgets(optFrame) -sticky news
#pack $pw -expand 1 -fill both -side top -pady 10 -padx 10
grid $pw -row 0 -column 0 -sticky news -padx 5 -pady 5
# create buttonFrame
set btnf [frame $w.f2 -takefocus 0]
set widgets(defaultButton) [button $btnf.defBtn]
set widgets(okButton) [button $btnf.okBtn]
set widgets(cancelButton) [button $btnf.cancelBtn]
grid $widgets(defaultButton) $widgets(okButton) $widgets(cancelButton) \
-row 0 -padx 5
#pack $btnf -pady 10 -expand 1 -fill both
grid $btnf -row 1 -column 0 -sticky ew -pady 10
grid rowconfigure $w 0 -weight 1
grid columnconfigure $w 0 -weight 1
set widgets(frame) ::prefs::${w}::$w
rename $w ::$widgets(frame)
proc ::$w { command args } \
"eval ::prefs::WidgetProc $w \$command \$args"
set data(curopt) ""
if {[catch "::prefs::Configure [list $widgets(this)] [array get options]" error]} {
catch {destroy $w}
error "internal error: $error"
}
return $w
}
# ::prefs::DestroyHandler {w} --
#
# Cleans up after a combobox widget is destroyed
#
# Arguments:
#
# w widget pathname
#
# Results:
#
# The namespace that was created for the widget is deleted,
# and the widget proc is removed.
proc ::prefs::DestroyHandler {w} {
upvar ::prefs::${w}::widgets widgets
array unset widgets
catch {
# if the widget actually being destroyed is of class Combobox,
# remove the namespace and associated proc.
if {[string compare [winfo class $w] "Preferences"] == 0} {
# delete the namespace and the proc which represents
# our widget
namespace delete ::combobox::$w
rename $w {}
}
}
return ""
}
# ::prefs::Configure --
#
# Implements the "configure" widget subcommand
#
# Arguments:
#
# w widget pathname
# args zero or more option/value pairs (or a single option)
#
# Results:
#
# Performs typcial "configure" type requests on the widget
proc ::prefs::Configure {w args} {
variable widgetOptions
upvar ::prefs::${w}::widgets widgets
upvar ::prefs::${w}::options options
if {[llength $args] == 0} {
# hmmm. User must be wanting all configuration information
# note that if the value of an array element is of length
# one it is an alias, which needs to be handled slightly
# differently
set results {}
foreach opt [lsort [array names widgetOptions]] {
if {[llength $widgetOptions($opt)] == 1} {
set alias $widgetOptions($opt)
set optName $widgetOptions($alias)
lappend results [list $opt $optName]
} else {
set optName [lindex $widgetOptions($opt) 0]
set optClass [lindex $widgetOptions($opt) 1]
set default [option get $w $optName $optClass]
if {[info exists options($opt)]} {
lappend results [list $opt $optName $optClass \
$default $options($opt)]
} else {
lappend results [list $opt $optName $optClass \
$default ""]
}
}
}
return $results
}
# one argument means we are looking for configuration
# information on a single option
if {[llength $args] == 1} {
# set opt [::combobox::Canonize $w option [lindex $args 0]]
set opt [lindex $args 0]
set optName [lindex $widgetOptions($opt) 0]
set optClass [lindex $widgetOptions($opt) 1]
set default [option get $w $optName $optClass]
set results [list $opt $optName $optClass \
$default $options($opt)]
return $results
}
# if we have an odd number of values, bail.
if {[expr {[llength $args]%2}] == 1} {
# hmmm. An odd number of elements in args
error "value for \"[lindex $args end]\" missing"
}
foreach option [array names options] {
set newValue $options($option)
if {[info exists options($option)]} {
set oldValue $options($option)
}
set options($option) $newValue
switch -- $option {
-canceltext {
$widgets(cancelButton) configure -text $newValue
}
-command {
if { $newValue eq {} } {
continue
}
foreach btn [list default ok cancel] {
$widgets(${btn}Button) configure -command [list $newValue $w $btn]
}
wm protocol $widgets(this) WM_DELETE_WINDOW [list $newValue $w cancel]
}
-defaulttext {
$widgets(defaultButton) configure -text $newValue
}
-font {
$widgets(optList) configure -font $newValue
set options($option) $newValue
}
-highlightbackground {
}
-highlightforeground {
}
-oktext {
$widgets(okButton) configure -text $newValue
}
-tabfont {
}
-textbackground {
$widgets(optList) configure -background $newValue
}
-textbackground {
$widgets(optList) configure -foreground $newValue
}
-titlefont {
}
-type {
switch -- $newValue {
"okCancel" {
grid forget $widgets(defaultButton)
}
default {
}
}
}
}
}
}
# ::prefs::WidgetProc --
#
#
# Arguments:
#
# w widget pathname
# command widget subcommand
# args additional arguments; varies with the subcommand
#
# Results:
#
# Performs the requested widget command
proc ::prefs::WidgetProc {w command args} {
upvar ::prefs::${w}::widgets widgets
upvar ::prefs::${w}::options options
upvar ::prefs::${w}::data data
#puts "[info level 0]"
set _args $args
set index [lindex $_args 0]
set _args [lreplace $_args 0 0]
set nodeText [lindex $_args 0]
set _args [lreplace $_args 0 0]
# if we have an odd number of values, bail.
if {[expr {[llength $_args]%2}] == 1} {
# hmmm. An odd number of elements in args
error "value for \"[lindex $args end]\" missing"
}
# Great. An even number of options. Let's make sure they
# are all valid before we do anything. Note that Canonize
# will generate an error if it finds a bogus option; otherwise
# it returns the canonical option name
foreach {name value} $_args {
set opts($name) $value
}
switch $command {
insert {
set ident [string map {{ } {} {.} {}} $nodeText]
set idx [string map {{ } {} {.} {}} $index]
# for index "end" create a new frame
# for a created index check if a tab widget exists
# if not create tab widget
# create a new frame
switch -- $idx {
"end" {
# create entry in optList widget
if { [array get opts "-image"] ne "" } {
$widgets(optList) image create end \
-image $opts(-image) -align center
}
$widgets(optList) insert end "$nodeText\n" [list optname $ident]
set activebg $options(-highlightbackground)
set activefg $options(-highlightforeground)
$widgets(optList) tag bind $ident <Enter> \
"$widgets(optList) tag configure $ident -background $activebg -foreground $activefg"
$widgets(optList) tag bind $ident <Leave> \
"$widgets(optList) tag configure $ident -background {} -foreground {}"
$widgets(optList) tag bind $ident <ButtonPress-1> \
"[list ::prefs::ActivateOption $w $ident]"
eval ::prefs::addNewOption $w $args
if { $data(curopt) eq "" } {
::prefs::ActivateOption $w $ident
}
set widgets(optFrame,${ident}Body) $widgets(optFrame,$ident).body
frame $widgets(optFrame,${ident}Body) -takefocus 0
pack $widgets(optFrame,${ident}Body) \
-expand 1 -fill both -side top -anchor nw
return $widgets(optFrame,${ident}Body)
}
default {
switch -- $options(-tabstyle) {
"blt" {
set w [eval ::prefs::addNewBltTab $w $args]
}
default {
error "only BLT tabs supported"
}
}
return $w
}
}
}
options {
set result [list]
set name ""
foreach item [array names widgets optFrame,*Body] {
regexp {optFrame,(.*)Body} $item dummy name
lappend result $name $widgets($item)
}
return $result
}
}
}
# ::prefs::addNewOption --
#
#
# Arguments:
#
# none
#
# Results:
#
# Insert new option in List
#
# Returns:
#
# empty string
proc ::prefs::addNewOption { w args } {
upvar ::prefs::${w}::widgets widgets
upvar ::prefs::${w}::options options
upvar ::prefs::${w}::data data
# puts [info level 0]
set index [lindex $args 0]
set args [lreplace $args 0 0]
set nodeText [lindex $args 0]
set args [lreplace $args 0 0]
# if we have an odd number of values, bail.
if {[expr {[llength $args]%2}] == 1} {
# hmmm. An odd number of elements in args
error "value for \"[lindex $args end]\" missing"
}
# Great. An even number of options. Let's make sure they
# are all valid before we do anything. Note that Canonize
# will generate an error if it finds a bogus option; otherwise
# it returns the canonical option name
foreach {name value} $args {
set opts($name) $value
}
set ident [string map {{ } {} {.} {}} $nodeText]
set idx [string map {{ } {} {.} {}} $index]
set widgets(optFrame,$ident) $widgets(optFrame).opt-$ident
frame $widgets(optFrame,$ident) -takefocus 0
set drawSeparator 0
if { [array get opts "-title"] ne "" } {
# create title label
set widgets(optFrame,${ident}Title) \
$widgets(optFrame,$ident).title
frame $widgets(optFrame,${ident}Title) -takefocus 0
label $widgets(optFrame,${ident}Title).l1 \
-text $opts(-title) \
-justify left -anchor w \
-font $options(-titlefont)
set drawSeparator 1
}
if { [array get opts "-titleimage"] ne "" } {
# add image
# if label doesn't exist yet create one
if { [array get opts "-title"] eq "" } {
set widgets(optFrame,${ident}Title) \
$widgets(optFrame,$ident).title
label $widgets(optFrame,${ident}Title).l1
set drawSeparator 1
}
$widgets(optFrame,${ident}Title).l1 configure \
-image $opts(-titleimage) \
-compound left
}
if { $drawSeparator == 1 } {
pack $widgets(optFrame,${ident}Title).l1 \
-anchor nw -fill x
pack $widgets(optFrame,${ident}Title) \
-anchor nw -fill x
frame $widgets(optFrame,${ident}Title).sep -height 2 \
-relief sunken -takefocus 0 -borderwidth 2
pack $widgets(optFrame,${ident}Title).sep -fill x -pady 3
}
}
# ::prefs::addNewBltTab --
#
#
# Arguments:
#
# none
#
# Results:
#
# Add Suboption as BLT Tab
#
# Returns:
#
# empty string
proc ::prefs::addNewBltTab { w args } {
upvar ::prefs::${w}::widgets widgets
upvar ::prefs::${w}::options options
upvar ::prefs::${w}::data data
if { [lsearch [package names] BLT] < 0 } {
error "package BLT is required"
}
package require BLT
#puts [info level 0]
set index [lindex $args 0]
set args [lreplace $args 0 0]
set nodeText [lindex $args 0]
set args [lreplace $args 0 0]
# if we have an odd number of values, bail.
if {[expr {[llength $args]%2}] == 1} {
# hmmm. An odd number of elements in args
error "value for \"[lindex $args end]\" missing"
}
# Great. An even number of options. Let's make sure they
# are all valid before we do anything. Note that Canonize
# will generate an error if it finds a bogus option; otherwise
# it returns the canonical option name
foreach {name value} $args {
set opts($name) $value
}
set ident [string map {{ } {} {.} {}} $nodeText]
set idx [string map {{ } {} {.} {}} $index]
if {[lsearch [array names widgets] "optFrame,$idx"] > -1 } {
if {[lsearch [array names widgets] "optFrame,${idx}-tab"] < 0 } {
# tab does not yet exist, create one
set widgets(optFrame,${idx}-tab) $widgets(optFrame,${idx}Body).tab$idx
set bgcolor [$widgets(this).pw cget -background]
blt::tabset $widgets(optFrame,${idx}-tab) -relief flat \
-takefocus 0 -tearoff 0 -tile "" \
-font $options(-tabfont) \
-borderwidth 0 \
-background $bgcolor \
-activebackground $bgcolor \
-selectbackground $bgcolor
pack $widgets(optFrame,${idx}-tab) -expand 1 -fill both
}
set widgets(optFrame,$ident) $widgets(optFrame,${idx}-tab).$ident
frame $widgets(optFrame,$ident) -takefocus 0
$widgets(optFrame,${idx}-tab) insert end $opts(-title) \
-window $widgets(optFrame,$ident) -fill both
return $widgets(optFrame,$ident)
} else {
error "Unknown index $ident"
}
}
# ::prefs::ActivateOption --
#
#
# Arguments:
#
# none
#
# Results:
#
# Show new frame and update internal variables
#
# Returns:
#
# empty string
proc ::prefs::ActivateOption { w opt } {
upvar ::prefs::${w}::widgets widgets
upvar ::prefs::${w}::options options
upvar ::prefs::${w}::data data
if { $data(curopt) eq "" } {
set data(curopt) $opt
}
pack forget $widgets(optFrame,$data(curopt))
pack $widgets(optFrame,$opt) -expand 1 -fill both -side top
set data(curopt) $opt
pack $widgets(optFrame,$data(curopt)) -expand 1 -fill both \
-padx 5 -pady 5
}
##
# some demo code
##
proc prefsAction { w cmd } {
puts [info level 0]
destroy $w
exit
}
prefs::prefs .p1 \
-textbackground white \
-oktext Okay \
-command prefsAction \
set t0 [.p1 insert end General -title "General"]
set t1 [.p1 insert end "Fonts and Colors" -title "Fonts and Colors"]
set t2 [.p1 insert end CANopen -title "CANopen"]
set t3 [.p1 insert end DeviceNet -title "DeviceNet"]
set t4 [.p1 insert end J1939 -title "J1939"]
set t5 [.p1 insert CANopen pdomap -title "PDO Mapping"]
set t6 [.p1 insert CANopen nodes -title "Node Names"]
set t7 [.p1 insert CANopen fonts -title "Fonts and Colors"]
#pack .p1 -expand yes -fill both
foreach tab [list $t0 $t1 $t2 $t3 $t4 $t5 $t6 $t7 ] {
puts $tab
label $tab.l1 -text $tab
pack $tab.l1 -side top
}