|
428
|
1 ;;; text-props.el --- implements properties of characters
|
|
|
2
|
|
|
3 ;; Copyright (C) 1993-4, 1997 Free Software Foundation, Inc.
|
|
|
4 ;; Copyright (C) 1995 Amdahl Corporation.
|
|
|
5 ;; Copyright (C) 1995 Ben Wing.
|
|
|
6
|
|
|
7 ;; Author: Jamie Zawinski <jwz@jwz.org>
|
|
|
8 ;; Maintainer: XEmacs Development Team
|
|
|
9 ;; Keywords: extensions, wp, faces, dumped
|
|
|
10
|
|
|
11 ;; This file is part of XEmacs.
|
|
|
12
|
|
|
13 ;; XEmacs is free software; you can redistribute it and/or modify
|
|
|
14 ;; it under the terms of the GNU General Public License as published by
|
|
|
15 ;; the Free Software Foundation; either version 2, or (at your option)
|
|
|
16 ;; any later version.
|
|
|
17
|
|
|
18 ;; XEmacs is distributed in the hope that it will be useful,
|
|
|
19 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
|
20 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
|
|
21 ;; GNU General Public License for more details.
|
|
|
22
|
|
|
23 ;; You should have received a copy of the GNU General Public License
|
|
|
24 ;; along with XEmacs; see the file COPYING. If not, write to the Free
|
|
|
25 ;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
|
|
|
26 ;; 02111-1307, USA.
|
|
|
27
|
|
|
28 ;;; Synched up with: Not in FSF.
|
|
|
29
|
|
|
30 ;;; Commentary:
|
|
|
31
|
|
|
32 ;; This file is dumped with XEmacs.
|
|
|
33
|
|
|
34 ;; This is a nearly complete implementation of the FSF19 text properties API.
|
|
|
35 ;; Please let me know if you notice any differences in behavior between
|
|
|
36 ;; this implementation and the FSF implementation.
|
|
|
37
|
|
|
38 ;; However, keep in mind that this interface has been implemented because it
|
|
|
39 ;; is useful. Compatibility with code written for FSF19 is a secondary goal
|
|
|
40 ;; to having a clean and useful interface.
|
|
|
41
|
|
|
42 ;; The cruftier parts of the FSF API, such as the special handling of
|
|
|
43 ;; properties like `mouse-face', `front-sticky', and other properties whose
|
|
|
44 ;; value is a list of names of *other* properties set at this position, are
|
|
|
45 ;; not implemented. The reason for this is that if you feel you need that
|
|
|
46 ;; kind of functionality, it's a good hint that you should be using extents
|
|
|
47 ;; instead of text properties.
|
|
|
48
|
|
|
49 ;; When should I use Text Properties, and when should I use Extents?
|
|
|
50 ;; ==================================================================
|
|
|
51
|
|
|
52 ;; If you are putting a `button' or `hyperlink' of some kind into a buffer,
|
|
|
53 ;; the most natural interface is one which deals with properties of regions
|
|
|
54 ;; with explicit endpoints that behave more-or-less like markers. That is
|
|
|
55 ;; what `make-extent', `extent-at', and `extent-property' are for.
|
|
|
56
|
|
|
57 ;; If you are dealing with styles of text, where things do not have explicit
|
|
|
58 ;; endpoints (as is done in font-lock.el and shell-font.el) or if you want to
|
|
|
59 ;; partition a buffer (that is, change some attribute of a range from one
|
|
|
60 ;; value to another without disturbing the properties outside of that range)
|
|
|
61 ;; then an interface that deals with properties of characters may be most
|
|
|
62 ;; natural.
|
|
|
63
|
|
|
64 ;; Another way of thinking of it is, do you care where the endpoints of the
|
|
|
65 ;; region are? If you do, then you should use extents. If it's ok for the
|
|
|
66 ;; region to become divided, and for two regions with identical properties to
|
|
|
67 ;; be merged into one region, then you might want to use text properties.
|
|
|
68
|
|
|
69 ;; Some applications want the attributes they add to be copied by the killing
|
|
|
70 ;; and yanking commands, and some do not. This is orthogonal to whether text
|
|
|
71 ;; properties or extents are used. Remember that text properties are
|
|
|
72 ;; implemented in terms of extents, so anything you can do with one you can
|
|
|
73 ;; do with the other. It's just a matter of which way of creating and
|
|
|
74 ;; managing them is most appropriate to your application.
|
|
|
75
|
|
|
76 ;; Implementation details:
|
|
|
77 ;; =======================
|
|
|
78
|
|
|
79 ;; This package uses extents with a non-nil 'text-prop property. It assumes
|
|
|
80 ;; free reign over the endpoints of any extent with that property. It will
|
|
|
81 ;; not alter any extent which does not have that property.
|
|
|
82
|
|
|
83 ;; Right now, the text-property functions create one extent for each distinct
|
|
|
84 ;; property; that is, if a range of text has two text-properties on it, there
|
|
|
85 ;; will be two extents. As the set of text-properties is going to be small,
|
|
|
86 ;; this is probably not a big deal. It would be possible to share extents.
|
|
|
87
|
|
|
88 ;; One tricky bit is that undo/kill/yank must be made to not fragment things:
|
|
|
89 ;; these extents must not be allowed to overlap. We accomplish this by using
|
|
|
90 ;; a custom `paste-function' property on the extents.
|
|
|
91
|
|
|
92 ;; shell-font.el and font-lock.el could put-text-property to attach fonts to
|
|
|
93 ;; the buffer. However, what these packages are interested in is the
|
|
|
94 ;; efficient extent partitioning behavior which this code exhibits, not the
|
|
|
95 ;; duplicability aspect of it. In fact, either of these packages could be
|
|
|
96 ;; implemented by creating a one-character non-expandable extent for each
|
|
|
97 ;; character in the buffer, except that that would be extremely wasteful of
|
|
|
98 ;; memory. (Redisplay performance would be fine, however.)
|
|
|
99
|
|
|
100 ;; If these packages were to use put-text-property to make the extents, then
|
|
|
101 ;; when one copied text from a shell buffer or a font-locked source buffer
|
|
|
102 ;; and pasted it somewhere else (a sendmail buffer, or a buffer not in
|
|
|
103 ;; font-lock mode) then the fonts would follow, and there's no easy way to
|
|
|
104 ;; get rid of them (other than pounding out a call to put-text-property by
|
|
|
105 ;; hand.) This is annoying. Maybe it wouldn't be so annoying if there was a
|
|
|
106 ;; more general set of commands for handling styles of text (in fact, if
|
|
|
107 ;; there were such a thing, copying the fonts would probably be exactly what
|
|
|
108 ;; one wanted) but we aren't there yet. So these packages use the interface
|
|
|
109 ;; of `put-nonduplicable-text-property' which is the same, except that it
|
|
|
110 ;; doesn't make duplicable extents.
|
|
|
111
|
|
|
112 ;; `put-text-property' and `put-nonduplicable-text-property' don't get along:
|
|
|
113 ;; they will interfere with each other, reusing each others' extents without
|
|
|
114 ;; checking that the "duplicableness" is correct. This is a bug, but it's
|
|
|
115 ;; one that I don't care enough to fix this right now.
|
|
|
116
|
|
|
117 ;;; Code:
|
|
|
118
|
|
|
119 (defun set-text-properties (start end props &optional buffer-or-string)
|
|
|
120 "You should NEVER use this function. It is ideologically blasphemous.
|
|
|
121 It is provided only to ease porting of broken FSF Emacs programs.
|
|
|
122 Instead, use `remove-text-properties' to remove the specific properties
|
|
|
123 you do not want.
|
|
|
124
|
|
|
125 Completely replace properties of text from START to END.
|
|
|
126 The third argument PROPS is the new property list.
|
|
|
127 The optional fourth argument, BUFFER-OR-STRING,
|
|
|
128 is the string or buffer containing the text."
|
|
|
129 (map-extents #'(lambda (extent ignored)
|
|
|
130 ;; #### dmoore - shouldn't this use
|
|
|
131 ;; (extent-start-position extent)
|
|
|
132 ;; (extent-end-position extent)
|
|
|
133 (remove-text-properties start end
|
|
|
134 (list (extent-property extent
|
|
|
135 'text-prop)
|
|
|
136 nil)
|
|
|
137 buffer-or-string)
|
|
|
138 nil)
|
|
|
139 buffer-or-string start end nil nil 'text-prop)
|
|
|
140 (add-text-properties start end props buffer-or-string))
|
|
|
141
|
|
|
142
|
|
|
143 ;;; The following functions can probably stay in lisp, since they're so simple.
|
|
|
144
|
|
|
145 ;(defun get-text-property (pos prop &optional buffer)
|
|
|
146 ; "Returns the value of the PROP property at the given position."
|
|
|
147 ; (let ((e (extent-at pos buffer prop)))
|
|
|
148 ; (if e
|
|
|
149 ; (extent-property e prop)
|
|
|
150 ; nil)))
|
|
|
151
|
|
|
152 (defun extent-properties-at-1 (position buffer-or-string text-props-only)
|
|
|
153 (let ((extent nil)
|
|
|
154 (props nil)
|
|
|
155 new-props)
|
|
|
156 (while (setq extent (extent-at position buffer-or-string
|
|
|
157 (if text-props-only 'text-prop nil)
|
|
|
158 extent))
|
|
|
159 (if text-props-only
|
|
|
160 ;; Only return the one prop which the `text-prop' property points at.
|
|
|
161 (let ((prop (extent-property extent 'text-prop)))
|
|
|
162 (setq new-props (list prop (extent-property extent prop))))
|
|
|
163 ;; Return all the properties...
|
|
|
164 (setq new-props (extent-properties extent))
|
|
|
165 ;; ...but! Don't return the `begin-glyph' or `end-glyph' properties
|
|
|
166 ;; unless the position is exactly at the appropriate endpoint. Yeah,
|
|
|
167 ;; this is kind of a kludge.
|
|
|
168 ;; #### Bug, this doesn't work for end-glyphs (on end-open extents)
|
|
|
169 ;; because we've already passed the extent with the glyph by the time
|
|
|
170 ;; it's appropriate to return the glyph. We could return the end
|
|
|
171 ;; glyph one character early I guess... But then next-property-change
|
|
|
172 ;; would have to stop one character early as well. It could back up
|
|
|
173 ;; when it hit an end-glyph...
|
|
|
174 ;; #### Another bug, if there are multiple glyphs at the same position,
|
|
|
175 ;; we only see the first one.
|
|
|
176 (cond ((or (extent-begin-glyph extent) (extent-end-glyph extent))
|
|
|
177 (if (/= position (if (extent-property extent 'begin-glyph)
|
|
|
178 (extent-start-position extent)
|
|
|
179 (extent-end-position extent)))
|
|
|
180 (let ((rest new-props)
|
|
|
181 prev)
|
|
|
182 (while rest
|
|
|
183 (cond ((or (eq (car rest) 'begin-glyph)
|
|
|
184 (eq (car rest) 'end-glyph))
|
|
|
185 (if prev
|
|
|
186 (setcdr prev (cdr (cdr rest)))
|
|
|
187 (setq new-props (cdr (cdr new-props))))
|
|
|
188 (setq rest nil)))
|
|
|
189 (setq prev rest
|
|
|
190 rest (cdr rest))))))))
|
|
|
191 (cond ((null props)
|
|
|
192 (setq props new-props))
|
|
|
193 (t
|
|
|
194 (while new-props
|
|
|
195 (or (getf props (car new-props))
|
|
|
196 (setq props (cons (car new-props)
|
|
|
197 (cons (car (cdr new-props))
|
|
|
198 props))))
|
|
|
199 (setq new-props (cdr (cdr new-props)))))))
|
|
|
200 props))
|
|
|
201
|
|
|
202 (defun extent-properties-at (position &optional object)
|
|
|
203 "Return the properties of the character at the given position in OBJECT.
|
|
|
204 OBJECT is either a string or a buffer. The properties of overlapping
|
|
|
205 extents are merged. The returned value is a property list, some of
|
|
|
206 which may be shared with other structures. You must not modify it.
|
|
|
207
|
|
|
208 If POSITION is at the end of OBJECT, the value is nil.
|
|
|
209
|
|
|
210 This returns all properties on all extents.
|
|
|
211 See also `text-properties-at'."
|
|
|
212 (extent-properties-at-1 position object nil))
|
|
|
213
|
|
|
214 (defun text-properties-at (position &optional object)
|
|
|
215 "Return the properties of the character at the given position in OBJECT.
|
|
|
216 OBJECT is either a string or a buffer. The properties of overlapping
|
|
|
217 extents are merged. The returned value is a property list, some of
|
|
|
218 which may be shared with other structures. You must not modify it.
|
|
|
219
|
|
|
220 If POSITION is at the end of OBJECT, the value is nil.
|
|
|
221
|
|
|
222 This returns only those properties added with `put-text-property'.
|
|
|
223 See also `extent-properties-at'."
|
|
|
224 (extent-properties-at-1 position object t))
|
|
|
225
|
|
|
226 (defun text-property-any (start end prop value &optional buffer-or-string)
|
|
|
227 "Check text from START to END to see if PROP is ever `eq' to VALUE.
|
|
|
228 If so, return the position of the first character whose PROP is `eq'
|
|
|
229 to VALUE. Otherwise return nil.
|
|
|
230 The optional fifth argument, BUFFER-OR-STRING, is the buffer or string
|
|
|
231 containing the text and defaults to the current buffer."
|
|
|
232 (while (and start (< start end)
|
|
|
233 (not (eq value (get-text-property start prop buffer-or-string))))
|
|
|
234 (setq start (next-single-property-change start prop buffer-or-string end)))
|
|
|
235 ;; we have to insert a special check for end due to the illogical
|
|
|
236 ;; definition of next-single-property-change (blame FSF for this).
|
|
1275
|
237 (if (and start (>= start end)) nil start))
|
|
428
|
238
|
|
|
239 (defun text-property-not-all (start end prop value &optional buffer-or-string)
|
|
|
240 "Check text from START to END to see if PROP is ever not `eq' to VALUE.
|
|
|
241 If so, return the position of the first character whose PROP is not
|
|
|
242 `eq' to VALUE. Otherwise, return nil.
|
|
|
243 The optional fifth argument, BUFFER-OR-STRING, is the buffer or string
|
|
|
244 containing the text and defaults to the current buffer."
|
|
|
245 (if (not (eq value (get-text-property start prop buffer-or-string)))
|
|
|
246 start
|
|
|
247 (let ((retval (next-single-property-change start prop
|
|
|
248 buffer-or-string end)))
|
|
|
249 ;; we have to insert a special check for end due to the illogical
|
|
|
250 ;; definition of previous-single-property-change (blame FSF for this).
|
|
1275
|
251 (if (and retval (>= retval end)) nil retval))))
|
|
428
|
252
|
|
|
253 ;; Older versions that only work sometimes (when VALUE is non-nil
|
|
|
254 ;; for text-property-any, and maybe only when VALUE is nil for
|
|
|
255 ;; text-property-not-all). They might be faster in those cases,
|
|
|
256 ;; but that's not obvious.
|
|
|
257
|
|
|
258 ;(defun text-property-any (start end prop value &optional buffer)
|
|
|
259 ; "Check text from START to END to see if PROP is ever `eq' to VALUE.
|
|
|
260 ;If so, return the position of the first character whose PROP is `eq'
|
|
|
261 ;to VALUE. Otherwise return nil."
|
|
|
262 ; ;; #### what should (text-property-any x y 'foo nil) return when there
|
|
|
263 ; ;; is no foo property between x and y? Either t or nil seems sensible,
|
|
|
264 ; ;; since a character with a property of nil is indistinguishable from
|
|
|
265 ; ;; a character without that property set.
|
|
|
266 ; (map-extents
|
|
|
267 ; #'(lambda (e ignore)
|
|
|
268 ; (if (eq value (extent-property e prop))
|
|
|
269 ; ;; return non-nil to stop mapping
|
|
|
270 ; (max start (extent-start-position e))
|
|
|
271 ; nil))
|
|
|
272 ; nil start end buffer))
|
|
|
273 ;
|
|
|
274 ;(defun text-property-not-all (start end prop value &optional buffer)
|
|
|
275 ; "Check text from START to END to see if PROP is ever not `eq' to VALUE.
|
|
|
276 ;If so, return the position of the first character whose PROP is not
|
|
|
277 ;`eq' to VALUE. Otherwise, return nil."
|
|
|
278 ; (let (maxend)
|
|
|
279 ; (map-extents
|
|
|
280 ; #'(lambda (e ignore)
|
|
|
281 ; ;;### no, actually, this is harder. We need to collect all props
|
|
|
282 ; ;; for a given character, and then determine whether no extent
|
|
|
283 ; ;; contributes the given value. Doing this without consing lots
|
|
|
284 ; ;; of lists is the tricky part.
|
|
|
285 ; (if (eq value (extent-property e prop))
|
|
|
286 ; (progn
|
|
|
287 ; (setq maxend (extent-end-position e))
|
|
|
288 ; nil)
|
|
|
289 ; (max start maxend)))
|
|
|
290 ; nil start end buffer)))
|
|
|
291
|
|
|
292 (defun next-property-change (pos &optional buffer-or-string limit)
|
|
|
293 "Return the position of next property change.
|
|
|
294 Scans forward from POS in BUFFER-OR-STRING (defaults to the current buffer)
|
|
|
295 until it finds a change in some text property, then returns the position of
|
|
|
296 the change.
|
|
|
297 Returns nil if the properties remain unchanged all the way to the end.
|
|
|
298 If the value is non-nil, it is a position greater than POS, never equal.
|
|
|
299 If the optional third argument LIMIT is non-nil, don't search
|
|
|
300 past position LIMIT; return LIMIT if nothing is found before LIMIT.
|
|
|
301 If two or more extents with conflicting non-nil values for a property overlap
|
|
|
302 a particular character, it is undefined which value is considered to be
|
|
|
303 the value of the property. (Note that this situation will not happen if
|
|
|
304 you always use the text-property primitives.)"
|
|
|
305 (let ((limit-was-nil (null limit)))
|
|
|
306 (or limit (setq limit (if (bufferp buffer-or-string)
|
|
|
307 (point-max buffer-or-string)
|
|
|
308 (length buffer-or-string))))
|
|
|
309 (let ((value (extent-properties-at pos buffer-or-string)))
|
|
|
310 (while
|
|
|
311 (and (< (setq pos (next-extent-change pos buffer-or-string)) limit)
|
|
|
312 (plists-eq value (extent-properties-at pos buffer-or-string)))))
|
|
|
313 (if (< pos limit) pos
|
|
|
314 (if limit-was-nil nil
|
|
|
315 limit))))
|
|
|
316
|
|
|
317 (defun previous-property-change (pos &optional buffer-or-string limit)
|
|
|
318 "Return the position of previous property change.
|
|
|
319 Scans backward from POS in BUFFER-OR-STRING (defaults to the current buffer)
|
|
|
320 until it finds a change in some text property, then returns the position of
|
|
|
321 the change.
|
|
|
322 Returns nil if the properties remain unchanged all the way to the beginning.
|
|
|
323 If the value is non-nil, it is a position less than POS, never equal.
|
|
|
324 If the optional third argument LIMIT is non-nil, don't search back
|
|
|
325 past position LIMIT; return LIMIT if nothing is found until LIMIT.
|
|
|
326 If two or more extents with conflicting non-nil values for a property overlap
|
|
|
327 a particular character, it is undefined which value is considered to be
|
|
|
328 the value of the property. (Note that this situation will not happen if
|
|
|
329 you always use the text-property primitives.)"
|
|
|
330 (let ((limit-was-nil (null limit)))
|
|
|
331 (or limit (setq limit (if (bufferp buffer-or-string)
|
|
|
332 (point-min buffer-or-string)
|
|
|
333 0)))
|
|
|
334 (let ((value (extent-properties-at (1- pos) buffer-or-string)))
|
|
|
335 (while
|
|
|
336 (and (> (setq pos (previous-extent-change pos buffer-or-string))
|
|
|
337 limit)
|
|
|
338 (plists-eq value (extent-properties-at (1- pos)
|
|
|
339 buffer-or-string)))))
|
|
|
340 (if (> pos limit) pos
|
|
|
341 (if limit-was-nil nil
|
|
|
342 limit))))
|
|
|
343
|
|
|
344 (defun text-property-bounds (pos prop &optional object at-flag)
|
|
|
345 "Return the bounds of property PROP at POS.
|
|
|
346 This returns a cons (START . END) of the largest region of text containing
|
|
|
347 POS which has a non-nil value for PROP. The return value is nil if POS
|
|
|
348 does not have a non-nil value for PROP. OBJECT specifies the buffer
|
|
|
349 or string to search in. Optional arg AT-FLAG controls what \"at POS\"
|
|
|
350 means, and has the same meaning as for `extent-at'."
|
|
|
351 (or object (setq object (current-buffer)))
|
|
|
352 (and (get-char-property pos prop object at-flag)
|
|
|
353 (let ((begin (if (stringp object) 0 (point-min object)))
|
|
|
354 (end (if (stringp object) (length object) (point-max object))))
|
|
|
355 (cons (previous-single-property-change (1+ pos) prop object begin)
|
|
|
356 (next-single-property-change pos prop object end)))))
|
|
|
357
|
|
|
358 (defun next-text-property-bounds (count pos prop &optional object)
|
|
|
359 "Return the COUNTth bounded property region of property PROP after POS.
|
|
|
360 If COUNT is less than zero, search backwards. This returns a cons
|
|
|
361 \(START . END) of the COUNTth maximal region of text that begins after POS
|
|
|
362 \(starts before POS) and has a non-nil value for PROP. If there aren't
|
|
|
363 that many regions, nil is returned. OBJECT specifies the buffer or
|
|
|
364 string to search in."
|
|
|
365 (or object (setq object (current-buffer)))
|
|
|
366 (let ((begin (if (stringp object) 0 (point-min object)))
|
|
|
367 (end (if (stringp object) (length object) (point-max object))))
|
|
|
368 (catch 'hit-end
|
|
|
369 (if (> count 0)
|
|
|
370 (progn
|
|
|
371 (while (> count 0)
|
|
|
372 (if (>= pos end)
|
|
|
373 (throw 'hit-end nil)
|
|
|
374 (and (get-char-property pos prop object)
|
|
|
375 (setq pos (next-single-property-change pos prop
|
|
|
376 object end)))
|
|
|
377 (setq pos (next-single-property-change pos prop object end)))
|
|
|
378 (setq count (1- count)))
|
|
|
379 (and (< pos end)
|
|
|
380 (cons pos (next-single-property-change pos prop object end))))
|
|
|
381 (while (< count 0)
|
|
|
382 (if (<= pos begin)
|
|
|
383 (throw 'hit-end nil)
|
|
|
384 (and (get-char-property (1- pos) prop object)
|
|
|
385 (setq pos (previous-single-property-change pos prop
|
|
|
386 object begin)))
|
|
|
387 (setq pos (previous-single-property-change pos prop object
|
|
|
388 begin)))
|
|
|
389 (setq count (1+ count)))
|
|
|
390 (and (> pos begin)
|
|
|
391 (cons (previous-single-property-change pos prop object begin)
|
|
|
392 pos))))))
|
|
|
393
|
|
|
394 ;(defun detach-all-extents (&optional buffer)
|
|
|
395 ; (map-extents #'(lambda (x i) (detach-extent x) nil)
|
|
|
396 ; buffer))
|
|
|
397
|
|
|
398
|
|
|
399 (provide 'text-props)
|
|
|
400
|
|
|
401 ;;; text-props.el ends here
|
