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 delete widgets array when widget is destroyed add new command options add _rcsid variable vor version tracking
# 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.7 2005-10-15 06:00:46 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 }