| # |
| # 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: entryfield.itk,v 1.6 2001/09/17 19:24:46 smithc Exp $ |
| # ---------------------------------------------------------------------- |
| # 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 |
| } |
| } |
| } |