[Fabricio Rocha] - 14 Feb 2011 - Some types of software, like simulators, GUI builders, or even simple databases, manipulate objects which have their behaviours and appearence 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 dinamically 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. [http://wiki.tcl.tk/_repo/images/Proplist1-Gnome.png] 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 dinamically 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 [dialog]s. 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 labelwhich 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 [dict]ionary 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 existant 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. <> ----- <> Known bugs and limitations [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. <> ----- <> Code 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: 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 -borderwidth 2 -relief sunken -padding 1 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 {::Proplist::OnDestroy %W} bind $w {::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 -borderwidth 2 -relief sunken -padding 1 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) \ [list ::Proplist::ValueChanged $w $optname] bind $line(Wdg) <> \ [list ::Proplist::ValueChanged $w $optname] bind $line(Wdg) <> \ [list ::Proplist::ValueChanged $w $optname] bind $line(Wdg) {focus [tk_focusNext %W]} bind $line(Wdg) \ [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) <> \ [list ::Proplist::ValueChanged $w $optname] bind $line(Wdg) \ [list ::Proplist::ValueChanged $w $optname] bind $line(Wdg) <> \ [list ::Proplist::ValueChanged $w $optname] bind $line(Wdg) <> \ [list ::Proplist::ValueChanged $w $optname] bind $line(Wdg) \ [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 \ [list ::Proplist::ValueChanged $w $optname] bind $line(Wdg).ent <> \ [list ::Proplist::ValueChanged $w $optname] bind $line(Wdg).ent <> \ [list ::Proplist::ValueChanged $w $optname] bind $line(Wdg).ent \ [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] - 14 Feb 2011 - First version posted in the Tclers wiki. ----- <> Demo script [http://wiki.tcl.tk/_repo/images/Proplist_demo-WinXP.png] [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) $enterScript $w tag bind $opt(-tag) $leaveScript } Canvas { $w bind $opt(-tag) $enterScript $w bind $opt(-tag) $leaveScript } default { bind $w $enterScript bind $w $leaveScript } } } else { bind $w $enterScript bind $w $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 [list after cancel $destroyScript] bind $t $destroyScript } Main ====== <> ----- <> Comments, questions, discussion, etc <> ----- <>Megawidgets[http://here.com/photo.gif|png|jpg]