diff options
Diffstat (limited to 'itcl/iwidgets/generic/entryfield.itk')
| -rw-r--r-- | itcl/iwidgets/generic/entryfield.itk | 603 |
1 files changed, 603 insertions, 0 deletions
diff --git a/itcl/iwidgets/generic/entryfield.itk b/itcl/iwidgets/generic/entryfield.itk new file mode 100644 index 00000000000..ce95d7bf790 --- /dev/null +++ b/itcl/iwidgets/generic/entryfield.itk @@ -0,0 +1,603 @@ +# +# Entryfield +# ---------------------------------------------------------------------- +# Implements an enhanced text entry widget. +# +# ---------------------------------------------------------------------- +# AUTHOR: Sue Yockey E-mail: yockey@acm.org +# Mark L. Ulferts E-mail: mulferts@austin.dsccc.com +# +# @(#) $Id$ +# ---------------------------------------------------------------------- +# 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 Entryfield { + keep -background -borderwidth -cursor -foreground -highlightcolor \ + -highlightthickness -insertbackground -insertborderwidth \ + -insertofftime -insertontime -insertwidth -labelfont \ + -selectbackground -selectborderwidth -selectforeground \ + -textbackground -textfont +} + +# ------------------------------------------------------------------ +# ENTRYFIELD +# ------------------------------------------------------------------ +itcl::class iwidgets::Entryfield { + 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 -pasting pasting Behavior 1 + itk_option define -validate validate Command {} + + 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 {} + } + + proc numeric {char} {} + proc integer {string} {} + proc alphabetic {char} {} + proc alphanumeric {char} {} + proc hexidecimal {string} {} + proc real {string} {} + + protected { + method _focusCommand {} + method _keyPress {char sym state} + } + + private method _peek {char} + private method _checkLength {} +} + +# +# Provide a lowercased access method for the Entryfield class. +# +proc ::iwidgets::entryfield {pathName args} { + uplevel ::iwidgets::Entryfield $pathName $args +} + +# ------------------------------------------------------------------ +# CONSTRUCTOR +# ------------------------------------------------------------------ +itcl::body iwidgets::Entryfield::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) + + # + # Entryfield 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::Entryfield::command {} + +# ------------------------------------------------------------------ +# OPTION: -focuscommand +# +# Command associated upon detection of focus. +# ------------------------------------------------------------------ +itcl::configbody iwidgets::Entryfield::focuscommand {} + +# ------------------------------------------------------------------ +# OPTION: -validate +# +# Specify a command to executed for the validation of Entryfields. +# ------------------------------------------------------------------ +itcl::configbody iwidgets::Entryfield::validate { + switch $itk_option(-validate) { + {} { + set itk_option(-validate) {} + } + numeric { + set itk_option(-validate) "::iwidgets::Entryfield::numeric %c" + } + integer { + set itk_option(-validate) "::iwidgets::Entryfield::integer %P" + } + hexidecimal { + set itk_option(-validate) "::iwidgets::Entryfield::hexidecimal %P" + } + real { + set itk_option(-validate) "::iwidgets::Entryfield::real %P" + } + alphabetic { + set itk_option(-validate) "::iwidgets::Entryfield::alphabetic %c" + } + alphanumeric { + set itk_option(-validate) "::iwidgets::Entryfield::alphanumeric %c" + } + } +} + +# ------------------------------------------------------------------ +# OPTION: -invalid +# +# Specify a command to executed should the current Entryfield contents +# be proven invalid. +# ------------------------------------------------------------------ +itcl::configbody iwidgets::Entryfield::invalid {} + +# ------------------------------------------------------------------ +# OPTION: -pasting +# +# Allows the developer to enable and disable pasting into the entry +# component of the entryfield. This is done to avoid potential stack +# dumps when using the -validate configuration option. Plus, it's just +# a good idea to have complete control over what you allow the user +# to enter into the entryfield. +# ------------------------------------------------------------------ +itcl::configbody iwidgets::Entryfield::pasting { + set oldtags [bindtags $itk_component(entry)] + if {[lindex $oldtags 0] != "pastetag"} { + bindtags $itk_component(entry) [linsert $oldtags 0 pastetag] + } + + if ($itk_option(-pasting)) { + bind pastetag <ButtonRelease-2> [itcl::code $this _checkLength] + bind pastetag <Control-v> [itcl::code $this _checkLength] + bind pastetag <Insert> [itcl::code $this _checkLength] + bind pastetag <KeyPress> {} + } else { + bind pastetag <ButtonRelease-2> {break} + bind pastetag <Control-v> {break} + bind pastetag <Insert> {break} + bind pastetag <KeyPress> { + # Disable function keys > F9. + if {[regexp {^F[1,2][0-9]+$} "%K"]} { + break + } + } + } +} + +# ------------------------------------------------------------------ +# 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::Entryfield::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::Entryfield::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" + } + } +} + +# ------------------------------------------------------------------ +# METHODS +# ------------------------------------------------------------------ + +# ------------------------------------------------------------------ +# METHOD: childsite +# +# Returns the path name of the child site widget. +# ------------------------------------------------------------------ +itcl::body iwidgets::Entryfield::childsite {} { + return $itk_component(efchildsite) +} + +# ------------------------------------------------------------------ +# METHOD: get +# +# Thin wrap of the standard entry widget get method. +# ------------------------------------------------------------------ +itcl::body iwidgets::Entryfield::get {} { + return [$itk_component(entry) get] +} + +# ------------------------------------------------------------------ +# METHOD: delete +# +# Thin wrap of the standard entry widget delete method. +# ------------------------------------------------------------------ +itcl::body iwidgets::Entryfield::delete {args} { + return [eval $itk_component(entry) delete $args] +} + +# ------------------------------------------------------------------ +# METHOD: icursor +# +# Thin wrap of the standard entry widget icursor method. +# ------------------------------------------------------------------ +itcl::body iwidgets::Entryfield::icursor {args} { + return [eval $itk_component(entry) icursor $args] +} + +# ------------------------------------------------------------------ +# METHOD: index +# +# Thin wrap of the standard entry widget index method. +# ------------------------------------------------------------------ +itcl::body iwidgets::Entryfield::index {args} { + return [eval $itk_component(entry) index $args] +} + +# ------------------------------------------------------------------ +# METHOD: insert +# +# Thin wrap of the standard entry widget index method. +# ------------------------------------------------------------------ +itcl::body iwidgets::Entryfield::insert {args} { + return [eval $itk_component(entry) insert $args] +} + +# ------------------------------------------------------------------ +# METHOD: scan +# +# Thin wrap of the standard entry widget scan method. +# ------------------------------------------------------------------ +itcl::body iwidgets::Entryfield::scan {args} { + return [eval $itk_component(entry) scan $args] +} + +# ------------------------------------------------------------------ +# METHOD: selection +# +# Thin wrap of the standard entry widget selection method. +# ------------------------------------------------------------------ +itcl::body iwidgets::Entryfield::selection {args} { + return [eval $itk_component(entry) selection $args] +} + +# ------------------------------------------------------------------ +# METHOD: xview +# +# Thin wrap of the standard entry widget xview method. +# ------------------------------------------------------------------ +itcl::body iwidgets::Entryfield::xview {args} { + return [eval $itk_component(entry) xview $args] +} + +# ------------------------------------------------------------------ +# METHOD: clear +# +# Delete the current entry contents. +# ------------------------------------------------------------------ +itcl::body iwidgets::Entryfield::clear {} { + $itk_component(entry) delete 0 end + icursor 0 +} + +# ------------------------------------------------------------------ +# PROCEDURE: numeric char +# +# The numeric procedure validates character input for a given +# Entryfield to be numeric and returns the result. +# ------------------------------------------------------------------ +itcl::body iwidgets::Entryfield::numeric {char} { + return [regexp {[0-9]} $char] +} + +# ------------------------------------------------------------------ +# PROCEDURE: integer string +# +# The integer procedure validates character input for a given +# Entryfield to be integer and returns the result. +# ------------------------------------------------------------------ +itcl::body iwidgets::Entryfield::integer {string} { + return [regexp {^[-+]?[0-9]*$} $string] +} + +# ------------------------------------------------------------------ +# PROCEDURE: alphabetic char +# +# The alphabetic procedure validates character input for a given +# Entryfield to be alphabetic and returns the result. +# ------------------------------------------------------------------ +itcl::body iwidgets::Entryfield::alphabetic {char} { + return [regexp -nocase {[a-z]} $char] +} + +# ------------------------------------------------------------------ +# PROCEDURE: alphanumeric char +# +# The alphanumeric procedure validates character input for a given +# Entryfield to be alphanumeric and returns the result. +# ------------------------------------------------------------------ +itcl::body iwidgets::Entryfield::alphanumeric {char} { + return [regexp -nocase {[0-9a-z]} $char] +} + +# ------------------------------------------------------------------ +# PROCEDURE: hexadecimal string +# +# The hexidecimal procedure validates character input for a given +# Entryfield to be hexidecimal and returns the result. +# ------------------------------------------------------------------ +itcl::body iwidgets::Entryfield::hexidecimal {string} { + return [regexp {^(0x)?[0-9a-fA-F]*$} $string] +} + +# ------------------------------------------------------------------ +# PROCEDURE: real string +# +# The real procedure validates character input for a given Entryfield +# to be real and returns the result. +# ------------------------------------------------------------------ +itcl::body iwidgets::Entryfield::real {string} { + return [regexp {^[-+]?[0-9]*\.?[0-9]*([0-9]\.?[eE][-+]?[0-9]*)?$} $string] +} + +# ------------------------------------------------------------------ +# PRIVATE METHOD: _peek char +# +# The peek procedure returns the value of the Entryfield with the +# char inserted at the insert position. +# ------------------------------------------------------------------ +itcl::body iwidgets::Entryfield::_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] + + regsub -all {\\} "$char" {\\\\} char + 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::Entryfield::_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::Entryfield::_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. + # + #----------------------------------------------------------- + # BUG FIX: csmith (Chad Smith: csmith@adc.com), 3/15/99 + #----------------------------------------------------------- + # The following conditional used to hardcode specific state values, such + # as "4" and "8". These values are used to detect <Ctrl>, <Shift>, etc. + # key combinations. On the windows platform, the <Alt> key is state + # 16, and on the unix platform, the <Alt> key is state 8. All <Ctrl> + # and <Alt> combinations should be masked out, regardless of the + # <NumLock> or <CapsLock> status, and regardless of platform. + #----------------------------------------------------------- + set CTRL 4 + global tcl_platform + if {$tcl_platform(platform) == "unix"} { + set ALT 8 + } elseif {$tcl_platform(platform) == "windows"} { + set ALT 16 + } else { + # This is something other than UNIX or WINDOWS. Default to the + # old behavior (UNIX). + set ALT 8 + } + # Thanks to Rolf Schroedter for the following elegant conditional. This + # masks out all <Ctrl> and <Alt> key combinations. + if {($char == "") || ($state & ($CTRL | $ALT))} { + 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 + } + } + + # + # The validate option may contain a keyword (numeric, alphabetic), + # the name of a procedure, or nothing. The numeric and alphabetic + # keywords engage typical base level checks. If a command procedure + # is specified, then invoke it with the object and character passed + # as arguments. If the validate procedure returns false, then the + # invalid procedure is called. + # + if {$itk_option(-validate) != {}} { + set cmd $itk_option(-validate) + + regsub -all "%W" "$cmd" $itk_component(hull) cmd + regsub -all "%P" "$cmd" [list [_peek $char]] cmd + regsub -all "%S" "$cmd" [list [get]] cmd + regsub -all "%c" "$cmd" [list $char] cmd + regsub -all {\\} "$cmd" {\\\\} cmd + + set valid [uplevel #0 $cmd] + + if {($valid == "") || ([regexp 0|false|off|no $valid])} { + uplevel #0 $itk_option(-invalid) + return -code break 0 + } + } + + return -code continue 1 +} + +# ------------------------------------------------------------------ +# PRIVATE METHOD: _checkLength +# +# This method was added by csmith for SF ticket 227912. We need to +# to check the clipboard content before allowing any pasting into +# the entryfield to disallow text that is longer than the value +# specified by the -fixed option. +# ------------------------------------------------------------------ +itcl::body iwidgets::Entryfield::_checkLength {} { + if {$itk_option(-fixed) != 0} { + if [catch {::selection get -selection CLIPBOARD} pending] { + # Nothing in the clipboard. Check the primary selection. + if [catch {::selection get -selection PRIMARY} pending] { + # Nothing here either. Goodbye. + return + } + } + set len [expr {[string length $pending] + [string length [get]]}] + if {$len > $itk_option(-fixed)} { + uplevel #0 $itk_option(-invalid) + return -code break 0 + } + } +} |