Mercurial > hg > xemacs-beta
annotate lisp/text-props.el @ 5603:2b2f37e84792
Fixes for building native windows setup kits
| author | Vin Shelton <acs@xemacs.org> |
|---|---|
| date | Tue, 29 Nov 2011 09:05:36 -0500 |
| parents | 308d34e9f07d |
| children |
| rev | line source |
|---|---|
| 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 | |
|
5402
308d34e9f07d
Changed bulk of GPLv2 or later files identified by script
Mats Lidell <matsl@xemacs.org>
parents:
1275
diff
changeset
|
13 ;; XEmacs is free software: you can redistribute it and/or modify it |
|
308d34e9f07d
Changed bulk of GPLv2 or later files identified by script
Mats Lidell <matsl@xemacs.org>
parents:
1275
diff
changeset
|
14 ;; under the terms of the GNU General Public License as published by the |
|
308d34e9f07d
Changed bulk of GPLv2 or later files identified by script
Mats Lidell <matsl@xemacs.org>
parents:
1275
diff
changeset
|
15 ;; Free Software Foundation, either version 3 of the License, or (at your |
|
308d34e9f07d
Changed bulk of GPLv2 or later files identified by script
Mats Lidell <matsl@xemacs.org>
parents:
1275
diff
changeset
|
16 ;; option) any later version. |
| 428 | 17 |
|
5402
308d34e9f07d
Changed bulk of GPLv2 or later files identified by script
Mats Lidell <matsl@xemacs.org>
parents:
1275
diff
changeset
|
18 ;; XEmacs is distributed in the hope that it will be useful, but WITHOUT |
|
308d34e9f07d
Changed bulk of GPLv2 or later files identified by script
Mats Lidell <matsl@xemacs.org>
parents:
1275
diff
changeset
|
19 ;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or |
|
308d34e9f07d
Changed bulk of GPLv2 or later files identified by script
Mats Lidell <matsl@xemacs.org>
parents:
1275
diff
changeset
|
20 ;; FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License |
|
308d34e9f07d
Changed bulk of GPLv2 or later files identified by script
Mats Lidell <matsl@xemacs.org>
parents:
1275
diff
changeset
|
21 ;; for more details. |
| 428 | 22 |
| 23 ;; You should have received a copy of the GNU General Public License | |
|
5402
308d34e9f07d
Changed bulk of GPLv2 or later files identified by script
Mats Lidell <matsl@xemacs.org>
parents:
1275
diff
changeset
|
24 ;; along with XEmacs. If not, see <http://www.gnu.org/licenses/>. |
| 428 | 25 |
| 26 ;;; Synched up with: Not in FSF. | |
| 27 | |
| 28 ;;; Commentary: | |
| 29 | |
| 30 ;; This file is dumped with XEmacs. | |
| 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 | |
| 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). | |
| 1275 | 235 (if (and start (>= start end)) nil start)) |
| 428 | 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). | |
| 1275 | 249 (if (and retval (>= retval end)) nil retval)))) |
| 428 | 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 |