Preferences Widget
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:
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
}