Based on the units converter I posted at unit converter, here's a measurement widget. As always, feedback welcome.
--[mailto:[email protected]]
# measurement.tcl --
#
# An entry widget which understands measurement units
#
#
# Copyright 2000 Pinebush Technologies Inc.
#
#
# Exported procs:
# measurement::measurement - Create a measurement widget
#
# A measurement widget is an enhanced entry widget that makes it
# easier to get dimensions from user input.
#
# It supports separate display and reporting units so the user's
# assumptions and the system's assuptions need not be the same. For
# example, a measurement widget could be configure to assume the user
# meant centimeters but that the system required inches. If the user
# typed "3.81" into the widget, the textvariable associated with the
# widget would have a value of "1.5".
#
# The user may enter explicit unit suffixes to override the
# assumption. Continuing the previous example, if the user typed
# "54pt" into the widget, the textvariable would be set to ".75"
#
#
# The measurement widget behaves like an entry except for the addition
# of new options and subcommands as follows.
#
# Measurement widgets recognize the following additional options:
#
# -units : Specifies the implied units for the value stored in the
# widget's textvariable and returned by the widget's get
# command. The value of this option may be any unit string
# recognized by the units package.
#
# -displayunits : Specifies the default units for the text displayed
# in the widget. If the user does not type a unit suffix in
# the entry, these units are assumed. The value of this option
# may be any unit string recognized by the units package. If
# not specified, displayunits defaults to the same value as units.
#
# -invalidforeground : Specifies a text color to use when the
# contents of the widget are not a valid measurement. For
# example, when the unit suffix is incomplete such as "2.54c"
# on the way to typing "2.54cm". If not specified,
# invalidforeground defaults to red.
#
# -invalidbackground : Specifies a background color to use when
# the contents of the widget are not a valid measurement. If
# not specified, invalidbackground defaults to the normal
# background.
#
# Measurement widgets respond to the following additional or changed
# commands:
#
# $m get ?export? - Returns the value exported by the widget (the
# same value that would be in the textvariable if one is
# assigned). Raises an error if the text in the widget does
# not represent a valid measurement.
#
# $m get display - Returns the text shown to the user.
#
# $m isvalid - Returns 1 if [$m get export] would raise an error,
# 0 otherwise.
#
# Also, trying to set the measurement widget's textvariable to a value
# that does not represent a valid measurement raises an error.
#
#
# WUZ - doesn't work with option database. Yet.
#
# Example:
# See measurement::Test at the bottom of this file.
#
#
# Global data:
# None.
#
#-----------------------------------------------------------------------
# package require units
source units.tcl
namespace eval ::measurement {
namespace export \
meas \
# "global" array(s)
variable Options
# Some defaults
set Options(-units) ""
set Options(-invalidforeground) red
}
#=======================================================================
# Public procs
#=======================================================================
# measurement::measurement --
#
# Create a new widget
#
# Arguments:
#
# Results:
#
proc ::measurement::measurement { w args } {
variable Options
# Create a namespace for the widget
namespace eval $w {}
# The hull frame
frame $w -class Meas
# Rename the widget command for the outer frame into the namespace
# We never really use this command again.
rename $w measurement::${w}::frame
# Make sure that closing this window does the right things.
#
# We bind to the Meas class rather than to the window because
# the caller might bind to the window's destroy event; the class is
# *ours*, the window path is "public"
bind Meas <Destroy> [namespace code [list Done %W CLOSE]]
#========================================
# Create the widget
set e [entry $w.entry]
pack $e -expand 1 -fill both
# Create a new widget command
proc ::$w [info args measurement::WidgetProc] \
"set w $w;[info body measurement::WidgetProc]"
upvar ::measurement::${w}::options options
set options(-units) ""
set options(-invalidforeground) $Options(-invalidforeground)
set options(-invalidbackground) [$e cget -background]
set options(-validfg) [$e cget -foreground]
set options(-validbg) [$e cget -background]
$w.entry configure -textvariable ::measurement::${w}::data(internalValue)
trace variable ::measurement::${w}::data(internalValue) w \
[namespace code [list UpdateExternalVar $w]]
# Pressing <Return> reformats to add units
bind $e <Return> [namespace code [list NormalizeValue $w]]
# Configure the widget
if {[llength $args]} {
eval [list $w configure] $args
}
return $w
}
# measurement::measurement
#
#=======================================================================
# Private procs only below this line
#=======================================================================
# measurement::Done --
#
# Clean up when the user's done with the option tree
#
# Arguments:
#
# Results:
# Returns the number of changes made.
#
proc ::measurement::Done { w why } {
variable meas
switch -- $why {
OK {
}
CLOSE -
CANCEL {
namespace delete measurement::$w
}
}
}
# measurement::Done
#
#-----------------------------------------------------------------------
# measurement::WidgetProc --
#
# The widget proc for a measurement entry; processes widget commands.
#
# Arguments:
#
# Results:
#
proc ::measurement::WidgetProc { cmd args } {
switch -- $cmd {
cget {
set result [measurement::Configure $w $args]
lindex $result 4
}
configure {
eval [list measurement::Configure $w] $args
}
get {
eval [list measurement::Get $w] $args
}
isvalid {
eval [list measurement::IsValid $w] $args
}
default {
# Pass the command down to the embedded entry
eval [list $w.entry $cmd] $args
}
}
}
# measurement::WidgetProc
#
#-----------------------------------------------------------------------
# measurement::Configure --
#
# Handle configure sub-command for widget.
#
# Arguments:
# w - Path to the widget
# args - Arguments to command
#
# Results:
#
proc ::measurement::Configure { w args} {
upvar ::measurement::${w}::options options
# If 0 args, get the full list from the base proc then post-process
# wrapped commands
# If 1 arg, handle wrapped commands directly, ask base proc for others
# If odd number of arguments, let the base proc generat the error
# Otherwise, set options, checking for the ones we have to handle specially
if {[llength $args] == 0} {
# List all the entry's options
set result [eval [list $w.entry configure] $args]
# Remove entry's textvariable, we'll add our own
set index [lsearch -glob $result "-textvariable*"]
set result [lreplace $result $index $index]
# Add our custom options, including textvariable
foreach opt {
-displayunits
-invalidforeground
-invalidbackground
-textvariable
-units
} {
lappend result [Configure $w $opt]
}
# We added some things out of order at the end, so fix it up.
lsort -index 0 -dictionary $result
} elseif {[llength $args] == 1 } {
# Get the value for a single option
set option [lindex $args 0]
switch -- $option {
-units {
set result [list -units units Units \
"" $options($option)]
}
-displayunits {
set result [list -displayunits displayUnits DisplayUnits \
"" $options($option)]
}
-invalidforeground {
set result [list -invalidforeground invalidForeground \
InvalidForeground "" \
$options($option)]
}
-invalidbackground {
set result [list -invalidbackground invalidBackground \
InvalidBackground "" \
$options($option)]
}
-textvariable {
# Get the name, defaults, etc. from entry
set result [eval [list $w.entry configure] $args]
# Put the real user's value in, not our wrapper
if {[info exists options(-textvariable)]} {
set textVar $options(-textvariable)
} else {
set textVar {}
}
lreplace $result 4 4 $textVar
}
default {
eval [list $w.entry configure] $args
}
}
} elseif {[llength $args]%2 == 1} {
# Odd number > 1, let the entry complain
eval [list $w.entry configure] $args
} else {
# Even number, set a bunch of option values
array set opt $args
foreach option [array names opt] {
switch -- $option {
-units -
-displayunits {
set units $opt($option)
# An empty string means no conversion
# Normalize any non-empty unit string
if {[string length $units]} {
set units [units::normalize $units]
}
set options($option) $units
unset opt($option)
if {[string equal $option -units]} {
UpdateExternalVar $w
} else {
UpdateInternalVar $w
}
}
-invalidforeground -
-invalidbackground {
set options($option) $opt($option)
unset opt($option)
}
-textvariable {
set varName "::$opt($option)"
# Remember what the user wanted.
set options(-textvariable) $varName
# Put a read trace on the user's variable
# to raise an error when reading a variable from
# an inconsistent measurement.
trace variable $varName r \
[namespace code [list ValidateRead $w]]
# Put a write trace on the user's variable to
# update the widget internal variable
trace variable $varName w \
[namespace code [list UpdateInternalVar $w]]
# Set measurement from user var
if {[info exists $varName]} {
UpdateInternalVar $w
}
# We always have our own text variable set so just
# unset this.
unset opt($option)
}
}
}
# foreach
if {[array size opt] != 0} {
eval [list $w.entry configure] [array get opt]
}
}
# if
}
# measurement::Configure
#
#-----------------------------------------------------------------------
# measurement::UpdateExternalVar --
#
# Update the external variable when the user modifies the
# measurement.
#
# Arguments:
#
# Results:
#
proc ::measurement::UpdateExternalVar { w args } {
upvar ::measurement::${w}::options options
upvar ::measurement::${w}::data data
if {[info exists measurement::InUpdate]} {
return
}
set measurement::InUpdate 1
set units $options(-units)
if {[info exists options(-displayunits)]} {
set displayunits $options(-displayunits)
} else {
set displayunits $options(-units)
}
set valueIn $data(internalValue)
if {[string length $valueIn] == 0} {
set valueOut $valueIn
} else {
if {[catch {units::parse $valueIn} meaIn]} {
$w.entry configure -foreground $options(-invalidforeground)
$w.entry configure -background $options(-invalidbackground)
unset measurement::InUpdate
return
}
if {[llength $meaIn] == 1} {
lappend meaIn $displayunits
}
if {[catch {units::convert $meaIn $units} meaOut]} {
$w.entry configure -foreground $options(-invalidforeground)
$w.entry configure -background $options(-invalidbackground)
unset measurement::InUpdate
return
}
set valueOut [lindex $meaOut 0]
}
$w.entry configure \
-foreground $options(-validfg) \
-background $options(-validbg)
# Set the user's variable, if there is one
if {[info exists options(-textvariable)]} {
set $options(-textvariable) $valueOut
}
unset measurement::InUpdate
}
# measurement::UpdateExternalVar
#
#-----------------------------------------------------------------------
# measurement::UpdateInternalVar --
#
# Update the internal variable which is tied to the text the user
# sees.
#
# Arguments:
#
# Results:
#
proc ::measurement::UpdateInternalVar { w args } {
upvar ::measurement::${w}::options options
upvar ::measurement::${w}::data data
if {[info exists measurement::InUpdate]} {
return
}
set measurement::InUpdate 1
set units $options(-units)
# Get the variable name
set varName $options(-textvariable)
if {[info exists $varName]} {
# Get the external value
set valueIn [set ::$varName]
if {[string length $valueIn]} {
if {[catch {units::parse $valueIn} meaIn]} {
# Restore the last, valid external value.
set $varName $data(externalValue)
# Clear our semaphore
unset measurement::InUpdate
# Raise an error.
error "'$valueIn' cannot be parsed for units conversion"
}
# Now that it's valid, save it for later
set data(externalValue) $valueIn
# If there was no unit in the external variable, add one.
if {[llength $meaIn] == 1} {
lappend meaIn $units
}
# Update the measurement
set data(internalValue) [join $meaIn ""]
NormalizeValue $w
}
}
unset measurement::InUpdate
}
# measurement::UpdateInternalVar
#
#-----------------------------------------------------------------------
# measurement::NormalizeValue --
#
# Normalize the value displayed, include units, etc.
#
# Arguments:
#
# Results:
#
proc ::measurement::NormalizeValue { w } {
upvar ::measurement::${w}::options options
upvar ::measurement::${w}::data data
# Get the default units for this measurement
if {[info exists options(-displayunits)]} {
set units $options(-displayunits)
} else {
set units $options(-units)
}
# Get the current value
set valueIn $data(internalValue)
# If we can't parse the current value, give up.
if { [catch {units::parse $valueIn} meaIn] } {
return
}
# If there aren't units in the current value, use the default
if {[llength $meaIn] == 1} {
lappend meaIn $units
}
# Convert to expected units
set meaOut [units::convert $meaIn $units]
set valueOut [join $meaOut ""]
# Update the display with the normalized value.
set data(internalValue) $valueOut
}
# measurement::NormalizeValue
#
#-----------------------------------------------------------------------
# measurement::Get --
#
# Get the value of the widget
#
# Arguments:
# w - The measurement widget
# what - What to return, "export" (the textvariable value) or
# "display" (what the user typed and sees). export is the
# default.
#
# Results:
# Returns the value of the widget.
#
proc measurement::Get { w {what "export"} } {
upvar ::measurement::${w}::data data
switch -- $what {
display {
set result $data(internalValue)
}
export {
# Raise an error if inconsistent
set result foo
}
default {
error "Invalid option, '$what'; must be display or export"
}
}
return $result
}
# measurement::Get
#
#-----------------------------------------------------------------------
# measurement::IsValid --
#
# Make sure that the text typed by the user is valid and that the
# value reported by [$m get export] and [$m get display] are
# consistent.
#
# Arguments:
# w - The measurement widget.
#
# Results:
# Returns 1 if the text is valid and the internal and external
# values are consistent, 0 otherwise.
#
proc measurement::IsValid { w } {
upvar ::measurement::${w}::data data
# If we can't parse the current value, it's invalid
if {[catch {units::parse $data(internalValue)}]} {
return 0
} else {
return 1
}
}
# measurement::IsValid
#
#-----------------------------------------------------------------------
# measurement::ValidateRead --
#
# <short description>
#
# Arguments:
#
# Results:
#
proc measurement::ValidateRead { w args } {
upvar ::measurement::${w}::data data
if { ! [IsValid $w] } {
error "'$data(internalValue)' cannot be parsed for units conversion"
}
}
# measurement::ValidateRead
#
#-----------------------------------------------------------------------
# measurement::Test --
#
# <short description>
#
# Arguments:
#
# Results:
#
proc ::measurement::Test { {w ""} } {
# Just in case.
destroy $w.test
set f [frame $w.test]
pack $f
set ::edit cm
set ::show cm
frame $f.top
pack $f.top -side top -expand 1 -fill both -padx 2m -pady 2m
label $f.top.label -text "Input:"
pack $f.top.label -side left
measurement $f.top.entry \
-units $::edit \
-displayunits $::show \
-textvariable foo
$f.top.entry configure -invalidforeground red
pack $f.top.entry -side left -expand 1 -fill x
frame $f.edit
pack $f.edit -side top -expand 1 -fill both -padx 2m -pady 2m
label $f.edit.label -text "Edit in:" -width 10
pack $f.edit.label -side left
foreach unit {pt cm in ft} {
radiobutton $f.edit.$unit -text $unit -width 3 \
-command [list $f.top.entry configure -displayunits $unit] \
-variable edit -value $unit
pack $f.edit.$unit -side left
}
frame $f.show
pack $f.show -side top -expand 1 -fill both -padx 2m -pady 2m
label $f.show.label -text "Export in:" -width 10
pack $f.show.label -side left
foreach unit {pt cm in ft} {
radiobutton $f.show.$unit -text $unit -width 3 \
-command [list $f.top.entry configure -units $unit] \
-variable show -value $unit
pack $f.show.$unit -side left
}
frame $f.btm
pack $f.btm -side top -expand 1 -fill both -padx 2m -pady 2m
label $f.btm.label -textvariable show
pack $f.btm.label -side left
entry $f.btm.entry -textvariable foo
pack $f.btm.entry -side left -expand 1 -fill x
}
# measurement::Test
#
# Make it easier to create measurement widgets
namespace import measurement::measurement
------
ARR: Hi, I like to test this out. Where can I find the units.tcl file? I tried 'package req units' in my ActiveTcl 8.5 but the proc 'units::normalize' is not there.
------