# 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 [info script]]} {
     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
 }