1 ;;; text-props.el --- implements properties of characters
3 ;; Copyright (C) 1993-4, 1997 Free Software Foundation, Inc.
4 ;; Copyright (C) 1995 Amdahl Corporation.
5 ;; Copyright (C) 1995 Ben Wing.
7 ;; Author: Jamie Zawinski <jwz@jwz.org>
8 ;; Maintainer: XEmacs Development Team
9 ;; Keywords: extensions, wp, faces, dumped
11 ;; This file is part of XEmacs.
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)
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.
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
28 ;;; Synched up with: Not in FSF.
32 ;; This file is dumped with XEmacs.
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.
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.
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.
49 ;; When should I use Text Properties, and when should I use Extents?
50 ;; ==================================================================
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.
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
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.
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.
76 ;; Implementation details:
77 ;; =======================
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.
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.
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.
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.)
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.
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.
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
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
139 buffer-or-string start end nil nil 'text-prop)
140 (add-text-properties start end props buffer-or-string))
143 ;;; The following functions can probably stay in lisp, since they're so simple.
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)))
149 ; (extent-property e prop)
152 (defun extent-properties-at-1 (position buffer-or-string text-props-only)
156 (while (setq extent (extent-at position buffer-or-string
157 (if text-props-only 'text-prop nil)
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)
183 (cond ((or (eq (car rest) 'begin-glyph)
184 (eq (car rest) 'end-glyph))
186 (setcdr prev (cdr (cdr rest)))
187 (setq new-props (cdr (cdr new-props))))
190 rest (cdr rest))))))))
192 (setq props new-props))
195 (or (getf props (car new-props))
196 (setq props (cons (car new-props)
197 (cons (car (cdr new-props))
199 (setq new-props (cdr (cdr new-props)))))))
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.
208 If POSITION is at the end of OBJECT, the value is nil.
210 This returns all properties on all extents.
211 See also `text-properties-at'."
212 (extent-properties-at-1 position object nil))
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.
220 If POSITION is at the end of OBJECT, the value is nil.
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))
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).
237 (if (and start (>= start end)) nil start))
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)))
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).
251 (if (and retval (>= retval end)) nil retval))))
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.
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.
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))
272 ; nil start end buffer))
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."
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))
287 ; (setq maxend (extent-end-position e))
289 ; (max start maxend)))
290 ; nil start end buffer)))
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
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)))
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
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
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)
334 (let ((value (extent-properties-at (1- pos) buffer-or-string)))
336 (and (> (setq pos (previous-extent-change pos buffer-or-string))
338 (plists-eq value (extent-properties-at (1- pos)
339 buffer-or-string)))))
340 (if (> pos limit) pos
341 (if limit-was-nil nil
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)))))
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))))
374 (and (get-char-property pos prop object)
375 (setq pos (next-single-property-change pos prop
377 (setq pos (next-single-property-change pos prop object end)))
378 (setq count (1- count)))
380 (cons pos (next-single-property-change pos prop object end))))
384 (and (get-char-property (1- pos) prop object)
385 (setq pos (previous-single-property-change pos prop
387 (setq pos (previous-single-property-change pos prop object
389 (setq count (1+ count)))
391 (cons (previous-single-property-change pos prop object begin)
394 ;(defun detach-all-extents (&optional buffer)
395 ; (map-extents #'(lambda (x i) (detach-extent x) nil)
399 (provide 'text-props)
401 ;;; text-props.el ends here