4 ## self-validating entry widget
6 ## Copyright 1997 Jeffrey Hobbs, CADIX International
9 ##------------------------------------------------------------------------
14 ## Implements a self-validating entry widget
17 ## ventry <widget> ?options?
23 ## RETURNS: the widget name
27 ##------------------------------------------------------------------------
29 ## Example use at end of file
33 ########################################################################
34 ############################# Ventry ###############################
35 ########################################################################
43 -borderwidth {borderWidth BorderWidth 0}
44 -invalidcmd {invalidCmd InvalidCmd bell}
45 -labeltext {labelText LabelText {}}
46 -labelwidth {labelWidth Width 0}
47 -labelanchor {ALIAS label -anchor labelAnchor Anchor}
48 -labelfont {ALIAS label -font labelFont Font}
49 -labelforeground {ALIAS label -foreground labelForeground Foreground}
50 -relief {relief Relief flat}
52 -vcmd {validateCmd ValidateCmd {}}
53 -validate {validate Validate none}
54 -textvariable {textVariable TextVariable {}}
57 # Create this to make sure there are registered in auto_mkindex
58 # these must come before the [widget create ...]
63 ;proc Ventry:construct {w args} {
68 grid $data(label) $data(entry) -in $w -sticky ns
69 grid configure $data(entry) -sticky news
70 grid columnconfig $w 1 -weight 1
71 grid rowconfig $w 0 -weight 1
72 grid remove $data(label)
74 bind $data(entry) <FocusIn> [list Ventry:focus $w in]
75 bind $data(entry) <FocusOut> [list Ventry:focus $w out]
78 ;proc Ventry:configure {w args} {
80 set truth {^(1|yes|true|on)$}
81 foreach {key val} $args {
83 -borderwidth - -relief { .$w configure $key $val }
84 -labelanchor { $data(label) configure -anchor $val }
85 -labelfont { $data(label) configure -font $val }
86 -labelforeground { $data(label) configure -foreground $val }
88 $data(label) configure -text $val
89 if {[string compare {} $val]} {
92 grid remove $data(label)
95 -labelwidth { $data(label) configure -width $val }
97 if {![regexp {^(focus|focusin|focusout|all|none|key)$} $val]} {
98 return -code error "Invalid validation type \"$val\""
101 -textvariable { $data(basecmd) configure -textvariable $val }
107 ;proc Ventry_insert {w index string} {
110 if {[regexp {^(all|key)$} $data(-validate)]} {
111 set index [$data(basecmd) index $index]
112 set cur [$data(basecmd) get]
113 set new [string range $cur 0 [expr $index-1]]$string[string range $cur $index end]
114 if {[catch {Ventry:validate $w $string $new $index insert} err]} {
118 return [uplevel [list $data(basecmd) insert $index $string]]
121 ;proc Ventry_delete {w first {last {}}} {
124 if {[regexp {^(all|key)$} $data(-validate)]} {
125 set first [$data(basecmd) index $first]
126 if {[string match {} $last]} {
127 set last [expr $first+1]
129 set last [$data(basecmd) index $last]
131 set cur [$data(basecmd) get]
132 set new [string range $cur 0 [expr $first-1]][string range $cur $last end]
133 if {[catch {Ventry:validate $w [string range $cur $first \
134 [expr $last-1]] $new $first delete} err]} {
138 return [uplevel [list $data(basecmd) delete $first] $last]
141 ;proc Ventry_validate {w} {
144 set old $data(-validate)
145 set data(-validate) all
146 set code [catch {Ventry:validate $w {} [$data(basecmd) get] \
147 [$data(basecmd) index insert] validate} err]
148 set data(-validate) $old
149 return [expr {$code?0:1}]
152 ;proc Ventry:focus {w which} {
155 if {[regexp "^(all|focus($which)?)\$" $data(-validate)]} {
156 catch {Ventry:validate $w {} [$data(basecmd) get] \
157 [$data(basecmd) index insert] focus$which}
161 ;proc Ventry:validate {w str new index type} {
164 if {[string match {} $data(-vcmd)] || \
165 [string match none $data(-validate)]} {
168 set data(flags) VALIDATING
170 set cmd [Ventry:substitute $w $data(-vcmd) $str $new $index $type]
172 set code [catch {uplevel \#0 $cmd} result]
173 if {$code != 0 && $code != 2} {
175 append errorInfo "\n\t(in $w validation command)"
179 set val [regexp {^(1|yes|true|on)$} $result]
180 if $val { set code 0 } else { set code 3 }
184 # If e->validate has become VALIDATE_NONE during the validation,
185 # it means that a loop condition almost occured. Do not allow
186 # this validation result to finish.
187 if {[string match none $data(-validate)] || \
188 [string match VALIDATE_VAR $data(flags)]} {
191 # If validate will return ERROR, then disallow further validations
192 # Otherwise, if it didn't accept the new string (returned TCL_BREAK)
193 # then eval the invalidCmd (if it's set)
197 if {[string compare {} $data(-invalidcmd)]} {
198 set cmd [Ventry:substitute $w $data(-invalidcmd) \
199 $str $new $index $type]
200 if {[catch {uplevel \#0 $cmd} result]} {
202 append errorInfo "\n\t(in $w validation command)"
205 set data(-validate) none
209 set data(-validate) none
213 return -code $code $result
216 ;proc Ventry:substitute {w cmd change newstr index type} {
220 set i [string first % $cmd]
221 if {$i < 0} { return $old }
222 set new [string range $cmd 0 [incr i -1]]
224 set c [string index $cmd [incr i 2]]
226 d { append new $type }
227 i { append new $index }
228 P { append new [list $newstr] }
229 s { append new [list [$data(basecmd) get]] }
230 S { append new [list $change] }
231 v { append new $data(-validate) }
232 W { append new [list $w] }
233 {} { append new %; return $new }
234 default { append new [list $c] }
236 set cmd [string range $cmd [incr i] end]
237 set i [string first % $cmd]
238 if {$i < 0} { return $new$cmd }
239 append new [string range $cmd 0 [incr i -1]]