cgit.sxemacs.org Git - sxemacs/blob - 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: SXEmacs Development Team
   9 ;; Keywords: extensions, wp, faces, dumped
  10
  11 ;; This file is part of SXEmacs.
  12
  13 ;; SXEmacs 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 3 of the License, or
  16 ;; (at your option) any later version.
  17
  18 ;; SXEmacs 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 this program.  If not, see <http://www.gnu.org/licenses/>.
  25
  26 ;;; Synched up with: Not in FSF.
  27
  28 ;;; Commentary:
  29
  30 ;; This file is dumped with SXEmacs.
  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
  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 ;;; Code:
 116
 117 (defun set-text-properties (start end props &optional buffer-or-string)
 118   "You should NEVER use this function.  It is ideologically blasphemous.
 119 It is provided only to ease porting of broken FSF Emacs programs.
 120 Instead, use `remove-text-properties' to remove the specific properties
 121 you do not want.
 122
 123 Completely replace properties of text from START to END.
 124 The third argument PROPS is the new property list.
 125 The optional fourth argument, BUFFER-OR-STRING,
 126 is the string or buffer containing the text."
 127   (map-extents #'(lambda (extent ignored)
 128                    ;; #### dmoore - shouldn't this use
 129                    ;; (extent-start-position extent)
 130                    ;; (extent-end-position extent)
 131                    (remove-text-properties start end
 132                                            (list (extent-property extent
 133                                                                   'text-prop)
 134                                                  nil)
 135                                            buffer-or-string)
 136                    nil)
 137                buffer-or-string start end nil nil 'text-prop)
 138   (add-text-properties start end props buffer-or-string))
 139
 140 \f
 141 ;;; The following functions can probably stay in lisp, since they're so simple.
 142
 143 ;(defun get-text-property (pos prop &optional buffer)
 144 ;  "Returns the value of the PROP property at the given position."
 145 ;  (let ((e (extent-at pos buffer prop)))
 146 ;    (if e
 147 ;       (extent-property e prop)
 148 ;      nil)))
 149
 150 (defun extent-properties-at-1 (position buffer-or-string text-props-only)
 151   (let ((extent nil)
 152         (props nil)
 153         new-props)
 154     (while (setq extent (extent-at position buffer-or-string
 155                                    (if text-props-only 'text-prop nil)
 156                                    extent))
 157       (if text-props-only
 158           ;; Only return the one prop which the `text-prop' property points at.
 159           (let ((prop (extent-property extent 'text-prop)))
 160             (setq new-props (list prop (extent-property extent prop))))
 161         ;; Return all the properties...
 162         (setq new-props (extent-properties extent))
 163         ;; ...but!  Don't return the `begin-glyph' or `end-glyph' properties
 164         ;; unless the position is exactly at the appropriate endpoint.  Yeah,
 165         ;; this is kind of a kludge.
 166         ;; #### Bug, this doesn't work for end-glyphs (on end-open extents)
 167         ;; because we've already passed the extent with the glyph by the time
 168         ;; it's appropriate to return the glyph.  We could return the end
 169         ;; glyph one character early I guess...  But then next-property-change
 170         ;; would have to stop one character early as well.  It could back up
 171         ;; when it hit an end-glyph...
 172         ;; #### Another bug, if there are multiple glyphs at the same position,
 173         ;; we only see the first one.
 174         (cond ((or (extent-begin-glyph extent) (extent-end-glyph extent))
 175                (if (/= position (if (extent-property extent 'begin-glyph)
 176                                     (extent-start-position extent)
 177                                   (extent-end-position extent)))
 178                    (let ((rest new-props)
 179                          prev)
 180                      (while rest
 181                        (cond ((or (eq (car rest) 'begin-glyph)
 182                                   (eq (car rest) 'end-glyph))
 183                               (if prev
 184                                   (setcdr prev (cdr (cdr rest)))
 185                                 (setq new-props (cdr (cdr new-props))))
 186                               (setq rest nil)))
 187                        (setq prev rest
 188                              rest (cdr rest))))))))
 189       (cond ((null props)
 190              (setq props new-props))
 191             (t
 192              (while new-props
 193                (or (getf props (car new-props))
 194                    (setq props (cons (car new-props)
 195                                      (cons (car (cdr new-props))
 196                                            props))))
 197                (setq new-props (cdr (cdr new-props)))))))
 198     props))
 199
 200 (defun extent-properties-at (position &optional object)
 201   "Return the properties of the character at the given position in OBJECT.
 202 OBJECT is either a string or a buffer. The properties of overlapping
 203 extents are merged.  The returned value is a property list, some of
 204 which may be shared with other structures.  You must not modify it.
 205
 206 If POSITION is at the end of OBJECT, the value is nil.
 207
 208 This returns all properties on all extents.
 209 See also `text-properties-at'."
 210   (extent-properties-at-1 position object nil))
 211
 212 (defun text-properties-at (position &optional object)
 213   "Return the properties of the character at the given position in OBJECT.
 214 OBJECT is either a string or a buffer. The properties of overlapping
 215 extents are merged.  The returned value is a property list, some of
 216 which may be shared with other structures.  You must not modify it.
 217
 218 If POSITION is at the end of OBJECT, the value is nil.
 219
 220 This returns only those properties added with `put-text-property'.
 221 See also `extent-properties-at'."
 222   (extent-properties-at-1 position object t))
 223
 224 (defun text-property-any (start end prop value &optional buffer-or-string)
 225   "Check text from START to END to see if PROP is ever `eq' to VALUE.
 226 If so, return the position of the first character whose PROP is `eq'
 227 to VALUE.  Otherwise return nil.
 228 The optional fifth argument, BUFFER-OR-STRING, is the buffer or string
 229 containing the text and defaults to the current buffer."
 230   (while (and start (< start end)
 231               (not (eq value (get-text-property start prop buffer-or-string))))
 232     (setq start (next-single-property-change start prop buffer-or-string end)))
 233   ;; we have to insert a special check for end due to the illogical
 234   ;; definition of next-single-property-change (blame FSF for this).
 235   (if (and start (>= start end)) nil start))
 236
 237 (defun text-property-not-all (start end prop value &optional buffer-or-string)
 238   "Check text from START to END to see if PROP is ever not `eq' to VALUE.
 239 If so, return the position of the first character whose PROP is not
 240 `eq' to VALUE.  Otherwise, return nil.
 241 The optional fifth argument, BUFFER-OR-STRING, is the buffer or string
 242 containing the text and defaults to the current buffer."
 243   (if (not (eq value (get-text-property start prop buffer-or-string)))
 244       start
 245     (let ((retval (next-single-property-change start prop
 246                                                buffer-or-string end)))
 247       ;; we have to insert a special check for end due to the illogical
 248       ;; definition of previous-single-property-change (blame FSF for this).
 249       (if (and retval (>= retval end)) nil retval))))
 250
 251 ;; Older versions that only work sometimes (when VALUE is non-nil
 252 ;; for text-property-any, and maybe only when VALUE is nil for
 253 ;; text-property-not-all).  They might be faster in those cases,
 254 ;; but that's not obvious.
 255
 256 ;(defun text-property-any (start end prop value &optional buffer)
 257 ;  "Check text from START to END to see if PROP is ever `eq' to VALUE.
 258 ;If so, return the position of the first character whose PROP is `eq'
 259 ;to VALUE.  Otherwise return nil."
 260 ;  ;; #### what should (text-property-any x y 'foo nil) return when there
 261 ;  ;; is no foo property between x and y?  Either t or nil seems sensible,
 262 ;  ;; since a character with a property of nil is indistinguishable from
 263 ;  ;; a character without that property set.
 264 ;  (map-extents
 265 ;   #'(lambda (e ignore)
 266 ;       (if (eq value (extent-property e prop))
 267 ;          ;; return non-nil to stop mapping
 268 ;          (max start (extent-start-position e))
 269 ;        nil))
 270 ;   nil start end buffer))
 271 ;
 272 ;(defun text-property-not-all (start end prop value &optional buffer)
 273 ;  "Check text from START to END to see if PROP is ever not `eq' to VALUE.
 274 ;If so, return the position of the first character whose PROP is not
 275 ;`eq' to VALUE.  Otherwise, return nil."
 276 ;  (let (maxend)
 277 ;    (map-extents
 278 ;     #'(lambda (e ignore)
 279 ;        ;;### no, actually, this is harder.  We need to collect all props
 280 ;        ;; for a given character, and then determine whether no extent
 281 ;        ;; contributes the given value.  Doing this without consing lots
 282 ;        ;; of lists is the tricky part.
 283 ;        (if (eq value (extent-property e prop))
 284 ;            (progn
 285 ;              (setq maxend (extent-end-position e))
 286 ;              nil)
 287 ;          (max start maxend)))
 288 ;     nil start end buffer)))
 289
 290 (defun next-property-change (pos &optional buffer-or-string limit)
 291   "Return the position of next property change.
 292 Scans forward from POS in BUFFER-OR-STRING (defaults to the current buffer)
 293  until it finds a change in some text property, then returns the position of
 294  the change.
 295 Returns nil if the properties remain unchanged all the way to the end.
 296 If the value is non-nil, it is a position greater than POS, never equal.
 297 If the optional third argument LIMIT is non-nil, don't search
 298  past position LIMIT; return LIMIT if nothing is found before LIMIT.
 299 If two or more extents with conflicting non-nil values for a property overlap
 300  a particular character, it is undefined which value is considered to be
 301  the value of the property. (Note that this situation will not happen if
 302  you always use the text-property primitives.)"
 303   (let ((limit-was-nil (null limit)))
 304     (or limit (setq limit (if (bufferp buffer-or-string)
 305                               (point-max buffer-or-string)
 306                             (length buffer-or-string))))
 307     (let ((value (extent-properties-at pos buffer-or-string)))
 308       (while
 309           (and (< (setq pos (next-extent-change pos buffer-or-string)) limit)
 310                (plists-eq value (extent-properties-at pos buffer-or-string)))))
 311     (if (< pos limit) pos
 312       (if limit-was-nil nil
 313         limit))))
 314
 315 (defun previous-property-change (pos &optional buffer-or-string limit)
 316   "Return the position of previous property change.
 317 Scans backward from POS in BUFFER-OR-STRING (defaults to the current buffer)
 318  until it finds a change in some text property, then returns the position of
 319  the change.
 320 Returns nil if the properties remain unchanged all the way to the beginning.
 321 If the value is non-nil, it is a position less than POS, never equal.
 322 If the optional third argument LIMIT is non-nil, don't search back
 323  past position LIMIT; return LIMIT if nothing is found until LIMIT.
 324 If two or more extents with conflicting non-nil values for a property overlap
 325  a particular character, it is undefined which value is considered to be
 326  the value of the property. (Note that this situation will not happen if
 327  you always use the text-property primitives.)"
 328   (let ((limit-was-nil (null limit)))
 329     (or limit (setq limit (if (bufferp buffer-or-string)
 330                               (point-min buffer-or-string)
 331                             0)))
 332     (let ((value (extent-properties-at (1- pos) buffer-or-string)))
 333       (while
 334           (and (> (setq pos (previous-extent-change pos buffer-or-string))
 335                   limit)
 336                (plists-eq value (extent-properties-at (1- pos)
 337                                                       buffer-or-string)))))
 338     (if (> pos limit) pos
 339       (if limit-was-nil nil
 340         limit))))
 341
 342 (defun text-property-bounds (pos prop &optional object at-flag)
 343   "Return the bounds of property PROP at POS.
 344 This returns a cons (START . END) of the largest region of text containing
 345 POS which has a non-nil value for PROP.  The return value is nil if POS
 346 does not have a non-nil value for PROP.  OBJECT specifies the buffer
 347 or string to search in.  Optional arg AT-FLAG controls what \"at POS\"
 348 means, and has the same meaning as for `extent-at'."
 349   (or object (setq object (current-buffer)))
 350   (and (get-char-property pos prop object at-flag)
 351        (let ((begin (if (stringp object) 0 (point-min object)))
 352              (end (if (stringp object) (length object) (point-max object))))
 353          (cons (previous-single-property-change (1+ pos) prop object begin)
 354                (next-single-property-change pos prop object end)))))
 355
 356 (defun next-text-property-bounds (count pos prop &optional object)
 357   "Return the COUNTth bounded property region of property PROP after POS.
 358 If COUNT is less than zero, search backwards.  This returns a cons
 359 \(START . END) of the COUNTth maximal region of text that begins after POS
 360 \(starts before POS) and has a non-nil value for PROP.  If there aren't
 361 that many regions, nil is returned.  OBJECT specifies the buffer or
 362 string to search in."
 363   (or object (setq object (current-buffer)))
 364   (let ((begin (if (stringp object) 0 (point-min object)))
 365         (end (if (stringp object) (length object) (point-max object))))
 366     (catch 'hit-end
 367       (if (> count 0)
 368           (progn
 369             (while (> count 0)
 370               (if (>= pos end)
 371                   (throw 'hit-end nil)
 372                 (and (get-char-property pos prop object)
 373                      (setq pos (next-single-property-change pos prop
 374                                                             object end)))
 375                 (setq pos (next-single-property-change pos prop object end)))
 376               (setq count (1- count)))
 377             (and (< pos end)
 378                  (cons pos (next-single-property-change pos prop object end))))
 379         (while (< count 0)
 380           (if (<= pos begin)
 381               (throw 'hit-end nil)
 382             (and (get-char-property (1- pos) prop object)
 383                  (setq pos (previous-single-property-change pos prop
 384                                                             object begin)))
 385             (setq pos (previous-single-property-change pos prop object
 386                                                        begin)))
 387           (setq count (1+ count)))
 388         (and (> pos begin)
 389              (cons (previous-single-property-change pos prop object begin)
 390                    pos))))))
 391
 392 ;(defun detach-all-extents (&optional buffer)
 393 ;  (map-extents #'(lambda (x i) (detach-extent x) nil)
 394 ;              buffer))
 395
 396
 397 (provide 'text-props)
 398
 399 ;;; text-props.el ends here