neingeist
/
arduinisten
Archived
1
0
Fork 0
You cannot select more than 25 topics Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
This repo is archived. You can view files and clone it, but cannot push or open issues/pull-requests.

604 lines
21 KiB
Plaintext

#
# 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
}
}
}