Proplist, the "properties list" megawidget
Fabricio Rocha - 14 Feb 2011 - Some types of software, like simulators, GUI builders, or even simple databases, manipulate objects which have their behaviours and appearance determined by a number of configuration options, each one with different values. Some of these options might have as values any string; some other might require a "yes" or "no".
As the number of options may be enormous, it is often fundamental that the graphical user interfaces for showing this data and allowing the user to edit some of them are dynamically built -- usually from files which describe how a certain option is called, which possible values it might have, a brief human-readable description of what it does, how the values would be better presented, and so on. This requires a standard method of creating and displaying this interface, and because of that some of the applications mentioned above use something like a "properties list", "attributes editor", whatever it is called -- it is simply a two-column panel in which all these options are listed along with a widget most appropriate to the values acceptable for each option.
The Proplist megawidget presented here for Tcl/Tk 8.5 provides a Tk panel with this functionality, in which option lines can be added and displayed with different widgets for configuration input, optionally along with default or valid-only values. The megawidget provides automatic displacement and resizing of these widgets, an automatic vertical scrollbar, commands for simple data retrieval, and optional support for external "balloon help" systems and data validation for each option.
This is my first attempt in building a megawidget and I have been scratching my head on how to do it for 2 years or so, until I finally decided to seriously try to do it. I was happy with the overall results (actually, I am glad it works someway!) and, in spite of some obvious limitations listed below, I wanted to share it here (specially because I have seen more people looking for something like this). I really hope someone else consider the Proplist useful, and it would be specially good if it could be improved right here (I am quite attracted to this kind of "wiki-based development").
Manual
INPUT WIDGETS
In a Proplist megawidget, each option is displayed in two columns: the first column contains a label with a descriptive text about the configuration option, and the second column holds a specific type of input widget. The supported input widgets for the moment might be sufficient for most purposes:
- entry - This is the basic entry field, in which the user may type any value. It can be configured to be read-only/disabled.
- combo - A list of valid values is presented to the user. These values may come from a previously defined list, or can be dynamically generated by a procedure/command when the user first "opens" the menu. Optionally, it can be writeable, so the user can also input a value which is not in the list of choices.
- entrybut - Some values -- like dates, colors, file names, font specifications, etc -- usually come from more specific dialogs. This input widget encomprises an entry field in which the user may type a value directly, and a button which opens a specific dialog, being the result of this dialog written to the entry field. The programmer is free to assign to the button any procedure or command which shows a dialog, and manual input of a value in the entry can be disabled.
- separator - Not exactly an input widget, but also a supported type of "line item" in the Proplist, it is simply a label which occupies the two columns and create a visual "grouping" of properties lines. In future versions, the separator may become a button which will "collapse" or "expand" the lines below it.
WIDGET COMMANDS
::Proplist::proplist path ?-option value? ?-option value? ?...? Creates an instance of a Proplist; path becomes a command which refers to this instance.
path configure ?-option value? ?-option value? ?...? Configures the Proplist widget. As the megawidget does not touch Tk's options database, the command behaviour does not follow the Tk standard. If the command is called without arguments, it returns a dictionary containing all the current configuration of widget path. If one or more option/value pairs is/are passed, each option is updated to the new value. Options passed without values will cause an error, just as unknown options. The following options are supported:
- -highlightchanged boolean - If set to 1/true/on, lines whose values are modified will have their labels highlighted. Default is 0.
- -tooltipsetup proc - The name of a procedure which will be called for configuring the widgets used in each line of the Proplist for showing tooltips (also known as "balloon help"). Each line added to the Proplist may have an optional -helptext (see below) which will be displayed by the balloon help. The procedure receives as arguments, each time it is called, the Tk path of a widget used in the Proplist line, and the -helptext assigned to the line. These arguments -- and this kind of "per-widget" configuration -- is adopted by many tooltips systems used in Tk, which usually have a procedure for configuring the widgets and another for actually displaying a balloon tooltip. For tooltips systems which require extra arguments, proc may be simply a "wrapper" which calls the command which will perform the widget configuration itself.
path cget option Returns the current value for the given configuration option. Returns an error if option is not valid.
path valuesget ?mode? Returns a dictionary with all the currently set values for each option/value line shown in the proplist. The argument mode is optional: by default it has the value all, which causes the command to return all the options and values currently shown. If it has the value changed, the returned dictionary will contain only options which had their initial values changed. If it has the value nosep, separator lines are not included in the returned dict (as separators usually do not have their titles changed, they are not returned if mode is changed).
path clear Removes all the lines and any related data displayed in path.
ITEM COMMANDS
path lineset name linetype ?-option value? ... Add a new line in path for displaying a property called name, being linetype one of the supported input widgets mentioned above (see Input Widgets). If name is the same of an already existent line, the old entry is replaced. The following option/value pairs are supported:
- -title string - A string which, if present, will be shown in the line's label. If omitted, defaults to name.
- -values list - A list of valid values for the option. For a separator line type, this option is ignored. For option widgets of type entry or entrybut, only the first value in the list is considered (but a value passed for the -defval option will have precedence). If the option -valproc is also defined and it successfully returns a list of values, the list passed for -values' is ignored.
- -valproc proc - The name of a procedure which should return one or more possible values for the input widget when it is created. If linetype is combo, this procedure is called right before the list of available options is shown in the combobox, so the procedure can return a list of possible values. If linetype is entrybut, this procedure is the one which will be called when the user clicks on the button "..."; the procedure receives as argument the current value in the entry, and the value returned by the procedure is written to the entry. You can use one of the Tk dialogs directly -- for example, {tk_getOpenFile -initialfile } -- but beware that some of these dialogs will not work correctly if the entry's current value is empty or invalid (for example, tk_chooseColor will fail silently). If proc does not exist or fails to return a value, the list passed for the -value option is used.
- -defval value - An initial value to be shown in the option widget. This value has higher precedence than the list defined for -values and the value(s) returned by a defined -valproc, for line types entry and entrybut.
- -state string - May have the values normal, readonly or disabled. If linetype is separator, this option is ignored. If linetype is combo, the normal state will allow the user to input a value which is not in the list of values shown in the widget, the readonly state will force the choice of a value, and the disabled state will allow no selection. If linetype is entry, the disabled and readonly states will both block any input. If linetype is entrybut, the normal state will allow the user to type anything in the entry, the readonly state will block typing but will allow the button to work (by calling the procedure defined in -valproc and setting the value for the entry), and the disabled state will not allow any change.
- -helptext string - A string intended for "tooltip" or "balloon help". If the proplist's -helpproc procedure was defined, this string is passed to it as an argument; otherwise it is ignored.
- -updatepolicy string - Defines when the procedure passed for the option -updateproc will be called. Two values are supported: if it is focusout, the update procedure will be called when the input widget loses focus. If this value is onchange, the update procedure is called at each change in the entry field (if the input widget is combo, the procedure is called as soon as the user makes a choice). For entrybut lines, the onchange value will not cause the procedure defined by -updateproc to be called after each key press, as it does for entry lines, but the procedure will run as soon as a new value is completely written in the entry.
- -updateproc proc - Name of a procedure to be called when the value for the option is changed by the user. This procedure receives the line's name and the new value as arguments.
path lineget name Returns the current value on the line identified by name. If name is invalid, returns with error. For separator lines, the value returned is the string shown in the separator's label.
Fabricio Rocha - 14 Feb 2011 - I have tested a lot the Proplist code, but as I never created a megawidget before, it may obviously contain some problems and caveats. I am not sure I was able to properly handle the execution of the procedures passed for the -valproc and -updateproc procedures, and maybe they are out of the standard we found in Tcl and Tk regular commands (well, some of them work like this, some other accept scripts, some even perform % substitution like bind). The current mechanism may create problems if you want, for example, use "tk_getOpenFile -initialfile " as the command for an entrybut'. For the moment, it is better to adopt "wrapper" procedures able to deal with the passed arguments. I hope some of our guru Tclers can improve this.
One of the most obvious known limitations, up to the moment, is the lack of support for mousewheel scrolling in the Proplist.
Also, I can notice that the canvas's internal frame kind of "overlaps" the canvas borders, specially in Windows. I don't know what to do about this. Fabricio Rocha - 16 Feb 2011 - I had just seen the page Scrolling widgets and borders which tells that this is a known problem and explains why it happens. So the code is now free of this problem.
Please, feel free to improve the code. If you do it, please describe your changes in the Changelog section just below the code.
# PropList - A megawidget for displaying editable option/value pairs in
# a scrollable frame, in the fashion used by IDEs like VB, Delphi,
# Lazarus, etc
# Fabricio Rocha - 05 Feb 2011
# LAST MODIFIED: 16 Feb 2011 by Fabricio Rocha - Borders in the internal
# frame were causing a strange artifact around it. The borders were removed.
package require Tk 8.5
namespace eval ::Proplist {}
# ::Proplist::proplist
# The widget creator procedure.
# ARGUMENTS: "w" is the path of the widget to be created. "args" is an
# optional list of option/value pairs.
# RESULTS: Returns the name of the new widget and creates its path along
# with the respective widget command in the global namespace.
proc ::Proplist::proplist {w args} {
# Create the base frame
set fail [catch {ttk::frame $w} rval ropt]
if { $fail } {
set errormsg "Proplist: $rval"
return -code error $errormsg
}
# Build the megawidget
canvas $w.c -yscrollcommand \
[list ::Proplist::ScrollConfig $w.scrV]
ttk::scrollbar $w.scrV -orient vertical \
-command [list $w.c yview]
ttk::frame $w.c.inner -padding 2
set innerframeHnd [$w.c create window 0 0 -anchor nw\
-window $w.c.inner -width [winfo reqwidth $w.c]]
grid $w.c -column 0 -row 0 -sticky news
grid $w.scrV -column 1 -row 0 -sticky ns
grid columnconfigure $w 0 -weight 1
grid columnconfigure $w 1 -weight 0
grid rowconfigure $w 0 -weight 1
bind $w <Destroy> {::Proplist::OnDestroy %W}
bind $w <Configure> {::Proplist::InnerFrame_Resize %W}
# Create a sub-namespace for the widget instance, along with control
# variables and default configuration options
namespace eval ::Proplist::Wdgs::$w {
variable Lines {}
variable Properties [dict create \
-tooltipsetup {}\
-highlightchanged 0]
}
namespace eval ::Proplist::Wdgs::$w \
"dict set Properties InnerHnd $innerframeHnd"
# Setup the font for labels
::Proplist::LabelFontSetup $w
# Create the command by which the widget will be handled.
# Before that, the widget itself must be renamed because the creation
# of a command with same name will delete the widget command.
rename $w ORIG_$w
proc ::$w {cmd args} {
# This proc is created dinamically, with various names, and when
# called we need to know what is the caller talking about!
set wdg [lindex [info level 0] 0]
switch -- $cmd {
cget {
::Proplist::Cget $wdg {*}$args
}
lineset {
::Proplist::LineSet $wdg {*}$args
}
lineget {
::Proplist::LineGet $wdg {*}$args
}
clear {
::Proplist::Clear $wdg
}
valuesget {
::Proplist::ValuesGet $wdg {*}$args
}
default {
set errormsg "Unknown or unimplemented subcommand: $cmd"
return -code 1 $errormsg
}
}
}
# Now the widget is created, we can configure it using the passed
# list of options and values.
Configure $w {*}$args
return $w
}
# #####################################################################
# Widget-as-a-whole procedures
# #####################################################################
# OnDestroy
# Called when a widget is destroyed, for cleaning up the created
# namespace, command and variables.
# ARGUMENTS: Are automatically set by the trace command set on the
# widget command bound to be deleted: "wdgcmd" is the command itself,
# "newcmd" is presumed to be empty, "op" should be "delete".
proc ::Proplist::OnDestroy {wdgcmd} {
namespace delete ::Proplist::Wdgs::$wdgcmd
rename ::$wdgcmd {}
return
}
# InnerFrame_Resize
proc ::Proplist::InnerFrame_Resize {w} {
namespace upvar ::Proplist::Wdgs::$w Properties Properties
set hnd [dict get $Properties InnerHnd]
update idletasks
$w.c configure -scrollregion [$w.c bbox $hnd]
ScrollConfig $w.scrV {*}[$w.c yview]
set cwidth [winfo width $w.c]
$w.c.inner configure -width $cwidth
$w.c itemconfigure $hnd -width $cwidth
return
}
# ScrollConfig
# Called instead of the regular "$scrollbar set" command, this proc
# checks the need of the scrollbar, and grids/ungrids it as needed.
# ARGUMENTS: "scr" is the scrollbar, "first" and "second" are the
# arguments automatically added by the caller widget via its
# "-yscrollcommand" option.
proc ::Proplist::ScrollConfig {scr first last} {
if { $first == 0 && $last == 1} {
grid remove $scr
} else {
grid $scr
}
# Now the regular scrollbar's "set" command is called
$scr set $first $last
return
}
# Configure
# Configuration options for the proplist widget. It does NOT follow
# the Tk standard yet.
# ARGUMENTS: "w" is the widget's path; "args" is an optional list of
# option/value pairs.
# RESULTS: The new value for each passed option is stored in the widget
# configuration. Returns error if an invalid option is passed, or if
# an option is passed without a value.
proc ::Proplist::Configure {w args} {
namespace upvar ::Proplist::Wdgs::$w Properties Properties
set validopts [dict keys $Properties]
if { ![llength $args] } {
# The Properties dict stores some internal-use, read only data.
# Let's filter them out.
set retdic {}
foreach opt $validopts {
dict set retdic $opt [dict get $Properties $opt]
}
return $retdic
}
# Verify the passed options list
set badopts [catch {opts2dict STRICT $args $validopts} rval ropt]
if { $badopts } {
set errormsg "Proplist: Bad configuration: $rval"
return -code 1 $errormsg
} else {
set passedopts $rval
unset rval
}
# Verify validity of passed values, and apply them if they have
# immediate effects. Add other options when supported.
dict for {opt val} $passedopts {
switch -- $opt {
-highlightchanged {
if { ![string is boolean $val] } {
set errormsg \
"Proplist: value for $opt must be boolean"
return -code 1 $errormsg
}
}
}
}
# Store the new configuration options in the Properties dict
set Properties [dict merge \
[dict get $Properties] [dict get $passedopts]]
return
}
# Cget
#
proc ::Proplist::Cget { w args } {
namespace upvar ::Proplist::Wdgs::$w Properties Properties
set opt [lindex $args 0]
if [dict exists $Properties $opt] {
return [dict get $Properties $opt]
} else {
set errormsg "Proplist: invalid option: $opt"
return -code 1 $errormsg
}
}
# ValuesGet
# Returns a dictionary containing pairs of the options and values
# currently shown in a Proplist widget.
# ARGUMENTS: "w" is the widget from which to obtain the values. "which"
# is optional and means which of the values to retrieve: "all"
# (default) will retrieve all the options and values; "changed" will
# retrieve only those options whose values are different than the
# initial ones.
# RESULTS: Returns a dict in which every key is a line's name, along
# with the corresponding value. If the "which" argument got an invalid
# value, an error is returned. If the widget is showing no values at
# the moment, an empty dict is returned.
proc ::Proplist::ValuesGet {w {which all}} {
namespace upvar ::Proplist::Wdgs::$w Lines Lines
set validwhich [list all changed nosep]
if { $which ni $validwhich} {
set errormsg "Proplist: valuesget: unknown option $which"
return -code 1 $errormsg
}
set retdict {}
dict for {lineopt linedata} $Lines {
set curval [LineGet $w $lineopt]
if { $which eq "changed" } {
set initval [dict get $Lines $lineopt InitVal]
if { $curval eq $initval } {
continue
}
}
if { $which eq "nosep"} {
set linetype [dict get $Lines $lineopt LineType]
if { $linetype eq "separator" } {
continue
}
}
dict set retdict $lineopt $curval
}
return $retdict
}
# Clear
# Removes all the lines currently displayed in the Proplist widget,
# and erases any reference to them.
# ARGUMENTS: "w" is the name of the Proplist widget.
# RESULTS: The lines and their data are deleted. A new inner frame is
# created in the widget.
proc ::Proplist::Clear {w} {
namespace upvar ::Proplist::Wdgs::$w Lines Lines
namespace upvar ::Proplist::Wdgs::$w Properties Properties
set innerhnd [dict get $Properties InnerHnd]
$w.c delete $innerhnd
destroy $w.c.inner
set Lines {}
ttk::frame $w.c.inner -padding 2
set innerhnd [$w.c create window 0 0 -anchor nw\
-window $w.c.inner -width [winfo reqwidth $w.c]]
dict set Properties InnerHnd $innerhnd
return
}
# LabelFontSetup
# Discovers which font is being used for labels in the current Ttk
# style, then configures a bold version of it for use in the Proplist
# ARGUMENTS: "w" is the Proplist for which the fonts will be configured.
# RESULTS: The Properties dict of the proplist "w" will receive two more
# keys containing the names of the fonts to be used in the lines
# labels: "LabelFontNormal" and "LabelFontBold".
proc ::Proplist::LabelFontSetup {w} {
namespace upvar ::Proplist::Wdgs::$w Properties Properties
set normalfont [ttk::style lookup TLabel -font]
set normalsize [font configure $normalfont -size]
dict set Properties LabelFontBold \
[font create -family $normalfont -size $normalsize -weight bold]
dict set Properties LabelFontNormal $normalfont
return
}
# #####################################################################
# Lines-related procedures
# #####################################################################
# Proplist_Lineset
# Adds a new line of label and input widget to the Proplist.
# ARGUMENTS: "w" is the proplist widget in which the line will be added.
# "optname" is the name of the new entry. "inptype" is the kind of
# widget which will be used in this line for user input. "args" is an
# optional sequence of option/value pairs with configuration data for
# the new line.
# RESULTS: The line is appended to the widget's internal frame (if this
# frame does not exist, it is created).
proc ::Proplist::LineSet {w optname inptype args} {
namespace upvar ::Proplist::Wdgs::$w Properties Properties
namespace upvar ::Proplist::Wdgs::$w Lines Lines
# Default line configuration options
set defopts [dict create \
-title $optname\
-values {}\
-defval {}\
-valproc {}\
-state normal\
-helptext {}\
-updatepolicy FocusOut\
-updateproc {}\
]
set validtypes [list entry entrybut combo separator]
if { $inptype ni $validtypes } {
set errormsg "Proplist: $inptype is an invalid input widget"
return -code 1 $errormsg
}
unset validtypes
# Parse args
set badopts [catch { opts2dict STRICT $args [dict keys $defopts] }\
rval ropts]
if {$badopts} {
set errormsg "Proplist: configuration error: $rval"
return -code 1 $errormsg
} else {
# rval contains a dict; merge to the defaults one
set lineopts [dict merge $defopts $rval]
}
# Define the row in which the line will be created
# Verify if the widget already has an option line with the same name
if { $optname in [dict keys $Lines] } {
# The new line will replace the previous one. Delete the old one
set linerow [dict get $Lines $optname GridRow]
LineDelete $w $optname
} else {
# The new line will be created in the end of the inner frame:
# let's get its size for knowing the number of this last row
set linerow [lindex [grid size $w.c.inner] 1]
}
# Create the line of widgets
# Define the line's description label
set line(Title) $w.c.inner.lbl$optname
ttk::label $line(Title) -anchor center \
-text [dict get $lineopts -title]
# Instantiate the line's input widget and set its initial value
set line(Wdg) $w.c.inner.wdg$optname
set line(Val) {}
switch -- $inptype {
separator {
set line(Wdg) $line(Title)
set line(Val) [dict get $lineopts -title]
}
entry {
ttk::entry $line(Wdg)
set defv [dict get $lineopts -defval]
set vproc [dict get $lineopts -valproc]
set line(Val) [lindex [dict get $lineopts -values] 0]
if { $vproc ne "" } {
set vpfail [catch {eval $vproc} rv ro]
if { !$vpfail } {
set line(Val) $rv
}
}
if { $defv ne "" } {
set line(Val) $defv
}
$line(Wdg) insert 0 $line(Val)
$line(Wdg) configure -state [dict get $lineopts -state]
bind $line(Wdg) <KeyRelease> \
[list ::Proplist::ValueChanged $w $optname]
bind $line(Wdg) <<Cut>> \
[list ::Proplist::ValueChanged $w $optname]
bind $line(Wdg) <<Paste>> \
[list ::Proplist::ValueChanged $w $optname]
bind $line(Wdg) <Key-Return> {focus [tk_focusNext %W]}
bind $line(Wdg) <FocusOut> \
[list ::Proplist::EditionComplete $w $optname]
}
combo {
set vals [dict get $lineopts -values]
set vproc [dict get $lineopts -valproc]
if { $vproc ne "" } {
set vpfail [catch {{*}$vproc} rv ro]
if { !$vpfail } {
set vals $rv
}
}
set wdgstate [dict get $lineopts -state]
ttk::combobox $line(Wdg) -values $vals \
-state $wdgstate -postcommand ${vproc}
set line(Val) [dict get $lineopts -defval]
$line(Wdg) set $line(Val)
# Bindings
bind $line(Wdg) <<ComboboxSelected>> \
[list ::Proplist::ValueChanged $w $optname]
bind $line(Wdg) <KeyRelease> \
[list ::Proplist::ValueChanged $w $optname]
bind $line(Wdg) <<Cut>> \
[list ::Proplist::ValueChanged $w $optname]
bind $line(Wdg) <<Paste>> \
[list ::Proplist::ValueChanged $w $optname]
bind $line(Wdg) <FocusOut> \
[list ::Proplist::EditionComplete $w $optname]
}
entrybut {
ttk::frame $line(Wdg)
ttk::button $line(Wdg).btn -text "..." -width -1 \
-command [list ::Proplist::EntryBut_Valproc $w $optname]
ttk::entry $line(Wdg).ent
grid $line(Wdg).ent -column 0 -row 0 -sticky ew -padx {0 2}
grid $line(Wdg).btn -column 1 -row 0 -sticky e
grid columnconfigure $line(Wdg) 0 -weight 1
set line(Val) [dict get $lineopts -defval]
if { $line(Val) eq "" } {
set $line(Val) [lindex [dict get $lineopts -values] 0]
}
$line(Wdg).ent insert 0 $line(Val)
switch -- [dict get $lineopts -state] {
normal {
bind $line(Wdg).ent <KeyRelease> \
[list ::Proplist::ValueChanged $w $optname]
bind $line(Wdg).ent <<Paste>> \
[list ::Proplist::ValueChanged $w $optname]
bind $line(Wdg).ent <<Cut>> \
[list ::Proplist::ValueChanged $w $optname]
bind $line(Wdg).ent <FocusOut> \
[list ::Proplist::EditionComplete $w $optname]
}
readonly {
$line(Wdg).ent configure -state readonly
}
disabled {
$line(Wdg).ent configure -state disabled
$line(Wdg).btn configure -state disabled
}
}
}
}
# Add the bindings for the configured balloon help procedure, if any
set hproc [dict get $Properties -tooltipsetup]
set linehelp [dict get $lineopts -helptext]
if { $hproc ne "" && $linehelp ne "" } {
catch {$hproc $line(Title) $linehelp}
if { $inptype eq "entrybut"} {
catch {$hproc $line(Wdg).ent $linehelp}
catch {$hproc $line(Wdg).btn $linehelp}
} else {
catch {$hproc $line(Wdg) $linehelp}
}
}
# Grid the new line widgets in the inner frame
set where $w.c.inner
if { $line(Wdg) eq $line(Title) } {
# We have a separator
grid $line(Title) -in $where \
-column 0 -row $linerow -columnspan 2
} else {
grid $line(Title) -in $where \
-column 0 -row $linerow -sticky ew
grid $line(Wdg) -in $where \
-column 1 -row $linerow -sticky ew
}
grid columnconfigure $where 0 -weight 0 -uniform lab
grid columnconfigure $where 1 -weight 1 -uniform wdg
# Recalculate the scrollbar and update the inner frame's width
InnerFrame_Resize $w
# Store the new line's data in the Lines dict
dict set lineopts GridRow $linerow
dict set lineopts LineType $inptype
dict set lineopts InputWdg $line(Wdg)
dict set lineopts InitVal $line(Val)
dict set lineopts LineLabel $line(Title)
dict set Lines $optname $lineopts
return
}
# LineDelete
# Removes an option/value line from the widget, along with the line's
# entries in the widget's Line variable
proc ::Proplist::LineDelete {w optname} {
namespace upvar ::Proplist::Wdgs::$w Lines Lines
if { $optname ni [dict keys $Lines] } {
return
}
# Destroy the line's widgets
destroy $w.c.inner.lbl$optname
destroy $w.c.inner.wdg$optname
# Remove the line's data
set Lines [dict remove $Lines $optname]
return
}
# LineGet
# Returns the value currently set for an option line.
# ARGUMENTS: "w" is the proplist widget, "optname" is the option whose
# value is requested.
# RESULTS: Retrieves the value currently written in the option line's
# input widget. If "optname" is invalid, returns with error.
proc ::Proplist::LineGet {w optname} {
namespace upvar ::Proplist::Wdgs::$w Lines Lines
if { $optname ni [dict keys $Lines] } {
set errormsg "Proplist: option line $optname does not exist"
return -code 1 $errormsg
}
set linetype [dict get $Lines $optname LineType]
set inpwdg [dict get $Lines $optname InputWdg]
set val {}
switch -- $linetype {
separator {
# No value in fact: for now, return its text.
set val [$inpwdg cget -text]
}
entrybut {
set val [$inpwdg.ent get]
}
combo -
entry {
set val [$inpwdg get]
}
}
return $val
}
# EntryBut_Valproc
# This procedure is called when an entrybut's button is clicked. It
# catch-calls the procedure passed with the -valproc option and, if the
# procedure returns a useful string, write this value to the entry. The
# procedure receives as argument the current value in the entry.
# ARGUMENTS: "w" is the proplist in which the entrybut is; "line" is the
# name of the line which contains the entrybut
proc ::Proplist::EntryBut_Valproc {w line} {
namespace upvar ::Proplist::Wdgs::$w Lines Lines
set valproc [dict get $Lines $line -valproc]
if { $valproc eq ""} {
# Leave the entrybut's value as it is
return
}
set ebt [dict get $Lines $line InputWdg]
set curvalue [$ebt.ent get]
set vpfail [catch {eval $valproc $curvalue} rv ro ]
if { $vpfail } {
# The procedure failed.
# Action was to disable the button and return, but for faulty
# valueprocs this would be bad to the user. Something to debate.
# catch {$ebt.btn configure -state disabled}
return
} else {
# Clear the current contents in the entry button and place the
# returned value in there.
set prevstate [$ebt.ent cget -state]
$ebt.ent configure -state normal
$ebt.ent delete 0 end
$ebt.ent insert 0 $rv
$ebt.ent configure -state $prevstate
# Force a call to ValueChanged
ValueChanged $w $line
}
return
}
# ValueChanged
# This procedure is called whenever a line's value is edited. It
# compares the new value to the default, for supporting the
# -highlightchanged option of the Proplist, and call the procedure
# defined for the line's -updateproc option.
# ARGUMENTS: "w" is the Propline where the option line "line" can be
# found.
proc ::Proplist::ValueChanged {w line} {
namespace upvar ::Proplist::Wdgs::$w Properties Properties
namespace upvar ::Proplist::Wdgs::$w Lines Lines
set newval [LineGet $w $line]
set doHilite [dict get $Properties -highlightchanged]
if { $doHilite } {
set lbl [dict get $Lines $line LineLabel]
set initval [dict get $Lines $line InitVal]
if { $newval eq $initval } {
$lbl configure -font [dict get $Properties LabelFontNormal]
} else {
$lbl configure -font [dict get $Properties LabelFontBold]
}
}
# Call the widget's -updateproc if it exists and if -updatepolicy
# is set to "OnChange"
set uproc [dict get $Lines $line -updateproc]
set upol [dict get $Lines $line -updatepolicy]
if { $uproc ne "" && $upol eq "onchange"} {
set cmd [list $uproc $line $newval]
set upfail [catch {eval $cmd} rval ropt]
}
return
}
# EditionComplete
# This procedure verifies a line widget's value after the widget loses
# keyboard focus, and calls the line's assigned -updateproc if the
# update policy is "focusout"
# ARGUMENTS: "w" is the Proplist widget, "line" is the name of the line
# which invokes execution of its named -updateproc.
# RESULTS: The assigned -updateproc is called and have the line's name
# and current value passed to it as arguments. It runs "catch"ed; for
# development purposes it may be more useful to "let it blow" so
# an error in the -updateproc or even in the mode it is called can be
# better detected.
proc ::Proplist::EditionComplete {w line} {
namespace upvar ::Proplist::Wdgs::$w Properties Properties
namespace upvar ::Proplist::Wdgs::$w Lines Lines
set newval [LineGet $w $line]
set uproc [dict get $Lines $line -updateproc]
set upol [dict get $Lines $line -updatepolicy]
if { $uproc ne "" && $upol eq "focusout"} {
set cmd [list $uproc $line $newval]
puts "\nWill try to run the following -updateproc: $cmd"
set upfail [catch {eval $cmd} rval ropt]
puts "EditionComplete: upfail $upfail. rval: $rval"
}
return
}
# #####################################################################
# Helper procedures
# #####################################################################
# opts2dict
# Transforms a list of option/value pairs into a dict, with checking
# against a list of valid options and some formatting errors.
# ARGUMENTS: "mode" can have three values: ANYVAL (option followed by
# option has the second option stored as a value for the first one),
# EMPTYVAL (option followed by option is stored with empty value, and
# the new option is stored as a new key), STRICT (option followed by
# another recognized option generates an error). "optlist" is the list
# of option/value pairs to be parsed. "validopts" is the list of
# supported options.
# RESULTS: A dict with the options stored as keys along with the values
# is returned. Some keys may have empty values if "mode" was EMPTYVAL,
# this may be specially the case of the last key in the ANYVAL mode.
# A word placed and located as an option but not in "validopts" will
# cause an error. If mode is "STRICT", an error will be raised if any
# known option is placed as a value, or if there's a value where an
# option was expected.
proc ::Proplist::opts2dict {mode optlist validopts} {
# Validate parameters
if { $mode ni {STRICT ANYVAL EMPTYVAL} } {
set errormsg "opts2dic: invalid mode $mode"
return -code 1 $errormsg
}
# Initialize variables
set itemcount 0
set optsdic {}
set lastkey {}
# Process the list
foreach item $optlist {
set expectval [ expr {$itemcount % 2} ]
if { $item in $validopts } {
set knownopt 1
} else {
set knownopt 0
}
if { $expectval } {
# Item is 1st, 3rd, 5th... a value is expected.
if { $knownopt } {
# Item is a known option. Mode will tell what to do:
if { $mode eq "STRICT"} {
# STRICT forbids a value which looks like a key.
set errormsg "Option without a value: $lastkey"
return -code 1 $errormsg
}
if { $mode eq "EMPTYVAL"} {
# In EMPTYVAL mode, the last option becomes a key
# without a value in the returned dictionary. The
# previous option was left without a value when it
# was created as a key: we have to create the new
# key now and prepare it for the next value.
dict set optsdic $item {}
set lastkey $item
continue
}
# If we got here, mode is ANYVAL. Nothing special to do.
}
# Item is not a known option, or it is a known option but we
# are in ANYVAL mode: just store the item as a value
dict set optsdic $lastkey $item
set lastkey {}
} else {
# Item is 0th, 2nd, 4th... an option is expected.
if { $lastkey ne {} } {
# There was a key expecting a value.
if { $mode eq "STRICT" } {
# Error: previous key can't be left empty. Actually,
# this block should never happen, because an error
# might have been raised when the value found was
# detected as a key
puts "Boo! Expected an option, lastkey not empty"
}
if { $mode eq "EMPTYVAL"} {
# Create another key and prepare it for a value, if
# it is a known option: do nothing for now.
}
if { $mode eq "ANYVAL"} {
# Continue for having the item treated as a value.
# How will this affect the odd/even count?
set lastkey {}
continue
}
}
if { $knownopt } {
dict set optsdic $item {}
set lastkey $item
} else {
# Item is not a valid option. Error in any mode.
set errormsg "opts2dic: invalid option $item"
return -code 1 $errormsg
}
}
incr itemcount
}
# Final check for STRICT mode: if the last item was an option,
# it might have been left empty
if { [expr {$itemcount %2}] && $mode eq "STRICT" } {
if { [dict get $optsdic $lastkey] eq {} } {
set errormsg "Option without a value: $lastkey"
return -code 1 $errormsg
}
}
return $optsdic
}
Changelog
Fabricio Rocha - 16 Feb 2011 - Borders in the internal frame removed (changes in ::Proplist::proplist and ::Proplist::Clear). Fabricio Rocha - 14 Feb 2011 - First version posted in the Tclers wiki.
Fabricio Rocha- 14 Feb 2011 - This is quite, quite crappy, but I got it working somehow: this code uses a Proplist for defining the options for new lines added to another Proplist! Observe how each new line is dinamically configured and how the balloon help is implemented (the code for this balloon help system is exactly one of the many which can be found in the Wiki). Not all features are demonstrated, and if you create something more useful and interesting as a demo, please add it to this section...
#!/bin/sh
# Take this, bash \
exec tclsh "$0" ${1+"$@"}
source proplist.tcl
proc Main {} {
wm title . "Proplist demo"
wm withdraw .
ttk::panedwindow .pnd -orient horizontal
grid .pnd -column 0 -row 0 -sticky news
grid columnconfigure . 0 -weight 1
grid rowconfigure . 0 -weight 1
ttk::frame .pnd.left -borderwidth 2 -relief sunken
.pnd add .pnd.left
Proplist::proplist .pnd.prl -highlightchanged 1 \
-tooltipsetup setBalloonHelp
.pnd add .pnd.prl
ttk::button .pnd.left.btnAddLine -text "Add a line" \
-command AddLine
ttk::button .pnd.left.btnClear -text "Clear Proplist" \
-command {.pnd.prl clear}
grid .pnd.left.btnAddLine -column 0 -row 0 -sticky news
grid .pnd.left.btnClear -column 0 -row 3 -sticky news
grid columnconfigure .pnd.left 0 -weight 1
grid rowconfigure .pnd.left all -weight 1
wm deiconify .
}
proc AddLine {} {
if { [winfo exists .pnd.left.propLine] } {
.pnd.left.propLine clear
} else {
Proplist::proplist .pnd.left.propLine \
-tooltipsetup setBalloonHelp
grid .pnd.left.propLine -column 0 -row 1 -sticky news
}
.pnd.left.propLine lineset optLineName entry \
-title "Option name" \
-updatepolicy focusout \
-updateproc {LineConfig} \
-helptext "The name of the option line" \
-defval "New Line 1"
.pnd.left.propLine lineset optLineTitle entry \
-title "Option title" \
-helptext "The title to be shown in the line's label" \
-updatepolicy onchange\
-updateproc LineConfig\
.pnd.left.propLine lineset optLineWidget combo \
-title "Line's widget type"\
-helptext "The type of widget shown in the line"\
-state readonly\
-values {entry separator combo entrybut}\
-defval entry\
-updatepolicy focusout\
-updateproc LineConfig
.pnd.left.propLine lineset optLineHelp entry \
-title "Balloon help string"\
-helptext "The string to be shown by the balloon help"\
-updatepolicy onchange\
-updateproc LineConfig
.pnd.left.propLine lineset optLineValproc combo \
-state normal\
-title "Values provider command"\
-updatepolicy focusout\
-updateproc LineConfig\
-valproc {info commands ::*}
}
proc LineConfig {lineopt lineval} {
set lineopts [.pnd.left.propLine valuesget]
dict with lineopts {
.pnd.prl lineset $optLineName $optLineWidget \
-title $optLineTitle\
-helptext $optLineHelp\
-valproc $optLineValproc
}
}
proc setBalloonHelp {w msg args} {
array set opt [concat {
-tag ""
} $args]
if {$msg ne ""} then {
set toolTipScript\
[list showBalloonHelp %W [string map {% %%} $msg]]
set enterScript [list after 700 $toolTipScript]
set leaveScript [list after cancel $toolTipScript]
append leaveScript \n [list after 50 [list destroy .balloonHelp]]
} else {
set enterScript {}
set leaveScript {}
}
if {$opt(-tag) ne ""} then {
switch -- [winfo class $w] {
Text {
$w tag bind $opt(-tag) <Enter> $enterScript
$w tag bind $opt(-tag) <Leave> $leaveScript
}
Canvas {
$w bind $opt(-tag) <Enter> $enterScript
$w bind $opt(-tag) <Leave> $leaveScript
}
default {
bind $w <Enter> $enterScript
bind $w <Leave> $leaveScript
}
}
} else {
bind $w <Enter> $enterScript
bind $w <Leave> $leaveScript
}
}
proc showBalloonHelp {w msg} {
set t .balloonHelp
catch {destroy $t}
toplevel $t -bg blue
wm overrideredirect $t yes
if {$::tcl_platform(platform) == "macintosh"} {
unsupported1 style $t floating sideTitlebar
}
pack [label $t.l -text [subst $msg] -bg white -font {Verdana 9}]\
-padx 1\
-pady 1
set width [expr {[winfo reqwidth $t.l] + 2}]
set height [expr {[winfo reqheight $t.l] + 2}]
set xMax [expr {[winfo screenwidth $w] - $width}]
set yMax [expr {[winfo screenheight $w] - $height}]
set x [winfo pointerx $w]
set y [expr {[winfo pointery $w] + 20}]
if {$x > $xMax} then {
set x $xMax
}
if {$y > $yMax} then {
set y $yMax
}
wm geometry $t +$x+$y
set destroyScript [list destroy .balloonHelp]
bind $t <Enter> [list after cancel $destroyScript]
bind $t <Leave> $destroyScript
}
Main
SeS (22-2-2011) I will certainly keep your initiative in mind. I had similar challenges when designing the property editor of tG², my approach & implementation is less dynamic as yours, therefore I think this might be a useful add-on/enhancement to the existing property editor of tG². Thanks Fabricio.