Reformatted.
[chise/xemacs-chise.git.1] / lisp / text-props.el
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 \f
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).
237   (if (and start (>= start end)) nil start))
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).
251       (if (and retval (>= retval end)) nil retval))))
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