Subversion Repositories or1k

#
# 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) <KeyPress> [code $this _keyPress %A %K %s]
    bind $itk_component(entry) <FocusIn> [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
}