(Peter Spjuth - 4 Dec 2003): I needed an entry widget for entering hexadecimal values and I wanted the result to be stored as a normal decimal integer in a variable for convenient usage.
I was also curious about trying snit which led to the creation of this little package.
The MappingEntry widget lets you set up mapping functions to do any transform between the entry's display and its textvariable. The included HexEntry, DecEntry and BinEntry uses it to make more specialised widgets.
Finally, I'm so amazed by the simplicity of snit that I think that I must have missed something. :-)
# MappingEntry
# Copyright (c) 2003, Peter Spjuth.
# Permission to use this is granted under the terms of the standard
# Tcl license agreement.
package require snit
package provide MappingEntry 0.1
namespace eval MappingEntry {
namespace export MappingEntry BinEntry HexEntry DecEntry
}
#----------------------------------------------------------------------
#
# MappingEntry::MappingEntry --
#
# Create an entry widget that supports setting up mapping
# functions between the edit text and the textvariable.
# It also supports some validation.
#
# Options:
# -fromvar A partial command. The textvariable's value is added
# as last argument to the command and the result is
# displayed in the entry field.
# -tovar A partial command. The textvariable's contents and the
# entry's contents is added as last arguments to the
# command and the result is stored in the textvariable.
# -maxlength Limit the entry's contents to this maximum length.
# -maxvalue Limit the textvariable to this maximum value.
# -minvalue Limit the textvariable to this minimum value.
# -validre A regular expression that the entry's contents must
# match.
#
# Note:
# The partial commands must be valid lists and no substitutions
# will take place before the command is called.
#
# Max/minvalues are checked using expr's < and >, so they can be
# used for integers, reals or strings.
#
#----------------------------------------------------------------------
::snit::widgetadaptor MappingEntry::MappingEntry {
# The variable holding the value displayed in the entry.
variable dispvar ""
# A flag to avoid race conditions
variable busy 0
# Mapping options
option -fromvar
option -tovar
option -textvariable
# Validation options
option -maxlength
option -maxvalue
option -minvalue
option -validre
constructor {args} {
installhull [entry $self -textvariable [varname dispvar]]
$self configurelist $args
$hull configure -validate key -vcmd [mymethod Validate %d %P]
# Set up a trace on the entry's variable
# This does not need the same special handling as the other
# trace since it can't be changed and it will be destroyed
# if the widget is destroyed.
trace add variable [varname dispvar] write [mymethod UpdateVar]
}
destructor {
$self RemoveTrace
}
onconfigure -textvariable {value} {
$self RemoveTrace
set options(-textvariable) $value
$self CreateTrace
}
# Remove variable trace
method RemoveTrace {} {
if {$options(-textvariable) == ""} return
upvar \#0 $options(-textvariable) TheVariable
trace remove variable TheVariable write [mymethod UpdateDisp]
}
# Set up a trace on the -textvariable to keep the entry updated.
method CreateTrace {} {
if {$options(-textvariable) == ""} return
upvar \#0 $options(-textvariable) TheVariable
if {![info exists TheVariable]} {
set TheVariable ""
}
after idle [mymethod UpdateDisp]
trace add variable TheVariable write [mymethod UpdateDisp]
}
# Update the textvariable when the displayed variable changes
method UpdateVar {args} {
if {$busy} return
if {$options(-textvariable) == ""} return
upvar \#0 $options(-textvariable) TheVariable
if {$options(-tovar) == ""} {
# There is no mapping function. Use it directly.
set TheVariable $dispvar
return
}
set cmd $options(-tovar)
lappend cmd $TheVariable $dispvar
if {[catch {uplevel \#0 $cmd} result]} {
set result ""
}
set busy 1
set TheVariable $result
set busy 0
}
# Update the displayed variable when the textvariable changes
method UpdateDisp {args} {
if {$busy} return
upvar \#0 $options(-textvariable) TheVariable
if {$options(-fromvar) == ""} {
set dispvar $TheVariable
return
}
set cmd $options(-fromvar)
lappend cmd $TheVariable
if {[catch {uplevel \#0 $cmd} result]} {
set result ""
}
set busy 1
set dispvar $result
set busy 0
}
# Apply validation options
# If any error occurs, the change is denied
method Validate {access new} {
if {[catch {$self DoValidate $access $new} result]} {
after idle [list bgerror $result]
return 0
}
return $result
}
# Do the actual validation
method DoValidate {access new} {
# Accept textvariable changes
if {$access == -1} {
return 1
}
# Check maxlength if specified and if it is not a delete operation
if {$options(-maxlength) != "" && $access == 1} {
if {[string length $new] > $options(-maxlength)} {
return 0
}
}
# Check the RegExp if specified
if {$options(-validre) != ""} {
if {![regexp $options(-validre) $new]} {
return 0
}
}
# Check min/maxvalue
if {$options(-minvalue) != "" || $options(-maxvalue) != ""} {
# Min/max is checked against the textvariable so we must
# first apply the mapping function.
if {$options(-tovar) == ""} {
set value $dispvar
} else {
upvar \#0 $options(-textvariable) TheVariable
set cmd $options(-tovar)
lappend cmd $TheVariable $new
if {[catch {uplevel \#0 $cmd} value]} {
set value 0
}
}
if {$options(-minvalue) != ""} {
if {$value < $options(-minvalue)} {
return 0
}
}
if {$options(-maxvalue) != ""} {
if {$value > $options(-maxvalue)} {
return 0
}
}
}
return 1
}
# Pass all other methods and options to the real entry widget, so
# that the remaining behavior is as expected.
delegate method * to hull
delegate option * to hull
}
#----------------------------------------------------------------------
#
# MappingEntry::BinEntry --
#
# Create an entry widget for entering binary values.
# A decimal value is stored in the textvariable.
#
# Options:
# -digits : Number of binary digits
# -shift : If specified, the entry will only edit a few bits
# of the value. A -shift of 0 means that the least
# significant bits are edited.
#
# Note:
# The displayed binary may contain underscores that will be
# ignored. When generated, the binary will have an underscore
# for every four binary digits.
#
#----------------------------------------------------------------------
::snit::widgetadaptor MappingEntry::BinEntry {
option -digits 8
option -shift {}
constructor {args} {
installhull [MappingEntry $self]
$self configurelist $args
}
# Decimal to binary converter
method dec2bin {width dec} {
if {$dec == ""} {return ""}
if {$options(-shift) != ""} {
set dec [expr {$dec >> $options(-shift)}]
set dec [expr {$dec & ((1 << $options(-digits)) - 1)}]
}
binary scan [binary format W $dec] B* bin
set bin [format "%0*s" $width [string trimleft $bin 0]]
# Add underscore for each fourth binary digit
regsub -all {\d(?=(\d{4})+$)} $bin {\0_} bin
return $bin
}
# Binary to decimal converter
method bin2dec {olddec bin} {
regsub -all "_" $bin "" bin
binary scan [binary format B* [format %064s $bin]] W dec
if {$options(-shift) != ""} {
set mask [expr {((1 << $options(-digits)) - 1) << $options(-shift)}]
set dec [expr {$dec << $options(-shift)}]
set dec [expr {($olddec & ~$mask) | $dec}]
}
return $dec
}
onconfigure -digits {value} {
set options(-digits) $value
set width [expr {$value + (($value + 3) / 4 - 1)}]
# An RE that maximizes the number of digits regardless of
# any underscores in the string.
set re [string map [list "%" $value] {^([01]_?){0,%}$}]
$hull configure -tovar [mymethod bin2dec] \
-fromvar [mymethod dec2bin $value] \
-width $width -maxlength $width -validre $re
}
# Pass all other methods and options to the real entry widget, so
# that the remaining behavior is as expected.
delegate method * to hull
delegate option * to hull
}
#----------------------------------------------------------------------
#
# MappingEntry::HexEntry --
#
# Create an entry widget for entering hexadecimal values.
# A decimal value is stored in the textvariable.
#
# Options:
# -digits : Number of hexadecimal digits
#
#----------------------------------------------------------------------
::snit::widgetadaptor MappingEntry::HexEntry {
option -digits 2
constructor {args} {
installhull [MappingEntry $self]
$self configurelist $args
}
# Decimal to hex converter
method dec2hex {width dec} {
if {$dec == ""} {return ""}
return [format "%0*lX" $width $dec]
}
# Hexadecimal to decimal converter
method hex2dec {olddec hex} {
set dec 0
scan $hex %lx dec
return $dec
}
onconfigure -digits {value} {
set options(-digits) $value
$hull configure -tovar [mymethod hex2dec] \
-fromvar [mymethod dec2hex $value] \
-width $value -maxlength $value \
-validre {^[0-9a-fA-F]*$}
}
# Pass all other methods and options to the real entry widget, so
# that the remaining behavior is as expected.
delegate method * to hull
delegate option * to hull
}
#----------------------------------------------------------------------
#
# MappingEntry::DecEntry --
#
# Create an entry widget for entering decimal values.
#
# Options:
# -digits : Number of digits
#
#----------------------------------------------------------------------
::snit::widgetadaptor MappingEntry::DecEntry {
option -digits 3
constructor {args} {
installhull [MappingEntry $self]
$self configurelist $args
}
# Convert from decimal to "pure" decimal.
proc dec2dec {olddec dec} {
scan $dec %ld
}
onconfigure -digits {value} {
set options(-digits) $value
$hull configure -tovar [codename dec2dec] \
-width $value -maxlength $value \
-validre {^\d*$}
}
# Pass all other methods and options to the real entry widget, so
# that the remaining behavior is as expected.
delegate method * to hull
delegate option * to hull
}
# Testing
catch {console show ; console eval {focus .console}}
set thisscript [file join [pwd] [info script]]
proc _rs {} {
uplevel #0 source \$thisscript
eval destroy [winfo children .]
}
namespace import -force MappingEntry::*
proc testa {} {
option add *Entry.font "courier 10"
# A test that creates multiple views of the same variable.
wm de .
eval destroy [winfo children .]
if {![info exists ::miffo]} {set ::miffo 4711}
HexEntry .eh -textvariable miffo -digits 9 -maxvalue 0x3ffffffff
BinEntry .eb -textvariable miffo -digits 34 -maxvalue 0x3ffffffff
DecEntry .ed -textvariable miffo -digits 11 -maxvalue 0x3ffffffff
BinEntry .ex1 -textvariable miffo -digits 6 -shift 0
BinEntry .ex2 -textvariable miffo -digits 6 -shift 6
BinEntry .ex3 -textvariable miffo -digits 6 -shift 12
BinEntry .ex4 -textvariable miffo -digits 6 -shift 18
BinEntry .ex5 -textvariable miffo -digits 6 -shift 24
BinEntry .ex6 -textvariable miffo -digits 4 -shift 30
label .l1 -text "A 34 bit number"
label .l2 -text "As Hex"
label .l3 -text "As Dec"
label .l4 -text "As Fields"
lower [frame .f]
pack .ex1 .ex2 .ex3 .ex4 .ex5 .ex6 -in .f -side right -padx 2
pack .l4 -in .f -side left
grid .l1 - - - -sticky w
grid .eb - - - - -sticky w
grid .l2 .eh .l3 .ed -sticky w
grid .f - - - - -sticky w
grid columnconfigure . 4 -weight 1
}