diff options
Diffstat (limited to 'iwidgets/generic/regexpfield.itk')
| -rw-r--r-- | iwidgets/generic/regexpfield.itk | 455 |
1 files changed, 455 insertions, 0 deletions
diff --git a/iwidgets/generic/regexpfield.itk b/iwidgets/generic/regexpfield.itk new file mode 100644 index 00000000000..3e899082743 --- /dev/null +++ b/iwidgets/generic/regexpfield.itk @@ -0,0 +1,455 @@ +# +# Regexpfield +# ---------------------------------------------------------------------- +# Implements a text entry widget which accepts input that matches its +# regular expression, and invalidates input which doesn't. +# +# +# ---------------------------------------------------------------------- +# AUTHOR: John A. Tucker E-mail: jatucker@austin.dsccc.com +# +# ---------------------------------------------------------------------- +# Copyright (c) 1995 DSC Technologies Corporation +# ====================================================================== +# Permission to use, copy, modify, distribute and license this software +# and its documentation for any purpose, and without fee or written +# agreement with DSC, is hereby granted, provided that the above copyright +# notice appears in all copies and that both the copyright notice and +# warranty disclaimer below appear in supporting documentation, and that +# the names of DSC Technologies Corporation or DSC Communications +# Corporation not be used in advertising or publicity pertaining to the +# software without specific, written prior permission. +# +# DSC DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING +# ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS, AND NON- +# INFRINGEMENT. THIS SOFTWARE IS PROVIDED ON AN "AS IS" BASIS, AND THE +# AUTHORS AND DISTRIBUTORS HAVE NO OBLIGATION TO PROVIDE MAINTENANCE, +# SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS. IN NO EVENT SHALL +# DSC BE LIABLE FOR ANY SPECIAL, INDIRECT OR CONSEQUENTIAL DAMAGES OR +# ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, +# WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTUOUS ACTION, +# ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS +# SOFTWARE. +# ====================================================================== + +# +# Usual options. +# +itk::usual Regexpfield { + keep -background -borderwidth -cursor -foreground -highlightcolor \ + -highlightthickness -insertbackground -insertborderwidth \ + -insertofftime -insertontime -insertwidth -labelfont \ + -selectbackground -selectborderwidth -selectforeground \ + -textbackground -textfont +} + +# ------------------------------------------------------------------ +# ENTRYFIELD +# ------------------------------------------------------------------ +itcl::class iwidgets::Regexpfield { + inherit iwidgets::Labeledwidget + + constructor {args} {} + + itk_option define -childsitepos childSitePos Position e + itk_option define -command command Command {} + itk_option define -fixed fixed Fixed 0 + itk_option define -focuscommand focusCommand Command {} + itk_option define -invalid invalid Command bell + itk_option define -regexp regexp Regexp {.*} + itk_option define -nocase nocase Nocase 0 + + public { + method childsite {} + method get {} + method delete {args} + method icursor {args} + method index {args} + method insert {args} + method scan {args} + method selection {args} + method xview {args} + method clear {} + } + + protected { + method _focusCommand {} + method _keyPress {char sym state} + } + + private { + method _peek {char} + } +} + +# +# Provide a lowercased access method for the Regexpfield class. +# +proc ::iwidgets::regexpfield {pathName args} { + uplevel ::iwidgets::Regexpfield $pathName $args +} + +# ------------------------------------------------------------------ +# CONSTRUCTOR +# ------------------------------------------------------------------ +itcl::body iwidgets::Regexpfield::constructor {args} { + component hull configure -borderwidth 0 + + itk_component add entry { + entry $itk_interior.entry + } { + keep -borderwidth -cursor -exportselection \ + -foreground -highlightcolor \ + -highlightthickness -insertbackground -insertborderwidth \ + -insertofftime -insertontime -insertwidth -justify \ + -relief -selectbackground -selectborderwidth \ + -selectforeground -show -state -textvariable -width + + rename -font -textfont textFont Font + rename -highlightbackground -background background Background + rename -background -textbackground textBackground Background + } + + # + # Create the child site widget. + # + itk_component add -protected efchildsite { + frame $itk_interior.efchildsite + } + set itk_interior $itk_component(efchildsite) + + # + # Regexpfield instance bindings. + # + bind $itk_component(entry) <KeyPress> [itcl::code $this _keyPress %A %K %s] + bind $itk_component(entry) <FocusIn> [itcl::code $this _focusCommand] + + # + # Initialize the widget based on the command line options. + # + eval itk_initialize $args +} + +# ------------------------------------------------------------------ +# OPTIONS +# ------------------------------------------------------------------ + +# ------------------------------------------------------------------ +# OPTION: -command +# +# Command associated upon detection of Return key press event +# ------------------------------------------------------------------ +itcl::configbody iwidgets::Regexpfield::command {} + +# ------------------------------------------------------------------ +# OPTION: -focuscommand +# +# Command associated upon detection of focus. +# ------------------------------------------------------------------ +itcl::configbody iwidgets::Regexpfield::focuscommand {} + +# ------------------------------------------------------------------ +# OPTION: -regexp +# +# Specify a regular expression to use in performing validation +# of the content of the entry widget. +# ------------------------------------------------------------------ +itcl::configbody iwidgets::Regexpfield::regexp { +} + +# ------------------------------------------------------------------ +# OPTION: -invalid +# +# Specify a command to executed should the current Regexpfield contents +# be proven invalid. +# ------------------------------------------------------------------ +itcl::configbody iwidgets::Regexpfield::invalid {} + +# ------------------------------------------------------------------ +# OPTION: -fixed +# +# Restrict entry to 0 (unlimited) chars. The value is the maximum +# number of chars the user may type into the field, regardles of +# field width, i.e. the field width may be 20, but the user will +# only be able to type -fixed number of characters into it (or +# unlimited if -fixed = 0). +# ------------------------------------------------------------------ +itcl::configbody iwidgets::Regexpfield::fixed { + if {[regexp {[^0-9]} $itk_option(-fixed)] || \ + ($itk_option(-fixed) < 0)} { + error "bad fixed option \"$itk_option(-fixed)\",\ + should be positive integer" + } +} + +# ------------------------------------------------------------------ +# OPTION: -childsitepos +# +# Specifies the position of the child site in the widget. +# ------------------------------------------------------------------ +itcl::configbody iwidgets::Regexpfield::childsitepos { + set parent [winfo parent $itk_component(entry)] + + switch $itk_option(-childsitepos) { + n { + grid $itk_component(efchildsite) -row 0 -column 0 -sticky ew + grid $itk_component(entry) -row 1 -column 0 -sticky nsew + + grid rowconfigure $parent 0 -weight 0 + grid rowconfigure $parent 1 -weight 1 + grid columnconfigure $parent 0 -weight 1 + grid columnconfigure $parent 1 -weight 0 + } + + e { + grid $itk_component(efchildsite) -row 0 -column 1 -sticky ns + grid $itk_component(entry) -row 0 -column 0 -sticky nsew + + grid rowconfigure $parent 0 -weight 1 + grid rowconfigure $parent 1 -weight 0 + grid columnconfigure $parent 0 -weight 1 + grid columnconfigure $parent 1 -weight 0 + } + + s { + grid $itk_component(efchildsite) -row 1 -column 0 -sticky ew + grid $itk_component(entry) -row 0 -column 0 -sticky nsew + + grid rowconfigure $parent 0 -weight 1 + grid rowconfigure $parent 1 -weight 0 + grid columnconfigure $parent 0 -weight 1 + grid columnconfigure $parent 1 -weight 0 + } + + w { + grid $itk_component(efchildsite) -row 0 -column 0 -sticky ns + grid $itk_component(entry) -row 0 -column 1 -sticky nsew + + grid rowconfigure $parent 0 -weight 1 + grid rowconfigure $parent 1 -weight 0 + grid columnconfigure $parent 0 -weight 0 + grid columnconfigure $parent 1 -weight 1 + } + + default { + error "bad childsite option\ + \"$itk_option(-childsitepos)\":\ + should be n, e, s, or w" + } + } +} +# ------------------------------------------------------------------ +# OPTION: -nocase +# +# Specifies whether or not lowercase characters can match either +# lowercase or uppercase letters in string. +# ------------------------------------------------------------------ +itcl::configbody iwidgets::Regexpfield::nocase { + + switch $itk_option(-nocase) { + 0 - 1 { + + } + + default { + error "bad nocase option \"$itk_option(-nocase)\":\ + should be 0 or 1" + } + } +} + +# ------------------------------------------------------------------ +# METHODS +# ------------------------------------------------------------------ + +# ------------------------------------------------------------------ +# METHOD: childsite +# +# Returns the path name of the child site widget. +# ------------------------------------------------------------------ +itcl::body iwidgets::Regexpfield::childsite {} { + return $itk_component(efchildsite) +} + +# ------------------------------------------------------------------ +# METHOD: get +# +# Thin wrap of the standard entry widget get method. +# ------------------------------------------------------------------ +itcl::body iwidgets::Regexpfield::get {} { + return [$itk_component(entry) get] +} + +# ------------------------------------------------------------------ +# METHOD: delete +# +# Thin wrap of the standard entry widget delete method. +# ------------------------------------------------------------------ +itcl::body iwidgets::Regexpfield::delete {args} { + return [eval $itk_component(entry) delete $args] +} + +# ------------------------------------------------------------------ +# METHOD: icursor +# +# Thin wrap of the standard entry widget icursor method. +# ------------------------------------------------------------------ +itcl::body iwidgets::Regexpfield::icursor {args} { + return [eval $itk_component(entry) icursor $args] +} + +# ------------------------------------------------------------------ +# METHOD: index +# +# Thin wrap of the standard entry widget index method. +# ------------------------------------------------------------------ +itcl::body iwidgets::Regexpfield::index {args} { + return [eval $itk_component(entry) index $args] +} + +# ------------------------------------------------------------------ +# METHOD: insert +# +# Thin wrap of the standard entry widget index method. +# ------------------------------------------------------------------ +itcl::body iwidgets::Regexpfield::insert {args} { + return [eval $itk_component(entry) insert $args] +} + +# ------------------------------------------------------------------ +# METHOD: scan +# +# Thin wrap of the standard entry widget scan method. +# ------------------------------------------------------------------ +itcl::body iwidgets::Regexpfield::scan {args} { + return [eval $itk_component(entry) scan $args] +} + +# ------------------------------------------------------------------ +# METHOD: selection +# +# Thin wrap of the standard entry widget selection method. +# ------------------------------------------------------------------ +itcl::body iwidgets::Regexpfield::selection {args} { + return [eval $itk_component(entry) selection $args] +} + +# ------------------------------------------------------------------ +# METHOD: xview +# +# Thin wrap of the standard entry widget xview method. +# ------------------------------------------------------------------ +itcl::body iwidgets::Regexpfield::xview {args} { + return [eval $itk_component(entry) xview $args] +} + +# ------------------------------------------------------------------ +# METHOD: clear +# +# Delete the current entry contents. +# ------------------------------------------------------------------ +itcl::body iwidgets::Regexpfield::clear {} { + $itk_component(entry) delete 0 end + icursor 0 +} + +# ------------------------------------------------------------------ +# PRIVATE METHOD: _peek char +# +# The peek procedure returns the value of the Regexpfield with the +# char inserted at the insert position. +# ------------------------------------------------------------------ +itcl::body iwidgets::Regexpfield::_peek {char} { + set str [get] + + set insertPos [index insert] + set firstPart [string range $str 0 [expr {$insertPos - 1}]] + set lastPart [string range $str $insertPos end] + + append rtnVal $firstPart $char $lastPart + return $rtnVal +} + +# ------------------------------------------------------------------ +# PROTECTED METHOD: _focusCommand +# +# Method bound to focus event which evaluates the current command +# specified in the focuscommand option +# ------------------------------------------------------------------ +itcl::body iwidgets::Regexpfield::_focusCommand {} { + uplevel #0 $itk_option(-focuscommand) +} + +# ------------------------------------------------------------------ +# PROTECTED METHOD: _keyPress +# +# Monitor the key press event checking for return keys, fixed width +# specification, and optional validation procedures. +# ------------------------------------------------------------------ +itcl::body iwidgets::Regexpfield::_keyPress {char sym state} { + # + # A Return key invokes the optionally specified command option. + # + if {$sym == "Return"} { + uplevel #0 $itk_option(-command) + return -code break 1 + } + + # + # Tabs, BackSpace, and Delete are passed on for other bindings. + # + if {($sym == "Tab") || ($sym == "BackSpace") || ($sym == "Delete")} { + return -code continue 1 + } + + # + # Character is not printable or the state is greater than one which + # means a modifier was used such as a control, meta key, or control + # or meta key with numlock down. + # + if {($char == "") || \ + ($state == 4) || ($state == 8) || \ + ($state == 36) || ($state == 40)} { + return -code continue 1 + } + + # + # If the fixed length option is not zero, then verify that the + # current length plus one will not exceed the limit. If so then + # invoke the invalid command procedure. + # + if {$itk_option(-fixed) != 0} { + if {[string length [get]] >= $itk_option(-fixed)} { + uplevel #0 $itk_option(-invalid) + return -code break 0 + } + } + + set flags "" + + # + # Get the new value of the Regexpfield with the char inserted at the + # insert position. + # + # If the new value doesn't match up with the pattern stored in the + # -regexp option, then the invalid procedure is called. + # + # If the value of the "-nocase" option is true, then add the + # "-nocase" flag to the list of flags. + # + set newVal [_peek $char] + + if {$itk_option(-nocase)} { + set valid [::regexp -nocase -- $itk_option(-regexp) $newVal] + } else { + set valid [::regexp $itk_option(-regexp) $newVal] + } + + if {!$valid} { + uplevel #0 $itk_option(-invalid) + return -code break 0 + } + + return -code continue 1 +} + |