]> git.zerfleddert.de Git - micropolis/blob - res/text.tcl
src/tclx/tkucbsrc/makefile: Micropolis build fixes for recent macOS
[micropolis] / res / text.tcl
1 # text.tcl --
2 #
3 # This file contains Tcl procedures used to manage Tk entries.
4 #
5 # $Header: /user6/ouster/wish/scripts/RCS/text.tcl,v 1.2 92/07/16 16:26:33 ouster Exp $ SPRITE (Berkeley)
6 #
7 # Copyright 1992 Regents of the University of California
8 # Permission to use, copy, modify, and distribute this
9 # software and its documentation for any purpose and without
10 # fee is hereby granted, provided that this copyright
11 # notice appears in all copies. The University of California
12 # makes no representations about the suitability of this
13 # software for any purpose. It is provided "as is" without
14 # express or implied warranty.
15 #
16
17 # $tk_priv(selectMode@$w) holds one of "char", "word", or "line" to
18 # indicate which selection mode is active.
19
20 # The procedure below is invoked when dragging one end of the selection.
21 # The arguments are the text window name and the index of the character
22 # that is to be the new end of the selection.
23
24 proc tk_textSelectTo {w x {y ""}} {
25 global tk_priv
26 if {$y != ""} {
27 set index @$x,$y
28 } else {
29 set index $x
30 }
31
32 if {![info exists tk_priv(selectMode@$w)]} {
33 set tk_priv(selectMode@$w) "char"
34 }
35 case $tk_priv(selectMode@$w) {
36 char {
37 if [$w compare $index < anchor] {
38 set first $index
39 set last anchor
40 } else {
41 set first anchor
42 set last [$w index $index+1c]
43 }
44 }
45 word {
46 if [$w compare $index < anchor] {
47 set first [$w index "$index wordstart"]
48 set last [$w index "anchor wordend"]
49 } else {
50 set first [$w index "anchor wordstart"]
51 set last [$w index "$index wordend"]
52 }
53 }
54 line {
55 if [$w compare $index < anchor] {
56 set first [$w index "$index linestart"]
57 set last [$w index "anchor lineend + 1c"]
58 } else {
59 set first [$w index "anchor linestart"]
60 set last [$w index "$index lineend + 1c"]
61 }
62 }
63 }
64 $w tag remove sel 0.0 $first
65 $w tag add sel $first $last
66 $w tag remove sel $last end
67 }
68
69 # The procedure below is invoked to backspace over one character in
70 # a text widget. The name of the widget is passed as argument.
71
72 proc tk_textBackspace w {
73 catch {$w delete insert-1c insert}
74 }
75
76 # The procedure below compares three indices, a, b, and c. Index b must
77 # be less than c. The procedure returns 1 if a is closer to b than to c,
78 # and 0 otherwise. The "w" argument is the name of the text widget in
79 # which to do the comparison.
80
81 proc tk_textIndexCloser {w a b c} {
82 set a [$w index $a]
83 set b [$w index $b]
84 set c [$w index $c]
85 if [$w compare $a <= $b] {
86 return 1
87 }
88 if [$w compare $a >= $c] {
89 return 0
90 }
91 scan $a "%d.%d" lineA chA
92 scan $b "%d.%d" lineB chB
93 scan $c "%d.%d" lineC chC
94 if {$chC == 0} {
95 incr lineC -1
96 set chC [string length [$w get $lineC.0 $lineC.end]]
97 }
98 if {$lineB != $lineC} {
99 return [expr {($lineA-$lineB) < ($lineC-$lineA)}]
100 }
101 return [expr {($chA-$chB) < ($chC-$chA)}]
102 }
103
104 # The procedure below is called to reset the selection anchor to
105 # whichever end is FARTHEST from the index argument.
106
107 proc tk_textResetAnchor {w x y} {
108 global tk_priv
109 set index @$x,$y
110 if {[$w tag ranges sel] == ""} {
111 set tk_priv(selectMode@$w) char
112 $w mark set anchor $index
113 return
114 }
115 if [tk_textIndexCloser $w $index sel.first sel.last] {
116 if {![info exists tk_priv(selectMode@$w)]} {
117 set tk_priv(selectMode@$w) "char"
118 }
119 if {$tk_priv(selectMode@$w) == "char"} {
120 $w mark set anchor sel.last
121 } else {
122 $w mark set anchor sel.last-1c
123 }
124 } else {
125 $w mark set anchor sel.first
126 }
127 }
128
129 proc tk_textDown {w x y} {
130 global tk_priv
131 set tk_priv(selectMode@$w) char
132 $w mark set insert @$x,$y
133 $w mark set anchor insert
134 if {[lindex [$w config -state] 4] == "normal"} {focus $w}
135 }
136
137 proc tk_textDoubleDown {w x y} {
138 global tk_priv
139 set tk_priv(selectMode@$w) word
140 $w mark set insert "@$x,$y wordstart"
141 tk_textSelectTo $w insert
142 }
143
144 proc tk_textTripleDown {w x y} {
145 global tk_priv
146 set tk_priv(selectMode@$w) line
147 $w mark set insert "@$x,$y linestart"
148 tk_textSelectTo $w insert
149 }
150
151 proc tk_textAdjustTo {w x y} {
152 tk_textResetAnchor $w $x $y
153 tk_textSelectTo $w $x $y
154 }
155
156 proc tk_textKeyPress {w a} {
157 if {"$a" != ""} {
158 $w insert insert $a
159 $w yview -pickplace insert
160 }
161 }
162
163 proc tk_textReturnPress {w} {
164 $w insert insert \n
165 $w yview -pickplace insert
166 }
167
168 proc tk_textDelPress {w} {
169 tk_textBackspace $w
170 $w yview -pickplace insert
171 }
172
173 proc tk_textCutPress {w} {
174 catch {$w delete sel.first sel.last}
175 }
176
177 proc tk_textCopyPress {w} {
178 set sel ""
179 catch {set sel [selection -window $w get]}
180 $w insert $sel
181 $w yview -pickplace insert
182 }
183
184
Impressum, Datenschutz