library/entryx.tcl

   1 # entryx.tcl --
   2 #
   3 # This file defines the additional bindings for entry widgets and provides
   4 # procedures that help in implementing those bindings.
   5 #
   6 # Copyright (c) 1992-1994 The Regents of the University of California.
   7 # Copyright (c) 1994-1995 Sun Microsystems, Inc.
   8 # Copyright (c) 1995 Christian Werner
   9 #
  10 # See the file "license.terms" for information on usage and redistribution
  11 # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  12 #
  13
  14 #-------------------------------------------------------------------------
  15 # Create extended entry widget.
  16 #-------------------------------------------------------------------------
  17
  18 proc entryx {w args} {
  19     global ckPriv errorInfo
  20
  21     set mode EntryNormal
  22     set index [lsearch -glob $args -mod*]
  23     set regexp ".*"
  24     if {$index >= 0} {
  25         set mode [lindex $args [expr $index + 1]]
  26         switch -glob -- $mode {
  27             in* {
  28                 set mode EntryInteger
  29                 set regexp {^[-+]?[0-9]*$}
  30             }
  31             un* {
  32                 set mode EntryUnsigned
  33                 set regexp {^[0-9]*$}
  34             }
  35             fl* {
  36                 set mode EntryFloat
  37                 set regexp {^[-+]?(([0-9]*(\.)[0-9]*)|([0-9]*))$}
  38             }
  39             re* {
  40                 set mode EntryRegexp
  41             }
  42             no* {
  43                 set mode EntryNormal
  44             }
  45             bo* {
  46                 set mode EntryBoolean
  47             }
  48             default {
  49                 return -code error -errorinfo \
  50 "bad mode \"$mode\": should be boolean, integer, unsigned, float, regexp or normal"
  51             }
  52         }
  53         set args [lreplace $args $index [expr $index + 1]]
  54     }
  55
  56
  57     set index [lsearch -glob $args -reg*]
  58     if {$index >= 0} {
  59         set regexp [lindex $args [expr $index + 1]]
  60         if [catch {regexp -- $regexp foo}] {
  61             return -code error -errorinfo "bad regexp \"$regexp\""
  62         }
  63         set args [lreplace $args $index [expr $index + 1]]
  64     }
  65
  66     set initial ""
  67     set index [lsearch -glob $args -ini*]
  68     if {$index >= 0} {
  69         set initial [lindex $args [expr $index + 1]]
  70         set args [lreplace $args $index [expr $index + 1]]
  71     }
  72
  73     set touchvar ""
  74     set index [lsearch -glob $args -to*]
  75     if {$index >= 0} {
  76         set touchvar [lindex $args [expr $index + 1]]
  77         set args [lreplace $args $index [expr $index + 1]]
  78     }
  79
  80     set default ""
  81     set index [lsearch -glob $args -de*]
  82     if {$index >= 0} {
  83         set default [lindex $args [expr $index + 1]]
  84         set args [lreplace $args $index [expr $index + 1]]
  85     }
  86
  87     if {$mode == "EntryBoolean"} {
  88         set onval 1
  89         set offval 0
  90
  91         set index [lsearch -glob $args -onv*]
  92         if {$index >= 0} {
  93             set onval [lindex $args [expr $index + 1]]
  94             set args [lreplace $args $index [expr $index + 1]]
  95         }
  96         set index [lsearch -glob $args -offv*]
  97         if {$index >= 0} {
  98             set offval [lindex $args [expr $index + 1]]
  99             set args [lreplace $args $index [expr $index + 1]]
 100         }
 101     }
 102
 103     set fieldwidth 100000
 104     set index [lsearch -glob $args -fie*]
 105     if {$index >= 0} {
 106         set value [lindex $args [expr $index + 1]]
 107         if {[catch {expr int($value)} fieldwidth] || $fieldwidth <= 0} {
 108             return -code error -errorinfo "bad fieldwidth \"$value\""
 109         }
 110         set args [lreplace $args $index [expr $index + 1]]
 111     }
 112
 113     if [catch {eval entry $w $args} ret] {
 114         return -code error -errorinfo $errorInfo
 115     }
 116
 117     set ckPriv(entryx$ret,fw) $fieldwidth
 118     if {$touchvar != ""} {
 119         upvar #0 $touchvar tv
 120         if ![catch {set tv 0}] {
 121             set ckPriv(entryx$ret,tv) $touchvar
 122         }
 123     }
 124     set ckPriv(entryx$ret,re) $regexp
 125     set ckPriv(entryx$ret,de) $default
 126
 127     if {$mode == "EntryBoolean"} {
 128         set ckPriv(entryx$ret,t) [string toupper [string index $onval 0]]
 129         set ckPriv(entryx$ret,f) [string toupper [string index $offval 0]]
 130     }
 131
 132     bindtags $ret [list $ret $mode [winfo toplevel $ret] all]
 133
 134     if {$initial != ""} {
 135         $ret delete 0 end
 136         $ret insert end $initial
 137     }
 138
 139     return $ret
 140 }
 141
 142 #-------------------------------------------------------------------------
 143 # The code below creates the class bindings for extended entries.
 144 #-------------------------------------------------------------------------
 145
 146 bind EntryInteger  <Destroy> {ckEntryDestroy %W}
 147 bind EntryUnsigned <Destroy> {ckEntryDestroy %W}
 148 bind EntryFloat    <Destroy> {ckEntryDestroy %W}
 149 bind EntryRegexp   <Destroy> {ckEntryDestroy %W}
 150 bind EntryNormal   <Destroy> {ckEntryDestroy %W}
 151 bind EntryBoolean  <Destroy> {ckEntryDestroy %W}
 152
 153 bind EntryInteger  <FocusIn> {ckEntryFocus %W 1 Integer}
 154 bind EntryUnsigned <FocusIn> {ckEntryFocus %W 1 Unsigned}
 155 bind EntryFloat    <FocusIn> {ckEntryFocus %W 1 Float}
 156 bind EntryRegexp   <FocusIn> {ckEntryFocus %W 1 Regexp}
 157 bind EntryNormal   <FocusIn> {ckEntryFocus %W 1 Normal}
 158 bind EntryBoolean  <FocusIn> {ckEntryFocus %W 1 Boolean}
 159
 160 bind EntryInteger  <FocusOut> {ckEntryFocus %W 0 Integer}
 161 bind EntryUnsigned <FocusOut> {ckEntryFocus %W 0 Unsigned}
 162 bind EntryFloat    <FocusOut> {ckEntryFocus %W 0 Float}
 163 bind EntryRegexp   <FocusOut> {ckEntryFocus %W 0 Regexp}
 164 bind EntryNormal   <FocusOut> {ckEntryFocus %W 0 Normal}
 165 bind EntryBoolean  <FocusOut> {ckEntryFocus %W 0 Boolean}
 166
 167 bind EntryInteger  <Left> {ckEntryXSetCursor %W [expr [%W index insert] - 1]}
 168 bind EntryUnsigned <Left> {ckEntryXSetCursor %W [expr [%W index insert] - 1]}
 169 bind EntryFloat    <Left> {ckEntryXSetCursor %W [expr [%W index insert] - 1]}
 170 bind EntryRegexp   <Left> {ckEntryXSetCursor %W [expr [%W index insert] - 1]}
 171 bind EntryNormal   <Left> {ckEntryXSetCursor %W [expr [%W index insert] - 1]}
 172 bind EntryBoolean  <Left> {focus [ck_focusPrev %W]}
 173
 174 bind EntryInteger  <Right> {ckEntryXSetCursor %W [expr [%W index insert] + 1]}
 175 bind EntryUnsigned <Right> {ckEntryXSetCursor %W [expr [%W index insert] + 1]}
 176 bind EntryFloat    <Right> {ckEntryXSetCursor %W [expr [%W index insert] + 1]}
 177 bind EntryRegexp   <Right> {ckEntryXSetCursor %W [expr [%W index insert] + 1]}
 178 bind EntryNormal   <Right> {ckEntryXSetCursor %W [expr [%W index insert] + 1]}
 179 bind EntryBoolean  <Right> {focus [ck_focusNext %W]}
 180
 181 bind EntryInteger  <BackSpace> {ckEntryXBackspace %W}
 182 bind EntryUnsigned <BackSpace> {ckEntryXBackspace %W}
 183 bind EntryFloat    <BackSpace> {ckEntryXBackspace %W}
 184 bind EntryRegexp   <BackSpace> {ckEntryXBackspace %W}
 185 bind EntryNormal   <BackSpace> {ckEntryXBackspace %W}
 186 bind EntryBoolean  <BackSpace> {# nothing}
 187
 188 bind EntryInteger  <Control-h> {ckEntryXBackspace %W}
 189 bind EntryUnsigned <Control-h> {ckEntryXBackspace %W}
 190 bind EntryFloat    <Control-h> {ckEntryXBackspace %W}
 191 bind EntryRegexp   <Control-h> {ckEntryXBackspace %W}
 192 bind EntryNormal   <Control-h> {ckEntryXBackspace %W}
 193 bind EntryBoolean  <Control-h> {# nothing}
 194
 195 bind EntryInteger  <Delete> {ckEntryXDelete %W}
 196 bind EntryUnsigned <Delete> {ckEntryXDelete %W}
 197 bind EntryFloat    <Delete> {ckEntryXDelete %W}
 198 bind EntryRegexp   <Delete> {ckEntryXDelete %W}
 199 bind EntryNormal   <Delete> {ckEntryXDelete %W}
 200 bind EntryBoolean  <Delete> {# nothing}
 201
 202 bind EntryInteger  <ASCIIDelete> {ckEntryXDelete %W}
 203 bind EntryUnsigned <ASCIIDelete> {ckEntryXDelete %W}
 204 bind EntryFloat    <ASCIIDelete> {ckEntryXDelete %W}
 205 bind EntryRegexp   <ASCIIDelete> {ckEntryXDelete %W}
 206 bind EntryNormal   <ASCIIDelete> {ckEntryXDelete %W}
 207 bind EntryBoolean  <ASCIIDelete> {# nothing}
 208
 209 bind EntryInteger  <Home> {ckEntryXSetCursor %W 0}
 210 bind EntryUnsigned <Home> {ckEntryXSetCursor %W 0}
 211 bind EntryFloat    <Home> {ckEntryXSetCursor %W 0}
 212 bind EntryRegexp   <Home> {ckEntryXSetCursor %W 0}
 213 bind EntryNormal   <Home> {ckEntryXSetCursor %W 0}
 214 bind EntryBoolean  <Home> {# nothing}
 215
 216 bind EntryInteger  <End> {ckEntryXSetCursor %W [expr [%W index end] - 1]}
 217 bind EntryUnsigned <End> {ckEntryXSetCursor %W [expr [%W index end] - 1]}
 218 bind EntryFloat    <End> {ckEntryXSetCursor %W [expr [%W index end] - 1]}
 219 bind EntryRegexp   <End> {ckEntryXSetCursor %W [expr [%W index end] - 1]}
 220 bind EntryNormal   <End> {ckEntryXSetCursor %W [expr [%W index end] - 1]}
 221 bind EntryBoolean  <End> {# nothing}
 222
 223 bind EntryInteger  <Return> {focus [ck_focusNext %W]}
 224 bind EntryUnsigned <Return> {focus [ck_focusNext %W]}
 225 bind EntryFloat    <Return> {focus [ck_focusNext %W]}
 226 bind EntryRegexp   <Return> {focus [ck_focusNext %W]}
 227 bind EntryNormal   <Return> {focus [ck_focusNext %W]}
 228 bind EntryBoolean  <Return> {focus [ck_focusNext %W]}
 229
 230 bind EntryInteger  <Linefeed> {focus [ck_focusNext %W]}
 231 bind EntryUnsigned <Linefeed> {focus [ck_focusNext %W]}
 232 bind EntryFloat    <Linefeed> {focus [ck_focusNext %W]}
 233 bind EntryRegexp   <Linefeed> {focus [ck_focusNext %W]}
 234 bind EntryNormal   <Linefeed> {focus [ck_focusNext %W]}
 235 bind EntryBoolean  <Linefeed> {focus [ck_focusNext %W]}
 236
 237 bind EntryInteger  <Tab> {# nothing}
 238 bind EntryUnsigned <Tab> {# nothing}
 239 bind EntryFloat    <Tab> {# nothing}
 240 bind EntryRegexp   <Tab> {# nothing}
 241 bind EntryNormal   <Tab> {# nothing}
 242 bind EntryBoolean  <Tab> {# nothing}
 243
 244 bind EntryInteger  <BackTab> {# nothing}
 245 bind EntryUnsigned <BackTab> {# nothing}
 246 bind EntryFloat    <BackTab> {# nothing}
 247 bind EntryRegexp   <BackTab> {# nothing}
 248 bind EntryNormal   <BackTab> {# nothing}
 249 bind EntryBoolean  <BackTab> {# nothing}
 250
 251 bind EntryInteger  <Escape> {# nothing}
 252 bind EntryUnsigned <Escape> {# nothing}
 253 bind EntryFloat    <Escape> {# nothing}
 254 bind EntryRegexp   <Escape> {# nothing}
 255 bind EntryNormal   <Escape> {# nothing}
 256 bind EntryBoolean  <Escape> {# nothing}
 257
 258 bind EntryInteger  <Control> {# nothing}
 259 bind EntryUnsigned <Control> {# nothing}
 260 bind EntryFloat    <Control> {# nothing}
 261 bind EntryRegexp   <Control> {# nothing}
 262 bind EntryNormal   <Control> {# nothing}
 263 bind EntryBoolean  <Control> {# nothing}
 264
 265 bind EntryInteger  <KeyPress> {ckEntryInput %W %A}
 266 bind EntryUnsigned <KeyPress> {ckEntryInput %W %A}
 267 bind EntryFloat    <KeyPress> {ckEntryInput %W %A}
 268 bind EntryRegexp   <KeyPress> {ckEntryInput %W %A}
 269 bind EntryNormal   <KeyPress> {ckEntryInput %W %A}
 270 bind EntryBoolean  <KeyPress> {ckEntryBooleanInput %W %A}
 271
 272 bind EntryInteger <Button-1> {
 273     if [ckFocusOK %W] {%W icursor @%x ; focus %W}
 274 }
 275 bind EntryUnsigned <Button-1> {
 276     if [ckFocusOK %W] {%W icursor @%x ; focus %W}
 277 }
 278 bind EntryFloat <Button-1> {
 279     if [ckFocusOK %W] {%W icursor @%x ; focus %W}
 280 }
 281 bind EntryRegexp <Button-1> {
 282     if [ckFocusOK %W] {%W icursor @%x ; focus %W}
 283 }
 284 bind EntryNormal <Button-1> {
 285     if [ckFocusOK %W] {%W icursor @%x ; focus %W}
 286 }
 287 bind EntryBoolean <Button-1> {
 288     if [ckFocusOK %W] {%W icursor @%x ; focus %W}
 289 }
 290
 291 # ckEntryDestroy --
 292 # If entry has been destroyed, cleanup parts of global ckPriv array
 293 #
 294 # Arguments:
 295 # w -           The entry window
 296
 297 proc ckEntryDestroy w {
 298     global ckPriv
 299     unset ckPriv(entryx$w,fw)
 300     unset ckPriv(entryx$w,re)
 301     unset ckPriv(entryx$w,de)
 302     catch {unset ckPriv(entryx%W,tv)}
 303     catch {unset ckPriv(entryx%W,t)}
 304     catch {unset ckPriv(entryx%W,f)}
 305 }
 306
 307 # ckEntryTouched --
 308 # If entry has a touch variable assigned, this variable is asserted here.
 309 #
 310 # Arguments:
 311 # w -           The entry window
 312
 313 proc ckEntryTouched w {
 314     global ckPriv
 315     if [info exists ckPriv(entryx$w,tv)] {
 316         upvar #0 $ckPriv(entryx$w,tv) var
 317         set var 1
 318     }
 319 }
 320
 321 # ckEntryFocus --
 322 # For FocusIn set reverse on mono screens or swap foreground/background
 323 # on color screens and position insertion cursor in first column of entry.
 324 # For FocusOut restore attributes or colors.
 325 #
 326 # Arguments:
 327 # w -           The entry window
 328 # focus -       1=FocusIn or 0=FocusOut
 329 # mode -        Type of entryx, e.g. Integer etc.
 330
 331 proc ckEntryFocus {w focus mode} {
 332     global ckPriv
 333     if {[winfo depth $w] == 1} {
 334         if $focus {
 335             set ckPriv(entryxAttr) [$w cget -attributes]
 336             $w configure -attributes reverse
 337         } else {
 338             $w configure -attributes $ckPriv(entryxAttr)
 339         }
 340     } else {
 341         if $focus {
 342             set ckPriv(entryxFg) [$w cget -foreground]
 343             set ckPriv(entryxBg) [$w cget -background]
 344             $w configure -foreground $ckPriv(entryxBg) \
 345                 -background $ckPriv(entryxFg)
 346         } else {
 347             $w configure -foreground $ckPriv(entryxFg) \
 348                 -background $ckPriv(entryxBg)
 349         }
 350     }
 351     if $focus {
 352         $w icursor 0
 353         ckEntryXSeeInsert $w
 354     } else {
 355         switch -glob -- $mode {
 356             Integer - Unsigned {
 357                 set val [$w get]
 358                 $w delete 0 end
 359                 if [scan $val %d val] {
 360                     $w insert end $val
 361                 } else {
 362                     $w insert end $ckPriv(entryx$w,de)
 363                 }
 364             }
 365             Float {
 366                 set val [$w get]
 367                 $w delete 0 end
 368                 if [scan $val %f val] {
 369                     $w insert end $val
 370                 } else {
 371                     $w insert end $ckPriv(entryx$w,de)
 372                 }
 373             }
 374         }
 375     }
 376 }
 377
 378 # ckEntryXSetCursor -
 379 # Move the insertion cursor to a given position in an entry.
 380 # Makes sure that the insertion cursor is visible.
 381 #
 382 # Arguments:
 383 # w -           The entry window.
 384 # pos -         The desired new position for the cursor in the window.
 385
 386 proc ckEntryXSetCursor {w pos} {
 387     $w icursor $pos
 388     ckEntryXSeeInsert $w
 389 }
 390
 391 # ckEntryXSeeInsert --
 392 # Make sure that the insertion cursor is visible in the entry window.
 393 # If not, adjust the view so that it is. If the cursor is at the very
 394 # end of the fieldwidth, advance focus to next window.
 395 #
 396 # Arguments:
 397 # w -           The entry window.
 398
 399 proc ckEntryXSeeInsert w {
 400     global ckPriv
 401     set c [$w index insert]
 402     set left [$w index @0]
 403     if {$left > $c} {
 404         $w xview $c
 405         return
 406     }
 407     set x [winfo width $w]
 408     while {([$w index @$x] <= $c) && ($left < $c)} {
 409         incr left
 410         $w xview $left
 411     }
 412     if {$c >= $ckPriv(entryx$w,fw)} {
 413         $w icursor [expr $ckPriv(entryx$w,fw) - 1]
 414     }
 415     if {$c >= $ckPriv(entryx$w,fw)} {
 416         set c [expr $ckPriv(entryx$w,fw) - 1]
 417         $w icursor $c
 418         $w xview [expr $c - $x]
 419     }
 420 }
 421
 422 # ckEntryXBackspace --
 423 # Backspace over the character just before the insertion cursor.
 424 # If backspacing would move the cursor off the left edge of the
 425 # window, reposition the cursor at about the middle of the window.
 426 #
 427 # Arguments:
 428 # w -           The entry window in which to backspace.
 429
 430 proc ckEntryXBackspace w {
 431     set x [expr {[$w index insert] - 1}]
 432     if {$x >= 0} {
 433         $w delete $x
 434         ckEntryTouched $w
 435     }
 436     if {[$w index @0] >= [$w index insert]} {
 437         set range [$w xview]
 438         set left [lindex $range 0]
 439         set right [lindex $range 1]
 440         $w xview moveto [expr $left - ($right - $left)/2.0]
 441     }
 442 }
 443
 444 # ckEntryXDelete --
 445 # Delete the character at the insertion cursor.
 446 #
 447 # Arguments:
 448 # w -           The entry window in which to backspace.
 449
 450 proc ckEntryXDelete w {
 451     set a [$w index insert]
 452     set b [$w index end]
 453     if {$a != $b && $b != 0} {
 454         $w delete $a
 455         ckEntryTouched $w
 456     }
 457 }
 458
 459 # ckEntryBooleanInput --
 460 #
 461 # Arguments:
 462 # w -           The entry window in which to insert the string
 463 # s -           The string to insert
 464
 465 proc ckEntryBooleanInput {w s} {
 466     global ckPriv
 467     set old [$w get]
 468     set s [string toupper $s]
 469     if {[string compare " " $s] == 0} {
 470         if {[string compare $ckPriv(entryx$w,t) $old] == 0} {
 471             set s $ckPriv(entryx$w,f)
 472         } else {
 473             set s $ckPriv(entryx$w,t)
 474         }
 475     } elseif {[string compare $ckPriv(entryx$w,t) $s] != 0 && \
 476         [string compare $ckPriv(entryx$w,f) $s] != 0} {
 477         return
 478     }
 479     if {[string compare $s $old] != 0} {
 480         $w delete 0 end
 481         $w insert 0 $s
 482         $w icursor 0
 483         ckEntryTouched $w
 484     }
 485 }
 486
 487 # ckEntryInput --
 488 #
 489 #    Input string into entry (types Integer, Unsigned, Float, Regexp, Normal).
 490 #    Handling of blanks is as follows:
 491 #      1. try to enter blank into the string, if result is a valid regexp
 492 #      2. otherwise try to delete rest of field, if result is a valid regexp
 493 #      3. ignore the blank input
 494 #    Lower case characters are converted to upper case, if regexp denies
 495 #    lower case characters.
 496 #
 497 # Arguments:
 498 # w -           The entry window in which to insert the string
 499 # s -           The string to insert
 500
 501 proc ckEntryInput {w s} {
 502     global ckPriv
 503     if {$s == ""} return
 504     set insert [$w index insert]
 505     if {$insert >= $ckPriv(entryx$w,fw)} return
 506     set save [$w get]
 507     $w insert insert $s
 508     $w delete insert
 509     if {![regexp $ckPriv(entryx$w,re) [$w get]]} {
 510         set ok 1
 511         if {$s == " "} {
 512             $w icursor [expr [$w index insert] - 1]
 513             $w delete insert end
 514             ckEntryTouched $w
 515             ckEntryXSeeInsert $w
 516             return
 517         } elseif {[string match {[a-z]} $s]} {
 518             $w icursor $insert
 519             $w insert insert [string toupper $s]
 520             $w delete insert
 521         } else {
 522             set ok 0
 523         }
 524         if {$ok} {
 525             set ok [regexp $ckPriv(entryx$w,re) [$w get]]
 526         }
 527         if {!$ok} {
 528             $w delete 0 end
 529             $w insert end $save
 530             $w icursor $insert
 531             ckEntryXSeeInsert $w
 532             bell
 533             return
 534         }
 535     }
 536     ckEntryTouched $w
 537     ckEntryXSeeInsert $w
 538 }