([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. :-)
----
([Peter Spjuth] - 15 Jun 2004): Updated the code here to my latest.
Mainly bugfixes and some behavioural changes.
----

 # 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 require Tk
 package provide MappingEntry 0.4.3
 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
     # Experimental
     option -ignorechars ""
 
     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]
 
         # Make sure the displayed value is "canonical" when leaving the
         # entry.
         bind $win <FocusOut> [mymethod UpdateDisp]
     }
 
     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 ""
         }
         if {$options(-minvalue) != "" && $TheVariable == ""} {
             set TheVariable $options(-minvalue)
         }
         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
         # Avoid upvar in here to not confuse any traces on the
         # -textvariable.
 
         if {$options(-tovar) == ""} {
             # There is no mapping function. Use it directly.
             uplevel \#0 [list set $options(-textvariable) $dispvar]
             return
         }
 
         set cmd $options(-tovar)
         set old [uplevel \#0 [list set $options(-textvariable)]]
         lappend cmd $old $dispvar
         if {[catch {uplevel \#0 $cmd} result]} {
             set result ""
         }
         set busy 1
         uplevel \#0 [list set $options(-textvariable) $result]
         set busy 0
         after idle [mymethod CheckInsert]
     }
 
     # Update the displayed variable when the textvariable changes
     method UpdateDisp {args} {
         if {$busy} return
 
         set value [uplevel \#0 [list set $options(-textvariable)]]
         if {$options(-fromvar) == ""} {
             set dispvar $value
             return
         }
 
         set cmd $options(-fromvar)
         lappend cmd $value
         if {[catch {uplevel \#0 $cmd} result]} {
             set result ""
         }
         set busy 1
         set dispvar $result
         set busy 0
         after idle [mymethod CheckInsert]
     }
 
     # Overload icursor to track cursor movements
     method icursor {index} {
         $hull icursor $index
         after idle [mymethod CheckInsert]
     }
 
     # Check the insertion cursor. If the entry is full, change to
     # overwrite behaviour
     method CheckInsert {} {
         if {$options(-maxlength) == ""} return
         if {[string length $dispvar] < $options(-maxlength)} return
         if {[$hull selection present]} return
         if {[focus] != $win} return
         # Select the char at the cursor to get overwrite behaviour
         set from [$hull index insert]
         set to [expr {$from + 1}]
         if {$options(-ignorechars) != ""} {
             set char [string index [$hull get] $from]
             if {[string first $char $options(-ignorechars)] >= 0} {
                 $win icursor $to
                 return
             }
         }
         $hull selection range $from $to
     }
 
     # 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 {
                 set old [uplevel \#0 [list set $options(-textvariable)]]
                 set cmd $options(-tovar)
                 lappend cmd $old $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::MappingEntry $self]
         $self configurelist $args
         $hull configure -ignorechars "_"
     }
 
     # 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::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::MappingEntry $self -minvalue 0]
         $self configurelist $args
     }
 
     # Convert from decimal to "pure" integer
     proc dec2dec {olddec dec} {
         if {$dec eq ""} {return 0}
         scan $dec %ld
     }
 
     # Convert from valid integer to "pure" integer
     proc dec2dec2 {dec} {
         if {$dec eq ""} {return 0}
         expr {$dec}
     }
 
     onconfigure -digits {value} {
         set options(-digits) $value
         $hull configure -tovar [codename dec2dec] \
                 -fromvar [codename dec2dec2] \
                 -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
 if {[string equal $argv0 mappingentry.tcl]} {
     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::HexEntry
     namespace import -force MappingEntry::BinEntry
     namespace import -force MappingEntry::DecEntry
     proc testa {} {
         option add *Entry.font "courier 10"
 
         # A test that creates multiple views of the same variable.
         wm deiconify .
         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
     }
     testa
 }

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

I wouldn't mind putting it there but I'm not currently inclined
to spend the effort to make it happen.
----
[Category Package] based on [Tk] and [snit] |
[Category GUI]