75 lines
2.5 KiB
Tcl
75 lines
2.5 KiB
Tcl
|
# entry.tcl --
|
||
|
|
#
|
||
|
|
# This file contains Tcl procedures used to manage Tk entries.
|
||
|
|
#
|
||
|
|
# $Header: /user6/ouster/wish/library/RCS/entry.tcl,v 1.7 93/10/18 17:15:23 ouster Exp $ SPRITE (Berkeley)
|
||
|
|
#
|
||
|
|
# Copyright (c) 1992-1993 The Regents of the University of California.
|
||
|
|
# All rights reserved.
|
||
|
|
#
|
||
|
|
# Permission is hereby granted, without written agreement and without
|
||
|
|
# license or royalty fees, to use, copy, modify, and distribute this
|
||
|
|
# software and its documentation for any purpose, provided that the
|
||
|
|
# above copyright notice and the following two paragraphs appear in
|
||
|
|
# all copies of this software.
|
||
|
|
#
|
||
|
|
# IN NO EVENT SHALL THE UNIVERSITY OF CALIFORNIA BE LIABLE TO ANY PARTY FOR
|
||
|
|
# DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES ARISING OUT
|
||
|
|
# OF THE USE OF THIS SOFTWARE AND ITS DOCUMENTATION, EVEN IF THE UNIVERSITY OF
|
||
|
|
# CALIFORNIA HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
|
||
|
|
#
|
||
|
|
# THE UNIVERSITY OF CALIFORNIA SPECIFICALLY DISCLAIMS ANY WARRANTIES,
|
||
|
|
# INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
|
||
|
|
# AND FITNESS FOR A PARTICULAR PURPOSE. THE SOFTWARE PROVIDED HEREUNDER IS
|
||
|
|
# ON AN "AS IS" BASIS, AND THE UNIVERSITY OF CALIFORNIA HAS NO OBLIGATION TO
|
||
|
|
# PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS.
|
||
|
|
#
|
||
|
|
|
||
|
|
# The procedure below is invoked to backspace over one character
|
||
|
|
# in an entry widget. The name of the widget is passed as argument.
|
||
|
|
|
||
|
|
proc tk_entryBackspace w {
|
||
|
|
set x [expr {[$w index insert] - 1}]
|
||
|
|
if {$x != -1} {$w delete $x}
|
||
|
|
}
|
||
|
|
|
||
|
|
# The procedure below is invoked to backspace over one word in an
|
||
|
|
# entry widget. The name of the widget is passed as argument.
|
||
|
|
|
||
|
|
proc tk_entryBackword w {
|
||
|
|
set string [$w get]
|
||
|
|
set curs [expr [$w index insert]-1]
|
||
|
|
if {$curs < 0} return
|
||
|
|
for {set x $curs} {$x > 0} {incr x -1} {
|
||
|
|
if {([string first [string index $string $x] " \t"] < 0)
|
||
|
|
&& ([string first [string index $string [expr $x-1]] " \t"]
|
||
|
|
>= 0)} {
|
||
|
|
break
|
||
|
|
}
|
||
|
|
}
|
||
|
|
$w delete $x $curs
|
||
|
|
}
|
||
|
|
|
||
|
|
# The procedure below is invoked after insertions. If the caret is not
|
||
|
|
# visible in the window then the procedure adjusts the entry's view to
|
||
|
|
# bring the caret back into the window again. Also, try to keep at
|
||
|
|
# least one character visible to the left of the caret.
|
||
|
|
|
||
|
|
proc tk_entrySeeCaret w {
|
||
|
|
set c [$w index insert]
|
||
|
|
set left [$w index @0]
|
||
|
|
if {$left >= $c} {
|
||
|
|
if {$c > 0} {
|
||
|
|
$w view [expr $c-1]
|
||
|
|
} else {
|
||
|
|
$w view $c
|
||
|
|
}
|
||
|
|
return
|
||
|
|
}
|
||
|
|
set x [expr [winfo width $w] - [lindex [$w config -bd] 4] - 1]
|
||
|
|
while {([$w index @$x] < $c) && ($left < $c)} {
|
||
|
|
set left [expr $left+1]
|
||
|
|
$w view $left
|
||
|
|
}
|
||
|
|
}
|