Version 1 of Entry Field Processing

Updated 2001-07-31 17:23:38

For a really good example of entry field processing, look at Jeff Hobbs' Entry Widget Validation Demo at http://tcl.activestate.com/community/hobbs/tcl/ .

Follow the link to Tcl Plugins, then to the validation demo.


Todd M. Helfter writes:

Larry

Here is one that I use to limit the length of an entry.

I am not sure if this is what you want. As this just removes any character typed past the length specified, this could be modified to apply any business rule you want. (handles both variables and arrays)

Todd

I use it like this

                entry $win.e$ix \
                        -width $c_len \
                        -textvariable ::app($win,$c_name)
                trace variable ::app($win,$c_name) w "limitEntry $c_len"

 #   .-------------.------------------------------------------------------.
 #  |  procedure  |  limitEntry                                          |
 #  |  purpose    |  Limit the maximum size of an entry.                 |
 #  |  date       |  (10/11/96)                                           |
 #    `-------------^------------------------------------------------------'
 proc limitEntry {args} {
        if {[llength $args] == 4} {
                set wid [lindex $args 0]
                set var [lindex $args 1]
                set idx [lindex $args 2]

                global [set var]

                if {[string length $idx] > 0} {
                        set str [lindex [array get [set var] $idx] 1]
                        if {[string length $str] > $wid} {
                                set str [string range $str 0 end-1]
                                array set [set var] [list $idx $str]
                        }
                } else {
                        set str [set [set var]]
                        if {[string length $str] > $wid} {
                                set str [string range $str 0 end-1]
                                set [set var] $str
                        }
                }
        }
 }

JH writes:

 # tkFormat --
 # This procedure attempts to format a value into a particular format string.
 #
 # Arguments:
 # format        - The format to fit
 # val           - The value to be validated
 #
 # Returns:      0 or 1 (whether it fits the format or not)
 #
 # Switches:
 # -fill ?var?   - Default values will be placed to fill format to spec
 #                 and the resulting value will be placed in variable 'var'.
 #                 It will equal {} if the match invalid
 #                 (doesn't work all that great currently)
 # -best ?var?   - 'Fixes' value to fit format, placing best correct value
 #                 in variable 'var'.  If current value is ok, the 'var'
 #                 will equal it, otherwise it removes chars from the end
 #                 until it fits the format, then adds any fixed format
 #                 chars to value.  Can be slow (recursive tkFormat op).
 # -strict       - Value must be an exact match for format (format && length)
 # --            - End of switches

 proc tkFormat {args} {
    set fill {}; set strict 0; set best {}; set result 1;
    set name [lindex [info level 0] 0]
    while {[string match {-*} [lindex $args 0]]} {
        switch -- [string index [lindex $args 0] 1] {
            b {
                set best [lindex $args 1]
                set args [lreplace $args 0 1]
            }
            f {
                set fill [lindex $args 1]
                set args [lreplace $args 0 1]
            }
            s {
                set strict 1
                set args [lreplace $args 0 0]
            }
            - {
                set args [lreplace $args 0 0]
                break
            }
            default {
                return -code error "bad $name option \"[lindex $args 0]\",\
                        must be: -best, -fill, -strict, or --"
            }
        }
    }

    if {[llength $args] != 2} {
        return -code error "wrong \# args: should be \"$name ?-best varname?\
                ?-fill varname? ?-strict? ?--? format value\""
    }
    set format [lindex $args 0]
    set val    [lindex $args 1]

    set flen [string length $format]
    set slen [string length $val]
    if {$slen > $flen} {set result 0}
    if {$strict && ($slen != $flen)} { set result 0 }

    if {$result} {
        set regform {}
        for {set i 0} {$i < $slen} {incr i} {
            set c [string index $format $i]
            if {$c == "\\"} {
                set c [string index $format [incr i]]
            } else {
                switch -- $c {
                    0   { set c {[[:digit:]]} }
                    A   { set c {[[:upper:]]} }
                    a   { set c {[[:lower:]]} }
                    W   { set c {[[:space:]]} }
                    z   { set c {[[:alpha:]]} }
                    Z   { set c {[[:alnum:]]} }
  • - + - - - ? - [ - \] - \( - \) - \{ - \} - \^ - \$ - . -
                    \\  { set c "\\$c" }
                    default {}
                }
            }
            lappend regform $c
        }
        #puts [list $regform $format $val]
        set result [regexp -- [join $regform {}] $val]
    }

    if {[string compare $fill {}]} {
        upvar $fill fvar
        if {$result} {
            set fvar $val[string range $format $i end]
        } else {
            set fvar {}
        }
    }

    if {[string compare $best {}]} {
        upvar $best bvar
        set bvar $val
        set len [string length $bvar]
        if {!$result} {
            incr len -2
            set bvar [string range $bvar 0 $len]
            # Remove characters until it's in valid format
            while {$len > 0 && ![tkFormat $format $bvar]} {
                set bvar [string range $bvar 0 [incr len -1]]
            }
            # Add back characters that are fixed
            while {($len<$flen) && ![string match \
                    {[0AaWzZ]} [string index $format [incr len]]]} {
                append bvar [string index $format $len]
            }
        } else {
            # If it's already valid, at least we can add fixed characters
            while {($len<$flen) && ![string match \
                    {[0AaWzZ]} [string index $format $len]]} {
                append bvar [string index $format $len]
                incr len
            }
        }
    }

    return $result

}

Then do something like:

    label .l4 -text "A phone number formatted widget:\
            \n(###) ###-####"
    entry .e4 -vcmd {tkFormat -best tmp {(000) 000-0000} %P} -validate key\
            -invcmd {
        bell
        %W delete 0 end
        %W insert 0 $tmp
        after idle %W configure -validate key
    }






Mentry [L1 ] is hard to beat for these purposes. It's pure Tcl.