127 lines
3.7 KiB
Tcl
127 lines
3.7 KiB
Tcl
# text.tcl --
|
|
#
|
|
# This file contains Tcl procedures used to manage Tk entries.
|
|
#
|
|
# $Header: /user6/ouster/wish/library/RCS/text.tcl,v 1.4 93/10/23 16:21:12 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 when dragging one end of the selection.
|
|
# The arguments are the text window name and the index of the character
|
|
# that is to be the new end of the selection.
|
|
|
|
proc tk_textSelectTo {w index} {
|
|
global tk_priv
|
|
|
|
if [catch {$w index anchor}] {
|
|
$w mark set anchor $index
|
|
}
|
|
case $tk_priv(selectMode) {
|
|
char {
|
|
if [$w compare $index < anchor] {
|
|
set first $index
|
|
set last anchor
|
|
} else {
|
|
set first anchor
|
|
set last [$w index $index+1c]
|
|
}
|
|
}
|
|
word {
|
|
if [$w compare $index < anchor] {
|
|
set first [$w index "$index wordstart"]
|
|
set last [$w index "anchor wordend"]
|
|
} else {
|
|
set first [$w index "anchor wordstart"]
|
|
set last [$w index "$index wordend"]
|
|
}
|
|
}
|
|
line {
|
|
if [$w compare $index < anchor] {
|
|
set first [$w index "$index linestart"]
|
|
set last [$w index "anchor lineend + 1c"]
|
|
} else {
|
|
set first [$w index "anchor linestart"]
|
|
set last [$w index "$index lineend + 1c"]
|
|
}
|
|
}
|
|
}
|
|
$w tag remove sel 0.0 $first
|
|
$w tag add sel $first $last
|
|
$w tag remove sel $last end
|
|
}
|
|
|
|
# The procedure below is invoked to backspace over one character in
|
|
# a text widget. The name of the widget is passed as argument.
|
|
|
|
proc tk_textBackspace w {
|
|
$w delete insert-1c insert
|
|
}
|
|
|
|
# The procedure below compares three indices, a, b, and c. Index b must
|
|
# be less than c. The procedure returns 1 if a is closer to b than to c,
|
|
# and 0 otherwise. The "w" argument is the name of the text widget in
|
|
# which to do the comparison.
|
|
|
|
proc tk_textIndexCloser {w a b c} {
|
|
set a [$w index $a]
|
|
set b [$w index $b]
|
|
set c [$w index $c]
|
|
if [$w compare $a <= $b] {
|
|
return 1
|
|
}
|
|
if [$w compare $a >= $c] {
|
|
return 0
|
|
}
|
|
scan $a "%d.%d" lineA chA
|
|
scan $b "%d.%d" lineB chB
|
|
scan $c "%d.%d" lineC chC
|
|
if {$chC == 0} {
|
|
incr lineC -1
|
|
set chC [string length [$w get $lineC.0 $lineC.end]]
|
|
}
|
|
if {$lineB != $lineC} {
|
|
return [expr {($lineA-$lineB) < ($lineC-$lineA)}]
|
|
}
|
|
return [expr {($chA-$chB) < ($chC-$chA)}]
|
|
}
|
|
|
|
# The procedure below is called to reset the selection anchor to
|
|
# whichever end is FARTHEST from the index argument.
|
|
|
|
proc tk_textResetAnchor {w index} {
|
|
global tk_priv
|
|
if {[$w tag ranges sel] == ""} {
|
|
set tk_priv(selectMode) char
|
|
$w mark set anchor $index
|
|
return
|
|
}
|
|
if [tk_textIndexCloser $w $index sel.first sel.last] {
|
|
if {$tk_priv(selectMode) == "char"} {
|
|
$w mark set anchor sel.last
|
|
} else {
|
|
$w mark set anchor sel.last-1c
|
|
}
|
|
} else {
|
|
$w mark set anchor sel.first
|
|
}
|
|
}
|