Subversion Repositories or1k_old

#

# 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.1.1.1 2002-01-16 10:24:50 markom 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

# ------------------------------------------------------------------

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

}

#

# Provide a lowercased access method for the Entryfield class.

#

proc ::iwidgets::entryfield {pathName args} {

    uplevel ::iwidgets::Entryfield $pathName $args

}

# ------------------------------------------------------------------

#                        CONSTRUCTOR

# ------------------------------------------------------------------

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)  [code $this _keyPress %A %K %s]

    bind $itk_component(entry)  [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

# ------------------------------------------------------------------

configbody iwidgets::Entryfield::command {}

# ------------------------------------------------------------------

# OPTION: -focuscommand

#

# Command associated upon detection of focus.

# ------------------------------------------------------------------

configbody iwidgets::Entryfield::focuscommand {}

# ------------------------------------------------------------------

# OPTION: -validate

#

# Specify a command to executed for the validation of Entryfields.

# ------------------------------------------------------------------

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.

# ------------------------------------------------------------------

configbody iwidgets::Entryfield::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).

# ------------------------------------------------------------------

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.

# ------------------------------------------------------------------

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.

# ------------------------------------------------------------------

body iwidgets::Entryfield::childsite {} {

    return $itk_component(efchildsite)

}

# ------------------------------------------------------------------

# METHOD: get

#

# Thin wrap of the standard entry widget get method.

# ------------------------------------------------------------------

body iwidgets::Entryfield::get {} {

    return [$itk_component(entry) get]

}

# ------------------------------------------------------------------

# METHOD: delete

#

# Thin wrap of the standard entry widget delete method.

# ------------------------------------------------------------------

body iwidgets::Entryfield::delete {args} {

    return [eval $itk_component(entry) delete $args]

}

# ------------------------------------------------------------------

# METHOD: icursor

#

# Thin wrap of the standard entry widget icursor method.

# ------------------------------------------------------------------

body iwidgets::Entryfield::icursor {args} {

    return [eval $itk_component(entry) icursor $args]

}

# ------------------------------------------------------------------

# METHOD: index

#

# Thin wrap of the standard entry widget index method.

# ------------------------------------------------------------------

body iwidgets::Entryfield::index {args} {

    return [eval $itk_component(entry) index $args]

}

# ------------------------------------------------------------------

# METHOD: insert

#

# Thin wrap of the standard entry widget index method.

# ------------------------------------------------------------------

body iwidgets::Entryfield::insert {args} {

    return [eval $itk_component(entry) insert $args]

}

# ------------------------------------------------------------------

# METHOD: scan

#

# Thin wrap of the standard entry widget scan method.

# ------------------------------------------------------------------

body iwidgets::Entryfield::scan {args} {

    return [eval $itk_component(entry) scan $args]

}

# ------------------------------------------------------------------

# METHOD: selection

#

# Thin wrap of the standard entry widget selection method.

# ------------------------------------------------------------------

body iwidgets::Entryfield::selection {args} {

    return [eval $itk_component(entry) selection $args]

}

# ------------------------------------------------------------------

# METHOD: xview

#

# Thin wrap of the standard entry widget xview method.

# ------------------------------------------------------------------

body iwidgets::Entryfield::xview {args} {

    return [eval $itk_component(entry) xview $args]

}

# ------------------------------------------------------------------

# METHOD: clear

#

# Delete the current entry contents.

# ------------------------------------------------------------------

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.

# ------------------------------------------------------------------

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.

# ------------------------------------------------------------------

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.

# ------------------------------------------------------------------

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.

# ------------------------------------------------------------------

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.

# ------------------------------------------------------------------

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.

# ------------------------------------------------------------------

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.

# ------------------------------------------------------------------

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

# ------------------------------------------------------------------

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.

# ------------------------------------------------------------------

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.

    #

    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

        }

    }

    #

    # 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

}