Mercurial > hg > xemacs-beta
comparison lisp/utils/text-props.el @ 0:376386a54a3c r19-14
Import from CVS: tag r19-14
author | cvs |
---|---|
date | Mon, 13 Aug 2007 08:45:50 +0200 |
parents | |
children | ac2d302a0011 |
comparison
equal
deleted
inserted
replaced
-1:000000000000 | 0:376386a54a3c |
---|---|
1 ;;; text-props.el --- implements properties of characters | |
2 | |
3 ;; Copyright (C) 1993, 1994 Free Software Foundation, Inc. | |
4 ;; Copyright (C) 1995 Amdahl Corporation. | |
5 ;; Copyright (C) 1995 Ben Wing. | |
6 | |
7 ;; Keywords: extensions, wp, faces | |
8 ;; Author: Jamie Zawinski <jwz@lucid.com> | |
9 ;; Modified: Ben Wing <wing@666.com> -- many of the Lisp functions below | |
10 ;; were completely broken. | |
11 ;; | |
12 ;; This file is part of XEmacs. | |
13 | |
14 ;; XEmacs is free software; you can redistribute it and/or modify | |
15 ;; it under the terms of the GNU General Public License as published by | |
16 ;; the Free Software Foundation; either version 2, or (at your option) | |
17 ;; any later version. | |
18 | |
19 ;; XEmacs is distributed in the hope that it will be useful, | |
20 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of | |
21 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
22 ;; GNU General Public License for more details. | |
23 | |
24 ;; You should have received a copy of the GNU General Public License | |
25 ;; along with XEmacs; see the file COPYING. If not, write to | |
26 ;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. | |
27 | |
28 ;;; Synched up with: Not in FSF. | |
29 | |
30 ;;; Commentary: | |
31 | |
32 ;;; This is a nearly complete implementation of the FSF19 text properties API. | |
33 ;;; Please let me know if you notice any differences in behavior between | |
34 ;;; this implementation and the FSF implementation. | |
35 ;;; | |
36 ;;; However, keep in mind that this interface has been implemented because it | |
37 ;;; is useful. Compatibility with code written for FSF19 is a secondary goal | |
38 ;;; to having a clean and useful interface. | |
39 ;;; | |
40 ;;; The cruftier parts of the FSF API, such as the special handling of | |
41 ;;; properties like `mouse-face', `front-sticky', and other properties whose | |
42 ;;; value is a list of names of *other* properties set at this position, are | |
43 ;;; not implemented. The reason for this is that if you feel you need that | |
44 ;;; kind of functionality, it's a good hint that you should be using extents | |
45 ;;; instead of text properties. | |
46 ;;; | |
47 ;;; When should I use Text Properties, and when should I use Extents? | |
48 ;;; ================================================================== | |
49 ;;; | |
50 ;;; If you are putting a `button' or `hyperlink' of some kind into a buffer, | |
51 ;;; the most natural interface is one which deals with properties of regions | |
52 ;;; with explicit endpoints that behave more-or-less like markers. That is | |
53 ;;; what `make-extent', `extent-at', and `extent-property' are for. | |
54 ;;; | |
55 ;;; If you are dealing with styles of text, where things do not have explicit | |
56 ;;; endpoints (as is done in font-lock.el and shell-font.el) or if you want to | |
57 ;;; partition a buffer (that is, change some attribute of a range from one | |
58 ;;; value to another without disturbing the properties outside of that range) | |
59 ;;; then an interface that deals with properties of characters may be most | |
60 ;;; natural. | |
61 ;;; | |
62 ;;; Another way of thinking of it is, do you care where the endpoints of the | |
63 ;;; region are? If you do, then you should use extents. If it's ok for the | |
64 ;;; region to become divided, and for two regions with identical properties to | |
65 ;;; be merged into one region, then you might want to use text properties. | |
66 ;;; | |
67 ;;; Some applications want the attributes they add to be copied by the killing | |
68 ;;; and yanking commands, and some do not. This is orthogonal to whether text | |
69 ;;; properties or extents are used. Remember that text properties are | |
70 ;;; implemented in terms of extents, so anything you can do with one you can | |
71 ;;; do with the other. It's just a matter of which way of creating and | |
72 ;;; managing them is most appropriate to your application. | |
73 ;;; | |
74 ;;; Implementation details: | |
75 ;;; ======================= | |
76 ;;; | |
77 ;;; This package uses extents with a non-nil 'text-prop property. It assumes | |
78 ;;; free reign over the endpoints of any extent with that property. It will | |
79 ;;; not alter any extent which does not have that property. | |
80 ;;; | |
81 ;;; Right now, the text-property functions create one extent for each distinct | |
82 ;;; property; that is, if a range of text has two text-properties on it, there | |
83 ;;; will be two extents. As the set of text-properties is going to be small, | |
84 ;;; this is probably not a big deal. It would be possible to share extents. | |
85 ;;; | |
86 ;;; One tricky bit is that undo/kill/yank must be made to not fragment things: | |
87 ;;; these extents must not be allowed to overlap. We accomplish this by using | |
88 ;;; a custom `paste-function' property on the extents. | |
89 ;;; | |
90 ;;; shell-font.el and font-lock.el could put-text-property to attach fonts to | |
91 ;;; the buffer. However, what these packages are interested in is the | |
92 ;;; efficient extent partitioning behavior which this code exhibits, not the | |
93 ;;; duplicability aspect of it. In fact, either of these packages could be be | |
94 ;;; implemented by creating a one-character non-expandable extent for each | |
95 ;;; character in the buffer, except that that would be extremely wasteful of | |
96 ;;; memory. (Redisplay performance would be fine, however.) | |
97 ;;; | |
98 ;;; If these packages were to use put-text-property to make the extents, then | |
99 ;;; when one copied text from a shell buffer or a font-locked source buffer | |
100 ;;; and pasted it somewhere else (a sendmail buffer, or a buffer not in | |
101 ;;; font-lock mode) then the fonts would follow, and there's no easy way to | |
102 ;;; get rid of them (other than pounding out a call to put-text-property by | |
103 ;;; hand.) This is annoying. Maybe it wouldn't be so annoying if there was a | |
104 ;;; more general set of commands for handling styles of text (in fact, if | |
105 ;;; there were such a thing, copying the fonts would probably be exactly what | |
106 ;;; one wanted) but we aren't there yet. So these packages use the interface | |
107 ;;; of `put-nonduplicable-text-property' which is the same, except that it | |
108 ;;; doesn't make duplicable extents. | |
109 ;;; | |
110 ;;; `put-text-property' and `put-nonduplicable-text-property' don't get along: | |
111 ;;; they will interfere with each other, reusing each others' extents without | |
112 ;;; checking that the "duplicableness" is correct. This is a bug, but it's | |
113 ;;; one that I don't care enough to fix this right now. | |
114 | |
115 | |
116 ;;; Code: | |
117 | |
118 | |
119 ;; The following functions were ported to C for speed; the overhead of doing | |
120 ;; this many full lisp function calls was not small. | |
121 | |
122 ;; #### The C functions have changed since then; the Lisp equivalents | |
123 ;; should be updated. | |
124 | |
125 ;(defun put-text-property (start end prop value &optional buffer) | |
126 ; "Adds the given property/value to all characters in the specified region. | |
127 ;The property is conceptually attached to the characters rather than the | |
128 ;region. The properties are copied when the characters are copied/pasted." | |
129 ; (put-text-property-1 start end prop value buffer t) | |
130 ; prop) | |
131 ; | |
132 ;(defun put-nonduplicable-text-property (start end prop value &optional buffer) | |
133 ; "Adds the given property/value to all characters in the specified region. | |
134 ;The property is conceptually attached to the characters rather than the | |
135 ;region, however the properties will not be copied the characters are copied." | |
136 ; (put-text-property-1 start end prop value buffer nil) | |
137 ; prop) | |
138 ; | |
139 ;(defun put-text-property-1 (start end prop value buffer duplicable) | |
140 ; ;; returns whether any property of a character was changed | |
141 ; (if (= start end) | |
142 ; nil | |
143 ; (save-excursion | |
144 ; (and buffer (set-buffer buffer)) | |
145 ; (let ((the-extent nil) | |
146 ; (changed nil)) | |
147 ; ;; prop, value, the-extent, start, end, and changed are of dynamic | |
148 ; ;; scope. changed and the-extent are assigned. | |
149 ; (map-extents (function put-text-property-mapper) nil | |
150 ; (max 1 (1- start)) | |
151 ; (min (buffer-size) (1+ end))) | |
152 ; | |
153 ; ;; If we made it through the loop without reusing an extent | |
154 ; ;; (and we want there to be one) make it now. | |
155 ; (cond ((and value (not the-extent)) | |
156 ; (setq the-extent (make-extent start end)) | |
157 ; (set-extent-property the-extent 'text-prop prop) | |
158 ; (set-extent-property the-extent prop value) | |
159 ; (setq changed t) | |
160 ; (cond (duplicable | |
161 ; (set-extent-property the-extent 'duplicable t) | |
162 ; (set-extent-property the-extent 'paste-function | |
163 ; 'text-prop-extent-paste-function))) | |
164 ; )) | |
165 ; changed)))) | |
166 ; | |
167 ;(defun put-text-property-mapper (e ignore) | |
168 ; ;; prop, value, the-extent, start, end, and changed are of dynamic scope. | |
169 ; ;; changed and the-extent are assigned. | |
170 ; (let ((e-start (extent-start-position e)) | |
171 ; (e-end (extent-end-position e)) | |
172 ; (e-val (extent-property e prop))) | |
173 ; (cond ((not (eq (extent-property e 'text-prop) prop)) | |
174 ; ;; It's not for this property; do nothing. | |
175 ; nil) | |
176 ; | |
177 ; ((and value | |
178 ; (not the-extent) | |
179 ; (eq value e-val)) | |
180 ; ;; we want there to be an extent here at the end, and we haven't | |
181 ; ;; picked one yet, so use this one. Extend it as necessary. | |
182 ; ;; We only reuse an extent which has an EQ value for the prop in | |
183 ; ;; question to avoid side-effecting the kill ring (that is, we | |
184 ; ;; never change the property on an extent after it has been | |
185 ; ;; created.) | |
186 ; (cond | |
187 ; ((or (/= e-start start) (/= e-end end)) | |
188 ; (set-extent-endpoints e (min e-start start) (max e-end end)) | |
189 ; (setq changed t))) | |
190 ; (setq the-extent e)) | |
191 ; | |
192 ; ;; Even if we're adding a prop, at this point, we want all other | |
193 ; ;; extents of this prop to go away (as now they overlap.) | |
194 ; ;; So the theory here is that, when we are adding a prop to a | |
195 ; ;; region that has multiple (disjoint) occurences of that prop | |
196 ; ;; in it already, we pick one of those and extend it, and remove | |
197 ; ;; the others. | |
198 ; | |
199 ; ((eq e the-extent) | |
200 ; ;; just in case map-extents hits it again (does that happen?) | |
201 ; nil) | |
202 ; | |
203 ; ((and (>= e-start start) | |
204 ; (<= e-end end)) | |
205 ; ;; extent is contained in region; remove it. Don't destroy or | |
206 ; ;; modify it, because we don't want to change the attributes | |
207 ; ;; pointed to by the duplicates in the kill ring. | |
208 ; (setq changed t) | |
209 ; (detach-extent e)) | |
210 ; | |
211 ; ((and the-extent | |
212 ; (eq value e-val) | |
213 ; (<= e-start end) | |
214 ; (>= e-end start)) | |
215 ; ;; this extent overlaps, and has the same prop/value as the | |
216 ; ;; extent we've decided to reuse, so we can remove this existing | |
217 ; ;; extent as well (the whole thing, even the part outside of the | |
218 ; ;; region) and extend the-extent to cover it, resulting in the | |
219 ; ;; minimum number of extents in the buffer. | |
220 ; (cond | |
221 ; ((and (/= (extent-start-position the-extent) e-start) | |
222 ; (/= (extent-end-position the-extent) e-end)) | |
223 ; (set-extent-endpoints the-extent | |
224 ; (min (extent-start-position the-extent) | |
225 ; e-start) | |
226 ; (max (extent-end-position the-extent) | |
227 ; e-end)) | |
228 ; (setq changed t))) | |
229 ; (detach-extent e)) | |
230 ; | |
231 ; ((<= (extent-end-position e) end) | |
232 ; ;; extent begins before start but ends before end, | |
233 ; ;; so we can just decrease its end position. | |
234 ; (if (and (= (extent-start-position e) e-start) | |
235 ; (= (extent-end-position e) start)) | |
236 ; nil | |
237 ; (set-extent-endpoints e e-start start) | |
238 ; (setq changed t))) | |
239 ; | |
240 ; ((>= (extent-start-position e) start) | |
241 ; ;; extent ends after end but begins after start, | |
242 ; ;; so we can just increase its start position. | |
243 ; (if (and (= (extent-start-position e) end) | |
244 ; (= (extent-start-position e) e-end)) | |
245 ; nil | |
246 ; (set-extent-endpoints e end e-end) | |
247 ; (setq changed t))) | |
248 ; | |
249 ; (t | |
250 ; ;; Otherwise, the extent straddles the region. | |
251 ; ;; We need to split it. | |
252 ; (set-extent-endpoints e e-start start) | |
253 ; (setq e (copy-extent e)) | |
254 ; (set-extent-endpoints e end e-end) | |
255 ; (setq changed t)))) | |
256 ; ;; return nil to continue mapping over region. | |
257 ; nil) | |
258 ; | |
259 ; | |
260 ;(defun text-prop-extent-paste-function (extent from to) | |
261 ; ;; Whenever a text-prop extent is pasted into a buffer (via `yank' or | |
262 ; ;; `insert' or whatever) we attach the properties to the buffer by calling | |
263 ; ;; `put-text-property' instead of by simply alowing the extent to be copied | |
264 ; ;; or re-attached. Then we return nil, telling the C code not to attach | |
265 ; ;; it again. By handing the insertion hackery in this way, we make kill/yank | |
266 ; ;; behave consistently iwth put-text-property and not fragment the extents | |
267 ; ;; (since text-prop extents must partition, not overlap.) | |
268 ; (let* ((prop (or (extent-property extent 'text-prop) | |
269 ; (error "internal error: no text-prop on %S" extent))) | |
270 ; (val (or (extent-property extent prop) | |
271 ; (error "internal error: no text-prop %S on %S" | |
272 ; prop extent)))) | |
273 ; (put-text-property from to prop val) | |
274 ; nil)) | |
275 ; | |
276 ;(defun add-text-properties (start end props &optional buffer) | |
277 ; "Add properties to the characters from START to END. | |
278 ;The third argument PROPS is a property list specifying the property values | |
279 ;to add. The optional fourth argument, OBJECT, is the buffer containing the | |
280 ;text. Returns t if any property was changed, nil otherwise." | |
281 ; (let ((changed nil)) | |
282 ; (while props | |
283 ; (setq changed | |
284 ; (or (put-text-property-1 start end (car props) (car (cdr props)) | |
285 ; buffer t) | |
286 ; changed)) | |
287 ; (setq props (cdr (cdr props)))) | |
288 ; changed)) | |
289 ; | |
290 ;(defun remove-text-properties (start end props &optional buffer) | |
291 ; "Remove the given properties from all characters in the specified region. | |
292 ;PROPS should be a plist, but the values in that plist are ignored (treated | |
293 ;as nil.) Returns t if any property was changed, nil otherwise." | |
294 ; (let ((changed nil)) | |
295 ; (while props | |
296 ; (setq changed | |
297 ; (or (put-text-property-1 start end (car props) nil buffer t) | |
298 ; changed)) | |
299 ; (setq props (cdr (cdr props)))) | |
300 ; changed)) | |
301 ; | |
302 | |
303 (defun set-text-properties (start end props &optional buffer-or-string) | |
304 "You should NEVER use this function. It is ideologically blasphemous. | |
305 It is provided only to ease porting of broken FSF Emacs programs. | |
306 | |
307 Completely replace properties of text from START to END. | |
308 The third argument PROPS is the new property list. | |
309 The optional fourth argument, BUFFER-OR-STRING, | |
310 is the string or buffer containing the text." | |
311 (map-extents #'(lambda (extent ignored) | |
312 (remove-text-properties start end | |
313 (list (extent-property extent | |
314 'text-prop) | |
315 nil) | |
316 buffer-or-string)) | |
317 buffer-or-string start end nil nil 'text-prop) | |
318 (add-text-properties start end props buffer-or-string)) | |
319 | |
320 | |
321 ;;; The following functions can probably stay in lisp, since they're so simple. | |
322 | |
323 ;(defun get-text-property (pos prop &optional buffer) | |
324 ; "Returns the value of the PROP property at the given position." | |
325 ; (let ((e (extent-at pos buffer prop))) | |
326 ; (if e | |
327 ; (extent-property e prop) | |
328 ; nil))) | |
329 | |
330 (defun extent-properties-at-1 (position buffer-or-string text-props-only) | |
331 (let ((extent nil) | |
332 (props nil) | |
333 new-props) | |
334 (while (setq extent (extent-at position buffer-or-string | |
335 (if text-props-only 'text-prop nil) | |
336 extent)) | |
337 (if text-props-only | |
338 ;; Only return the one prop which the `text-prop' property points at. | |
339 (let ((prop (extent-property extent 'text-prop))) | |
340 (setq new-props (list prop (extent-property extent prop)))) | |
341 ;; Return all the properties... | |
342 (setq new-props (extent-properties extent)) | |
343 ;; ...but! Don't return the `begin-glyph' or `end-glyph' properties | |
344 ;; unless the position is exactly at the appropriate endpoint. Yeah, | |
345 ;; this is kind of a kludge. | |
346 ;; #### Bug, this doesn't work for end-glyphs (on end-open extents) | |
347 ;; because we've already passed the extent with the glyph by the time | |
348 ;; it's appropriate to return the glyph. We could return the end | |
349 ;; glyph one character early I guess... But then next-property-change | |
350 ;; would have to stop one character early as well. It could back up | |
351 ;; when it hit an end-glyph... | |
352 ;; #### Another bug, if there are multiple glyphs at the same position, | |
353 ;; we only see the first one. | |
354 (cond ((or (extent-begin-glyph extent) (extent-end-glyph extent)) | |
355 (if (/= position (if (extent-property extent 'begin-glyph) | |
356 (extent-start-position extent) | |
357 (extent-end-position extent))) | |
358 (let ((rest new-props) | |
359 prev) | |
360 (while rest | |
361 (cond ((or (eq (car rest) 'begin-glyph) | |
362 (eq (car rest) 'end-glyph)) | |
363 (if prev | |
364 (setcdr prev (cdr (cdr rest))) | |
365 (setq new-props (cdr (cdr new-props)))) | |
366 (setq rest nil))) | |
367 (setq prev rest | |
368 rest (cdr rest)))))))) | |
369 (cond ((null props) | |
370 (setq props new-props)) | |
371 (t | |
372 (while new-props | |
373 (or (getf props (car new-props)) | |
374 (setq props (cons (car new-props) | |
375 (cons (car (cdr new-props)) | |
376 props)))) | |
377 (setq new-props (cdr (cdr new-props))))))) | |
378 props)) | |
379 | |
380 (defun extent-properties-at (position &optional object) | |
381 "Returns the properties of the character at the given position | |
382 in OBJECT (a string or buffer) by merging the properties of overlapping | |
383 extents. The returned value is a property list, some of which may be | |
384 shared with other structures. You must not modify it. | |
385 | |
386 If POSITION is at the end of OBJECT, the value is nil. | |
387 | |
388 This returns all properties on all extents. | |
389 See also `text-properties-at'." | |
390 (extent-properties-at-1 position object nil)) | |
391 | |
392 (defun text-properties-at (position &optional object) | |
393 "Returns the properties of the character at the given position | |
394 in OBJECT (a string or buffer) by merging the properties of overlapping | |
395 extents. The returned value is a property list, some of which may be | |
396 shared with other structures. You must not modify it. | |
397 | |
398 If POSITION is at the end of OBJECT, the value is nil. | |
399 | |
400 This returns only those properties added with `put-text-property'. | |
401 See also `extent-properties-at'." | |
402 (extent-properties-at-1 position object t)) | |
403 | |
404 (defun text-property-any (start end prop value &optional buffer-or-string) | |
405 "Check text from START to END to see if PROP is ever `eq' to VALUE. | |
406 If so, return the position of the first character whose PROP is `eq' | |
407 to VALUE. Otherwise return nil. | |
408 The optional fifth argument, BUFFER-OR-STRING, is the buffer or string | |
409 containing the text and defaults to the current buffer." | |
410 (while (and start (< start end) | |
411 (not (eq value (get-text-property start prop buffer-or-string)))) | |
412 (setq start (next-single-property-change start prop buffer-or-string end))) | |
413 ;; we have to insert a special check for end due to the illogical | |
414 ;; definition of next-single-property-change (blame FSF for this). | |
415 (if (eq start end) nil start)) | |
416 | |
417 (defun text-property-not-all (start end prop value &optional buffer-or-string) | |
418 "Check text from START to END to see if PROP is ever not `eq' to VALUE. | |
419 If so, return the position of the first character whose PROP is not | |
420 `eq' to VALUE. Otherwise, return nil. | |
421 The optional fifth argument, BUFFER-OR-STRING, is the buffer or string | |
422 containing the text and defaults to the current buffer." | |
423 (if (not (eq value (get-text-property start prop buffer-or-string))) | |
424 start | |
425 (let ((retval (next-single-property-change start prop | |
426 buffer-or-string end))) | |
427 ;; we have to insert a special check for end due to the illogical | |
428 ;; definition of previous-single-property-change (blame FSF for this). | |
429 (if (eq retval end) nil retval)))) | |
430 | |
431 ;; Older versions that only work sometimes (when VALUE is non-nil | |
432 ;; for text-property-any, and maybe only when VALUE is nil for | |
433 ;; text-property-not-all). They might be faster in those cases, | |
434 ;; but that's not obvious. | |
435 | |
436 ;(defun text-property-any (start end prop value &optional buffer) | |
437 ; "Check text from START to END to see if PROP is ever `eq' to VALUE. | |
438 ;If so, return the position of the first character whose PROP is `eq' | |
439 ;to VALUE. Otherwise return nil." | |
440 ; ;; #### what should (text-property-any x y 'foo nil) return when there | |
441 ; ;; is no foo property between x and y? Either t or nil seems sensible, | |
442 ; ;; since a character with a property of nil is indistinguishable from | |
443 ; ;; a character without that property set. | |
444 ; (map-extents | |
445 ; #'(lambda (e ignore) | |
446 ; (if (eq value (extent-property e prop)) | |
447 ; ;; return non-nil to stop mapping | |
448 ; (max start (extent-start-position e)) | |
449 ; nil)) | |
450 ; nil start end buffer)) | |
451 ; | |
452 ;(defun text-property-not-all (start end prop value &optional buffer) | |
453 ; "Check text from START to END to see if PROP is ever not `eq' to VALUE. | |
454 ;If so, return the position of the first character whose PROP is not | |
455 ;`eq' to VALUE. Otherwise, return nil." | |
456 ; (let (maxend) | |
457 ; (map-extents | |
458 ; #'(lambda (e ignore) | |
459 ; ;;### no, actually, this is harder. We need to collect all props | |
460 ; ;; for a given character, and then determine whether no extent | |
461 ; ;; contributes the given value. Doing this without consing lots | |
462 ; ;; of lists is the tricky part. | |
463 ; (if (eq value (extent-property e prop)) | |
464 ; (progn | |
465 ; (setq maxend (extent-end-position e)) | |
466 ; nil) | |
467 ; (max start maxend))) | |
468 ; nil start end buffer))) | |
469 | |
470 (defun next-property-change (pos &optional buffer-or-string limit) | |
471 "Return the position of next property change. | |
472 Scans forward from POS in BUFFER-OR-STRING (defaults to the current buffer) | |
473 until it finds a change in some text property, then returns the position of | |
474 the change. | |
475 Returns nil if the properties remain unchanged all the way to the end. | |
476 If the value is non-nil, it is a position greater than POS, never equal. | |
477 If the optional third argument LIMIT is non-nil, don't search | |
478 past position LIMIT; return LIMIT if nothing is found before LIMIT. | |
479 If two or more extents with conflicting non-nil values for a property overlap | |
480 a particular character, it is undefined which value is considered to be | |
481 the value of the property. (Note that this situation will not happen if | |
482 you always use the text-property primitives.)" | |
483 (let ((limit-was-nil (null limit))) | |
484 (or limit (setq limit (if (bufferp buffer-or-string) | |
485 (point-max buffer-or-string) | |
486 (length buffer-or-string)))) | |
487 (let ((value (extent-properties-at pos buffer-or-string))) | |
488 (while | |
489 (and (< (setq pos (next-extent-change pos buffer-or-string)) limit) | |
490 (plists-eq value (extent-properties-at pos buffer-or-string))))) | |
491 (if (< pos limit) pos | |
492 (if limit-was-nil nil | |
493 limit)))) | |
494 | |
495 (defun previous-property-change (pos &optional buffer-or-string limit) | |
496 "Return the position of previous property change. | |
497 Scans backward from POS in BUFFER-OR-STRING (defaults to the current buffer) | |
498 until it finds a change in some text property, then returns the position of | |
499 the change. | |
500 Returns nil if the properties remain unchanged all the way to the beginning. | |
501 If the value is non-nil, it is a position less than POS, never equal. | |
502 If the optional third argument LIMIT is non-nil, don't search back | |
503 past position LIMIT; return LIMIT if nothing is found until LIMIT. | |
504 If two or more extents with conflicting non-nil values for a property overlap | |
505 a particular character, it is undefined which value is considered to be | |
506 the value of the property. (Note that this situation will not happen if | |
507 you always use the text-property primitives.)" | |
508 (let ((limit-was-nil (null limit))) | |
509 (or limit (setq limit (if (bufferp buffer-or-string) | |
510 (point-min buffer-or-string) | |
511 0))) | |
512 (let ((value (extent-properties-at (1- pos) buffer-or-string))) | |
513 (while | |
514 (and (> (setq pos (previous-extent-change pos buffer-or-string)) | |
515 limit) | |
516 (plists-eq value (extent-properties-at (1- pos) | |
517 buffer-or-string))))) | |
518 (if (> pos limit) pos | |
519 (if limit-was-nil nil | |
520 limit)))) | |
521 | |
522 (defun text-property-bounds (pos prop &optional object at-flag) | |
523 "Return the bounds of property PROP at POS. | |
524 This returns a cons (START . END) of the largest region of text containing | |
525 POS which has a non-nil value for PROP. The return value is nil if POS | |
526 does not have a non-nil value for PROP. OBJECT specifies the buffer | |
527 or string to search in. Optional arg AT-FLAG controls what \"at POS\" | |
528 means, and has the same meaning as for `extent-at'." | |
529 (or object (setq object (current-buffer))) | |
530 (and (get-char-property pos prop object at-flag) | |
531 (let ((begin (if (stringp object) 0 (point-min object))) | |
532 (end (if (stringp object) (length object) (point-max object)))) | |
533 (cons (previous-single-property-change (1+ pos) prop object begin) | |
534 (next-single-property-change pos prop object end))))) | |
535 | |
536 (defun next-text-property-bounds (count pos prop &optional object) | |
537 "Return the COUNTth bounded property region of property PROP after POS. | |
538 If COUNT is less than zero, search backwards. This returns a cons | |
539 \(START . END) of the COUNTth maximal region of text that begins after POS | |
540 \(starts before POS) and has a non-nil value for PROP. If there aren't | |
541 that many regions, nil is returned. OBJECT specifies the buffer or | |
542 string to search in." | |
543 (or object (setq object (current-buffer))) | |
544 (let ((begin (if (stringp object) 0 (point-min object))) | |
545 (end (if (stringp object) (length object) (point-max object)))) | |
546 (catch 'hit-end | |
547 (if (> count 0) | |
548 (progn | |
549 (while (> count 0) | |
550 (if (>= pos end) | |
551 (throw 'hit-end nil) | |
552 (and (get-char-property pos prop object) | |
553 (setq pos (next-single-property-change pos prop | |
554 object end))) | |
555 (setq pos (next-single-property-change pos prop object end))) | |
556 (setq count (1- count))) | |
557 (and (< pos end) | |
558 (cons pos (next-single-property-change pos prop object end)))) | |
559 (while (< count 0) | |
560 (if (<= pos begin) | |
561 (throw 'hit-end nil) | |
562 (and (get-char-property (1- pos) prop object) | |
563 (setq pos (previous-single-property-change pos prop | |
564 object begin))) | |
565 (setq pos (previous-single-property-change pos prop object | |
566 begin))) | |
567 (setq count (1+ count))) | |
568 (and (> pos begin) | |
569 (cons (previous-single-property-change pos prop object begin) | |
570 pos)))))) | |
571 | |
572 ;(defun detach-all-extents (&optional buffer) | |
573 ; (map-extents #'(lambda (x i) (detach-extent x) nil) | |
574 ; buffer)) | |
575 | |
576 | |
577 (provide 'text-props) | |
578 | |
579 ;;; text-props.el ends here |