([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
 }


----
How about contributing this to [tklib]?

----
[Category Package] based on [Tk] and [snit] |
[Category GUI]