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
