Subversion Repositories or1k

#

# Regexpfield

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

# Implements a text entry widget which accepts input that matches its

# regular expression, and invalidates input which doesn't.

#

#

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

#   AUTHOR:  John A. Tucker           E-mail: jatucker@austin.dsccc.com

#

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

#            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 Regexpfield {

    keep -background -borderwidth -cursor -foreground -highlightcolor \

         -highlightthickness -insertbackground -insertborderwidth \

         -insertofftime -insertontime -insertwidth -labelfont \

         -selectbackground -selectborderwidth -selectforeground \

         -textbackground -textfont

}

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

#                            ENTRYFIELD

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

class iwidgets::Regexpfield {

    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 -regexp regexp Regexp {.*}

    itk_option define -nocase nocase Nocase 0

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

    }

    protected {

        method _focusCommand {}

        method _keyPress {char sym state}

    }

    private {

        method _peek {char}

    }

}

#

# Provide a lowercased access method for the Regexpfield class.

#

proc ::iwidgets::regexpfield {pathName args} {

    uplevel ::iwidgets::Regexpfield $pathName $args

}

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

#                        CONSTRUCTOR

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

body iwidgets::Regexpfield::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)

    #

    # Regexpfield 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::Regexpfield::command {}

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

# OPTION: -focuscommand

#

# Command associated upon detection of focus.

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

configbody iwidgets::Regexpfield::focuscommand {}

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

# OPTION: -regexp

#

# Specify a regular expression to use in performing validation

# of the content of the entry widget.

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

configbody iwidgets::Regexpfield::regexp {

}

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

# OPTION: -invalid

#

# Specify a command to executed should the current Regexpfield contents

# be proven invalid.

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

configbody iwidgets::Regexpfield::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::Regexpfield::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::Regexpfield::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"

        }

    }

}

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

# OPTION: -nocase

#

# Specifies whether or not lowercase characters can match either

# lowercase or uppercase letters in string.

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

configbody iwidgets::Regexpfield::nocase {

    switch $itk_option(-nocase) {

        }

        default {

            error "bad nocase option \"$itk_option(-nocase)\":\

                    should be 0 or 1"

        }

    }

}

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

#                            METHODS

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

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

# METHOD: childsite

#

# Returns the path name of the child site widget.

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

body iwidgets::Regexpfield::childsite {} {

    return $itk_component(efchildsite)

}

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

# METHOD: get

#

# Thin wrap of the standard entry widget get method.

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

body iwidgets::Regexpfield::get {} {

    return [$itk_component(entry) get]

}

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

# METHOD: delete

#

# Thin wrap of the standard entry widget delete method.

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

body iwidgets::Regexpfield::delete {args} {

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

}

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

# METHOD: icursor

#

# Thin wrap of the standard entry widget icursor method.

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

body iwidgets::Regexpfield::icursor {args} {

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

}

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

# METHOD: index

#

# Thin wrap of the standard entry widget index method.

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

body iwidgets::Regexpfield::index {args} {

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

}

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

# METHOD: insert

#

# Thin wrap of the standard entry widget index method.

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

body iwidgets::Regexpfield::insert {args} {

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

}

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

# METHOD: scan

#

# Thin wrap of the standard entry widget scan method.

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

body iwidgets::Regexpfield::scan {args} {

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

}

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

# METHOD: selection

#

# Thin wrap of the standard entry widget selection method.

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

body iwidgets::Regexpfield::selection {args} {

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

}

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

# METHOD: xview

#

# Thin wrap of the standard entry widget xview method.

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

body iwidgets::Regexpfield::xview {args} {

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

}

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

# METHOD: clear

#

# Delete the current entry contents.

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

body iwidgets::Regexpfield::clear {} {

    $itk_component(entry) delete 0 end

    icursor 0

}

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

# PRIVATE METHOD: _peek char

#

# The peek procedure returns the value of the Regexpfield with the

# char inserted at the insert position.

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

body iwidgets::Regexpfield::_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]

    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::Regexpfield::_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::Regexpfield::_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

        }

    }

    set flags ""

    #

    # Get the new value of the Regexpfield with the char inserted at the

    # insert position.

    #

    # If the new value doesn't match up with the pattern stored in the

    # -regexp option, then the invalid procedure is called.

    #

    # If the value of the "-nocase" option is true, then add the

    # "-nocase" flag to the list of flags.

    #

    set newVal [_peek $char]

    if {$itk_option(-nocase)} {

        set valid [::regexp -nocase -- $itk_option(-regexp) $newVal]

    } else {

        set valid [::regexp $itk_option(-regexp) $newVal]

    }

    if {!$valid} {

        uplevel #0 $itk_option(-invalid)

        return -code break 0

    }

    return -code continue 1

}