entryfield.itk

windows下的GDB insight前端

# ------------------------------------------------------------------
#                            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: [e-mail]), 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
    }
  }
}