tcl/ventry.tcl

   1 ##
   2 ## ventry.tcl
   3 ##
   4 ## self-validating entry widget
   5 ##
   6 ## Copyright 1997 Jeffrey Hobbs, CADIX International
   7 ##
   8
   9 ##------------------------------------------------------------------------
  10 ## PROCEDURE
  11 ##      ventry
  12 ##
  13 ## DESCRIPTION
  14 ##      Implements a self-validating entry widget
  15 ##
  16 ## ARGUMENTS
  17 ##      ventry <widget> ?options?
  18 ##
  19 ## OPTIONS
  20 ##
  21 ##
  22 ##
  23 ## RETURNS: the widget name
  24 ##
  25 ## BINDINGS:
  26 ##
  27 ##------------------------------------------------------------------------
  28 ##
  29 ## Example use at end of file
  30 ##
  31
  32
  33 ########################################################################
  34 ############################# Ventry ###############################
  35 ########################################################################
  36
  37 array set Ventry {
  38     type                frame
  39     base                entry
  40     components          {label}
  41
  42     -bd                 -borderwidth
  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}
  51     -validatecmd        -vcmd
  52     -vcmd               {validateCmd    ValidateCmd     {}}
  53     -validate           {validate       Validate        none}
  54     -textvariable       {textVariable   TextVariable    {}}
  55 }
  56
  57 # Create this to make sure there are registered in auto_mkindex
  58 # these must come before the [widget create ...]
  59 proc Ventry args {}
  60 proc ventry args {}
  61 widget create Ventry
  62
  63 ;proc Ventry:construct {w args} {
  64     upvar \#0 $w data
  65
  66     set data(flags) {}
  67
  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)
  73
  74     bind $data(entry) <FocusIn>  [list Ventry:focus $w in]
  75     bind $data(entry) <FocusOut> [list Ventry:focus $w out]
  76 }
  77
  78 ;proc Ventry:configure {w args} {
  79     upvar \#0 $w data
  80     set truth {^(1|yes|true|on)$}
  81     foreach {key val} $args {
  82         switch -- $key {
  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 }
  87             -labeltext          {
  88                 $data(label) configure -text $val
  89                 if {[string compare {} $val]} {
  90                     grid $data(label)
  91                 } else {
  92                     grid remove $data(label)
  93                 }
  94             }
  95             -labelwidth         { $data(label) configure -width $val }
  96             -validate {
  97                 if {![regexp {^(focus|focusin|focusout|all|none|key)$} $val]} {
  98                     return -code error "Invalid validation type \"$val\""
  99                 }
 100             }
 101             -textvariable       { $data(basecmd) configure -textvariable $val }
 102         }
 103         set data($key) $val
 104     }
 105 }
 106
 107 ;proc Ventry_insert {w index string} {
 108     upvar \#0 $w data
 109
 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]} {
 115             return
 116         }
 117     }
 118     return [uplevel [list $data(basecmd) insert $index $string]]
 119 }
 120
 121 ;proc Ventry_delete {w first {last {}}} {
 122     upvar \#0 $w data
 123
 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]
 128         } else {
 129             set last [$data(basecmd) index $last]
 130         }
 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]} {
 135             return
 136         }
 137     }
 138     return [uplevel [list $data(basecmd) delete $first] $last]
 139 }
 140
 141 ;proc Ventry_validate {w} {
 142     upvar \#0 $w data
 143
 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}]
 150 }
 151
 152 ;proc Ventry:focus {w which} {
 153     upvar \#0 $w data
 154
 155     if {[regexp "^(all|focus($which)?)\$" $data(-validate)]} {
 156         catch {Ventry:validate $w {} [$data(basecmd) get] \
 157                 [$data(basecmd) index insert] focus$which}
 158     }
 159 }
 160
 161 ;proc Ventry:validate {w str new index type} {
 162     upvar \#0 $w data
 163
 164     if {[string match {} $data(-vcmd)] || \
 165             [string match none $data(-validate)]} {
 166         return
 167     }
 168     set data(flags) VALIDATING
 169
 170     set cmd [Ventry:substitute $w $data(-vcmd) $str $new $index $type]
 171
 172     set code [catch {uplevel \#0 $cmd} result]
 173     if {$code != 0 && $code != 2} {
 174         global errorInfo
 175         append errorInfo "\n\t(in $w validation command)"
 176         bgerror $result
 177         set code 1
 178     } else {
 179         set val [regexp {^(1|yes|true|on)$} $result]
 180         if $val { set code 0 } else { set code 3 }
 181         set result {}
 182     }
 183
 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)]} {
 189         set code 1
 190     }
 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)
 194     if {$code} {
 195         if {$code == 3} {
 196             ## TCL_BREAK
 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]} {
 201                     global errorInfo
 202                     append errorInfo "\n\t(in $w validation command)"
 203                     bgerror $result
 204                     set code 1
 205                     set data(-validate) none
 206                 }
 207             }
 208         } else {
 209             set data(-validate) none
 210         }
 211     }
 212     set data(flags) {}
 213     return -code $code $result
 214 }
 215
 216 ;proc Ventry:substitute {w cmd change newstr index type} {
 217     upvar \#0 $w data
 218
 219     set old $cmd
 220     set i [string first % $cmd]
 221     if {$i < 0} { return $old }
 222     set new [string range $cmd 0 [incr i -1]]
 223     while 1 {
 224         set c [string index $cmd [incr i 2]]
 225         switch $c {
 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] }
 235         }
 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]]
 240     }
 241 }