Updated 2012-03-01 19:04:43 by hae

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 ? SC No, but I added BWidgets.

Screenshot

Mar. 01. 2012 Changes:

  • Fixed setting an option. Thanks for reporting go to: enel

Feb. 08. 2011 Changes:

  • enabled scrolling of the options list. Thanks for reporting go to: enel

Mar. 05. 2006 Changes:

  • added BWidget Tabstyle contributed by SC
  • use canvas to draw title of a page to show gradients [1]

Oct. 19. 2005 Changes:

  • fix typo in option
  • add color option for selected item
  • set default font to font size 10
  • leave selected item marked when highlighting another item
  • separate procs for enter and leave of an item

Oct. 14. 2005 Changes:

  • delete widgets array when widget is destroyed
  • add new command options
  • add _rcsid variable for 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, BWidget             one of the two
 #     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>
 #    -selectedbackground <color>
 #    -selectedforeground <color>
 #    -tabstyle <style>                blt or bwidget
 #    -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>
 #    -titlefont <font>
 #    -titlefg color
 #    -titlebg {'gradient' ['x'|'y'] <color1> <color2>, 'solid' <color>}
 #
 # Thanks to Rohan Pall for his gradients example on the wiki 9079.
 #
 #
 
 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.25 2006-12-14 19:00:12 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         HighlightBackground}        \
             -highlightforeground        {highlightForeground        HighlightForeground}        \
             -selectedbackground        {selectedBackground        SelectedBackground}        \
             -selectedforeground        {selectedForeground        SelectedForeground}        \
             -tabstyle                {tabStyle        TabStyle}        \
             -titlefont                {titleFont        TitleFont}        \
             -titlefg                {titleForeground        TitleForeground}        \
             -titlebg                {titleBackground        TitleBackground}        \
             -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 10 bold" widgetDefault
     option add *Preferences.highlightBackground    darkblue       widgetDefault
     option add *Preferences.highlightForeground    white          widgetDefault
     option add *Preferences.selectedBackground     darkblue       widgetDefault
     option add *Preferences.selectedForeground     white          widgetDefault
     option add *Preferences.tabFont                "Helvetica 10" widgetDefault
     option add *Preferences.titleFont              "Helvetica 24" widgetDefault
     option add *Preferences.titleForeground        "black"        widgetDefault
     option add *Preferences.titleBackground        ""                  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 \
        -command [list $widgets(optList) yview]
     scrollbar $widgets(optHScroll)   -orient horizontal \
        -command [list $widgets(optList) xview]
 
     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
 
     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
 
     grid $btnf -row 1 -column 0 -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 newValue} [array names options] {

         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]
 
                     $widgets(optList) tag bind $ident <Enter> \
                         [list ::prefs::EnterOption $w $ident]
                     $widgets(optList) tag bind $ident <Leave> \
                         [list ::prefs::LeaveOption $w $ident]
                     $widgets(optList) tag bind $ident <ButtonPress-1> \
                         [list ::prefs::ActivateOption $w $ident]
 
                     set activebg $options(-selectedbackground)
                     set activefg $options(-selectedforeground)
                     $widgets(optList) tag configure selected -background $activebg -foreground $activefg
 
                     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]
                         }
                         "bwidget" {
                             set w [eval ::prefs::addNewBwidgetTab $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"
     }
 
     # set default value
     set opts(-titlefont) $options(-titlefont) 
     set opts(-titlefg) $options(-titlefg) 
 
     # 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
 
     set widgets(optFrame,${ident}Title) \
         $widgets(optFrame,$ident).title
     frame $widgets(optFrame,${ident}Title) -takefocus 0
     set c $widgets(optFrame,${ident}Title).c1
 
     if { [array get opts "-title"] ne "" } {
         # create title label
 
         set xoffs 3
         set yoffs 3
         set ls [font metrics $opts(-titlefont) -linespace]
         canvas $c -height [expr $ls + $yoffs] -relief flat \
             -borderwidth 0 -takefocus 0 \
              -background [. cget -bg] \
              -insertborderwidth 0 \
              -selectborderwidth 0 \
              -selectbackground  [. cget -bg] 
         $c create text $xoffs $yoffs -tags title \
             -text $opts(-title) \
             -justify left -anchor nw \
             -font $opts(-titlefont) \
             -fill $opts(-titlefg)
         set drawSeparator 1
     }
     if { [array get opts "-titlebg"] ne "" } {
         set type [lindex $opts(-titlebg) 0]
         switch $type {
             gradient {
                 set direction  [lindex $opts(-titlebg) 1]
                 set color1 [lindex $opts(-titlebg) 2]
                 set color2 [lindex $opts(-titlebg) 3]
                 bind $c <Configure> \
                     [list ::prefs::gradient %W $direction $color1 $color2]
             }
             solid {
                 set color [lindex $opts(-titlebg) 1]
                 bind $c <Configure> \
                     [list ::prefs::solid %W $color]
 
             }
             default {
 
             }
         }
 
     }
     if { [array get opts "-titleimage"] ne "" } {
         # add image
         set xoffs 3
         set yoffs 3
         set ls [font metrics $opts(-titlefont) -linespace]
 
         # if label doesn't exist yet create one
         if { [array get opts "-title"] eq "" } {
             canvas $c -height [expr $ls + $yoffs] -takefocus 0
 
             set drawSeparator 1
         } else {
             set xoffs [expr 3 + [image width $opts(-titleimage)]]
             set yoffs 3
             set ls [font metrics $options(-titlefont) -linespace]
             set ih [image height $opts(-titleimage)] 
 
             $c move title $xoffs 0
             if { $ls < $ih } {
                 $c configure -height [expr {$ih + $yoffs}]
             } else {
                 set as [font metrics $options(-titlefont) -ascent]
                 set yoffs [expr {$ls - $as}]
             }
 
         }
         $widgets(optFrame,${ident}Title).c1 create image \
             3 $yoffs -image $opts(-titleimage) -anchor nw
     }
 
     if { $drawSeparator == 1 } {
         pack $widgets(optFrame,${ident}Title).c1 \
             -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 \
                 -tiers 3
 
             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::EnterOption --
 #
 #
 # Arguments:
 #
 #    none
 #
 # Results:
 #
 #   highlight item
 #
 # Returns:
 #
 #     empty string
 
 proc ::prefs::EnterOption { w opt } {
     upvar ::prefs::${w}::widgets widgets
     upvar ::prefs::${w}::options options
     upvar ::prefs::${w}::data data
 
     $widgets(optList) tag configure $opt \
             -background $options(-highlightbackground) \
             -foreground $options(-highlightforeground)
 }
 
 # ::prefs::LeaveOption --
 #
 #
 # Arguments:
 #
 #    none
 #
 # Results:
 #
 #   remove highlight from item
 #
 # Returns:
 #
 #     empty string
 
 proc ::prefs::LeaveOption { w opt } {
     upvar ::prefs::${w}::widgets widgets
     upvar ::prefs::${w}::options options
     upvar ::prefs::${w}::data data
 
     $widgets(optList) tag configure $opt -background {} -foreground {}
 }
 
 # ::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
     }
 
     set range [$widgets(optList) tag ranges $data(curopt)]
     set start [lindex $range 0]
     set end [lindex $range 1]
     $widgets(optList) tag remove selected $start $end
 
     pack forget $widgets(optFrame,$data(curopt))
     pack $widgets(optFrame,$opt) -expand 1 -fill both -side top
 
     set data(curopt) $opt
     set range [$widgets(optList) tag ranges $data(curopt)]
     set start [lindex $range 0]
     set end [lindex $range 1]
     $widgets(optList) tag add selected $start $end
     $widgets(optList) tag raise selected
 
     pack $widgets(optFrame,$data(curopt)) -expand 1 -fill both \
             -padx 5 -pady 5
 
 }
 
 # ::prefs::addNewBwidgetTab --
 #
 #
 # Arguments:
 #
 #    none
 #
 # Results:
 #
 #   Add Suboption as Bwidget Tab
 #
 # Returns:
 #
 #     empty string
 
 proc ::prefs::addNewBwidgetTab { w args } {
     upvar ::prefs::${w}::widgets widgets
     upvar ::prefs::${w}::options options
     upvar ::prefs::${w}::data data
 
     package require BWidget
 
     #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]
 
             NoteBook $widgets(optFrame,${idx}-tab) \
                 -font $options(-tabfont) \
                 -activebackground $bgcolor \
                 -activeforeground blue
 
             pack $widgets(optFrame,${idx}-tab) -expand 1 -fill both
         }
 
         # do the insert of the new page, return the name of the new frame
         # created
         set widgets(optFrame,$ident)\
             [$widgets(optFrame,${idx}-tab) insert end $opts(-title)\
             -text $opts(-title)]
 
         return $widgets(optFrame,$ident)
 
     } else {
         error "Unknown index $ident"
     }
 }
 
 
 
 # ::prefs::rgbs --
 #
 # calculate colors for a gradient
 #
 # This procedure was taken from the wiki.tcl.tk
 # entry 9079.
 #
 # Arguments:
 #
 #    none
 #
 # Results:
 #
 #   
 #
 # Returns:
 #
 #     list of rgb values per step
 
 proc prefs::rgbs {n c1 c2} {
 
     # Color intensities are from 0 to 65535, 2 byte colors.
     foreach {r1 g1 b1} [winfo rgb . $c1] break
     foreach {r2 g2 b2} [winfo rgb . $c2] break
 
     # Normalize intensities to 0 to 255, 1 byte colors.
     foreach el {r1 g1 b1 r2 g2 b2} {
         set $el [expr {[set $el] * 255 / 65535}].0
     }
 
     if {$n == 1} {
         set r_step 0.0 
         set g_step 0.0
         set b_step 0.0
     } else {
         set r_step [expr {($r2-$r1) / ($n-1)}]
         set g_step [expr {($g2-$g1) / ($n-1)}]
         set b_step [expr {($b2-$b1) / ($n-1)}]
 
         set steps {}
         for {set i 0} {$i < $n} {incr i} {
             set r [expr {int($r_step * $i + $r1)}]
             set g [expr {int($g_step * $i + $g1)}]
             set b [expr {int($b_step * $i + $b1)}]
             lappend steps [format "#%.2X%.2X%.2X" $r $g $b]
         }
     }
 
     return $steps
 }
 
 # ::prefs::gradient --
 #
 # This procedure was taken from the wiki.tcl.tk
 # entry 9079.
 #
 # Arguments:
 #
 #    none
 #
 # Results:
 #
 #   
 #
 # Returns:
 #
 #     list of rgb values per step
 
 proc prefs::gradient { w {type x} {c1 darkgray} {c2 #d4d0c8}} {
 
     $w delete gradient
     set width [winfo width $w]
     set height [winfo height $w]
     if {[string equal $type "x"]} {
         set n $width
         set steps [rgbs $n $c1 $c2]
         for {set i 0} {$i < $n} {incr i} {
             $w create line $i 0 $i $height -tags gradient -fill [lindex $steps $i]
         }
     } else {
         set n $height
         set steps [rgbs $n $c1 $c2]
         for {set i 0} {$i < $n} {incr i} {
             $w create line 0 $i $width $i -tags gradient -fill [lindex $steps $i]
         }
     }
     $w lower gradient
 
 }
 
 # ::prefs::solid --
 #
 #
 # Arguments:
 #
 #    none
 #
 # Results:
 #
 #   
 #
 # Returns:
 #
 #     
 
 proc prefs::solid { w {color darkgray}} {
 
     $w delete solid
     set width [winfo width $w]
     set height [winfo height $w]
     $w create rectangle 0 0 $width $height \
         -fill $color -tags solid
     $w lower solid
 }
 
 
 ##
 # some demo code
 ##
 
 proc prefsAction { w cmd } {
     puts [info level 0]
 
     destroy $w
     exit
 }
 
 prefs::prefs .p1 \
     -textbackground white \
     -command prefsAction \
     -highlightbackground peru \
     -highlightforeground gold \
     -selectedbackground bisque4 \
     -tabstyle blt
 
 image create photo fonts -data {
 R0lGODlhHgAeAMYAAAAAAAICAgQEBAoKCgsLCw0NDQ8PDxUVFSIiIiMjIzAw
 MDU1NS9UjDBVjDNYjjRYjjRYjzpdkjxfk19fX2NjY2RkZGhoaFRzoFh2o1l2
 o3Nzc1x5pUqYPUyZQGB8p06aQVOdR2eCq4GBgV+kU3iQtI6OjoSau4Wbu3mz
 b4mevp6gooi7f6ioqK+vr6OzzKm4zq270a680rG/1LnG2MrKyszMzM7OzsrU
 4tHZ5djY2NXc59Pm0N/f3+Hh4ePj49rq2Orq6ufr8e7u7u/v7/L0+PT2+fz8
 /P7+/v///wAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA
 AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA
 AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA
 AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAACH5BAEKAH8A
 LAAAAAAeAB4AAAf+gH+Cg4SFhoeIiYqLjI2Oj4cMDJCMkjKUiZIMHpiIDBcZ
 DDqdhZIwLgwpjBwcigwORX8PEkSLrEiZJLgQDDG2HLiRDDfBDBu/wYaayww4
 irfCzJInz8DCQUjZSEENESoA4ACF0MohweAlIQwvBOAUyX/khJIzuOFAJgwY
 Fe7w8oTZBIUbIghJjX6E/hkKB4CgQISDFBZi6PBPuHcJrSWiOOiivw/wDg3s
 CFEQhxEhDR0A14MkAIwmOaxIaSgBgAoPEbLi0OEHTUMiFAgIMCBcBVwcQKDY
 8XNiQSQ5wmkIpq0ROAOEwrVoqgiAABY5FxghNQEBwwIWhHBl5MMGDR4FRwIy
 CgQAOw==
 }
 
 image create photo hwfilter -data {
 R0lGODlhGgAaAKEAAAAAAP8AAP///wAAACH+FUNyZWF0ZWQgd2l0aCBUaGUg
 R0lNUAAsAAAAABoAGgAAAl6Eb4Ko6/yAErRGGWeltzm9dZm0ed9Ymot6gNb4
 sElK12EMX2uut3yPwQF9wmHwZDzukjIlwwZN/YiPgPWKuWJdHIDWmv1ipF6x
 4hsYlwzosFZ9a5/NpDhdXn8Vl44CADs=
 }
 
 # gradient  {x|y|d|c} opts
 #   x,y : color1 color2 [step offset]
 #   d(iagonal)   : color1 color2 [step offset degree]
 #   c(ircle)   : color1 color2 [step offset center]
 # solid color
 set fillOpts [list gradient x "#505050" [. cget -bg]]
 set t0 [.p1 insert end General -title "General" \
         -titlebg $fillOpts -titlefg white]
 set t1 [.p1 insert end "Fonts and Colors" -title "Fonts and Colors" \
         -titlebg $fillOpts -titlefg white -titleimage fonts]
 set fillOpts [list gradient x "SeaGreen4" [. cget -bg]]
 set t2 [.p1 insert end CANopen -title "CANopen" \
         -titlebg $fillOpts -titlefg white]
 set fillOpts [list gradient x "MediumPurple4" [. cget -bg]]
 set t3 [.p1 insert end DeviceNet -title "DeviceNet" \
         -titlebg $fillOpts -titlefg white ]
 set fillOpts [list gradient x "pink4" [. cget -bg]]
 set t4 [.p1 insert end J1939 -title "J1939" \
         -titlebg $fillOpts -titlefg white]
 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"]
 set t8 [.p1 insert end X -title "Hardware Filter" \
         -titleimage hwfilter \
         -titlefg white \
         -titlebg [list gradient x "#505050" [. cget -bg]]]
 
 foreach tab [list $t0 $t1 $t2 $t3 $t4 $t5 $t6 $t7 $t8] {
     puts $tab
     label $tab.l1 -text $tab
     pack $tab.l1 -side top
 }