--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/lisp/text-props.el	Mon Aug 13 10:04:58 2007 +0200
@@ -0,0 +1,401 @@
+;;; text-props.el --- implements properties of characters
+
+;; Copyright (C) 1993-4, 1997  Free Software Foundation, Inc.
+;; Copyright (C) 1995 Amdahl Corporation.
+;; Copyright (C) 1995 Ben Wing.
+
+;; Author: Jamie Zawinski <jwz@netscape.com>
+;; Maintainer: XEmacs Development Team
+;; Keywords: extensions, wp, faces, dumped
+
+;; This file is part of XEmacs.
+
+;; XEmacs is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+
+;; XEmacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with XEmacs; see the file COPYING.  If not, write to the Free
+;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
+;; 02111-1307, USA.
+
+;;; Synched up with: Not in FSF.
+
+;;; Commentary:
+
+;; This file is dumped with XEmacs.
+
+;; This is a nearly complete implementation of the FSF19 text properties API.
+;; Please let me know if you notice any differences in behavior between
+;; this implementation and the FSF implementation.
+
+;; However, keep in mind that this interface has been implemented because it
+;; is useful.  Compatibility with code written for FSF19 is a secondary goal
+;; to having a clean and useful interface.
+
+;; The cruftier parts of the FSF API, such as the special handling of
+;; properties like `mouse-face', `front-sticky', and other properties whose
+;; value is a list of names of *other* properties set at this position, are
+;; not implemented.  The reason for this is that if you feel you need that
+;; kind of functionality, it's a good hint that you should be using extents
+;; instead of text properties.
+
+;; When should I use Text Properties, and when should I use Extents?
+;; ==================================================================
+
+;; If you are putting a `button' or `hyperlink' of some kind into a buffer,
+;; the most natural interface is one which deals with properties of regions
+;; with explicit endpoints that behave more-or-less like markers.  That is
+;; what `make-extent', `extent-at', and `extent-property' are for.
+
+;; If you are dealing with styles of text, where things do not have explicit
+;; endpoints (as is done in font-lock.el and shell-font.el) or if you want to
+;; partition a buffer (that is, change some attribute of a range from one
+;; value to another without disturbing the properties outside of that range)
+;; then an interface that deals with properties of characters may be most
+;; natural.  
+
+;; Another way of thinking of it is, do you care where the endpoints of the
+;; region are?  If you do, then you should use extents.  If it's ok for the
+;; region to become divided, and for two regions with identical properties to
+;; be merged into one region, then you might want to use text properties.
+
+;; Some applications want the attributes they add to be copied by the killing
+;; and yanking commands, and some do not.  This is orthogonal to whether text
+;; properties or extents are used.  Remember that text properties are
+;; implemented in terms of extents, so anything you can do with one you can
+;; do with the other.  It's just a matter of which way of creating and
+;; managing them is most appropriate to your application.
+
+;; Implementation details:
+;; =======================
+
+;; This package uses extents with a non-nil 'text-prop property.  It assumes
+;; free reign over the endpoints of any extent with that property.  It will
+;; not alter any extent which does not have that property.
+
+;; Right now, the text-property functions create one extent for each distinct
+;; property; that is, if a range of text has two text-properties on it, there
+;; will be two extents.  As the set of text-properties is going to be small,
+;; this is probably not a big deal.  It would be possible to share extents.
+
+;; One tricky bit is that undo/kill/yank must be made to not fragment things:
+;; these extents must not be allowed to overlap.  We accomplish this by using
+;; a custom `paste-function' property on the extents.
+
+;; shell-font.el and font-lock.el could put-text-property to attach fonts to
+;; the buffer.  However, what these packages are interested in is the
+;; efficient extent partitioning behavior which this code exhibits, not the
+;; duplicability aspect of it.  In fact, either of these packages could be
+;; implemented by creating a one-character non-expandable extent for each
+;; character in the buffer, except that that would be extremely wasteful of
+;; memory.  (Redisplay performance would be fine, however.)
+
+;; If these packages were to use put-text-property to make the extents, then
+;; when one copied text from a shell buffer or a font-locked source buffer
+;; and pasted it somewhere else (a sendmail buffer, or a buffer not in
+;; font-lock mode) then the fonts would follow, and there's no easy way to
+;; get rid of them (other than pounding out a call to put-text-property by
+;; hand.)  This is annoying.  Maybe it wouldn't be so annoying if there was a
+;; more general set of commands for handling styles of text (in fact, if
+;; there were such a thing, copying the fonts would probably be exactly what
+;; one wanted) but we aren't there yet.  So these packages use the interface
+;; of `put-nonduplicable-text-property' which is the same, except that it
+;; doesn't make duplicable extents.
+
+;; `put-text-property' and `put-nonduplicable-text-property' don't get along:
+;; they will interfere with each other, reusing each others' extents without
+;; checking that the "duplicableness" is correct.  This is a bug, but it's
+;; one that I don't care enough to fix this right now.
+
+;;; Code:
+
+(defun set-text-properties (start end props &optional buffer-or-string)
+  "You should NEVER use this function.  It is ideologically blasphemous.
+It is provided only to ease porting of broken FSF Emacs programs.
+Instead, use `remove-text-properties' to remove the specific properties
+you do not want.
+
+Completely replace properties of text from START to END.
+The third argument PROPS is the new property list.
+The optional fourth argument, BUFFER-OR-STRING,
+is the string or buffer containing the text."
+  (map-extents #'(lambda (extent ignored)
+		   ;; #### dmoore - shouldn't this use
+		   ;; (extent-start-position extent)
+		   ;; (extent-end-position extent)
+		   (remove-text-properties start end
+					   (list (extent-property extent
+								  'text-prop)
+						 nil)
+					   buffer-or-string)
+		   nil)
+	       buffer-or-string start end nil nil 'text-prop)
+  (add-text-properties start end props buffer-or-string))
+
+
+;;; The following functions can probably stay in lisp, since they're so simple.
+
+;(defun get-text-property (pos prop &optional buffer)
+;  "Returns the value of the PROP property at the given position."
+;  (let ((e (extent-at pos buffer prop)))
+;    (if e
+;	(extent-property e prop)
+;      nil)))
+
+(defun extent-properties-at-1 (position buffer-or-string text-props-only)
+  (let ((extent nil)
+	(props nil)
+	new-props)
+    (while (setq extent (extent-at position buffer-or-string
+				   (if text-props-only 'text-prop nil)
+				   extent))
+      (if text-props-only
+	  ;; Only return the one prop which the `text-prop' property points at.
+	  (let ((prop (extent-property extent 'text-prop)))
+	    (setq new-props (list prop (extent-property extent prop))))
+	;; Return all the properties...
+	(setq new-props (extent-properties extent))
+	;; ...but!  Don't return the `begin-glyph' or `end-glyph' properties
+	;; unless the position is exactly at the appropriate endpoint.  Yeah,
+	;; this is kind of a kludge.
+	;; #### Bug, this doesn't work for end-glyphs (on end-open extents)
+	;; because we've already passed the extent with the glyph by the time
+	;; it's appropriate to return the glyph.  We could return the end
+	;; glyph one character early I guess...  But then next-property-change
+	;; would have to stop one character early as well.  It could back up
+	;; when it hit an end-glyph...
+	;; #### Another bug, if there are multiple glyphs at the same position,
+	;; we only see the first one.
+	(cond ((or (extent-begin-glyph extent) (extent-end-glyph extent))
+	       (if (/= position (if (extent-property extent 'begin-glyph)
+				    (extent-start-position extent)
+				  (extent-end-position extent)))
+		   (let ((rest new-props)
+			 prev)
+		     (while rest
+		       (cond ((or (eq (car rest) 'begin-glyph)
+				  (eq (car rest) 'end-glyph))
+			      (if prev
+				  (setcdr prev (cdr (cdr rest)))
+				(setq new-props (cdr (cdr new-props))))
+			      (setq rest nil)))
+		       (setq prev rest
+			     rest (cdr rest))))))))
+      (cond ((null props)
+	     (setq props new-props))
+	    (t
+	     (while new-props
+	       (or (getf props (car new-props))
+		   (setq props (cons (car new-props)
+				     (cons (car (cdr new-props))
+					   props))))
+	       (setq new-props (cdr (cdr new-props)))))))
+    props))
+
+(defun extent-properties-at (position &optional object)
+  "Returns the properties of the character at the given position
+in OBJECT (a string or buffer) by merging the properties of overlapping
+extents.  The returned value is a property list, some of which may be
+shared with other structures.  You must not modify it.
+
+If POSITION is at the end of OBJECT, the value is nil.
+
+This returns all properties on all extents.
+See also `text-properties-at'."
+  (extent-properties-at-1 position object nil))
+
+(defun text-properties-at (position &optional object)
+  "Returns the properties of the character at the given position
+in OBJECT (a string or buffer) by merging the properties of overlapping
+extents.  The returned value is a property list, some of which may be
+shared with other structures.  You must not modify it.
+
+If POSITION is at the end of OBJECT, the value is nil.
+
+This returns only those properties added with `put-text-property'.
+See also `extent-properties-at'."
+  (extent-properties-at-1 position object t))
+
+(defun text-property-any (start end prop value &optional buffer-or-string)
+  "Check text from START to END to see if PROP is ever `eq' to VALUE.
+If so, return the position of the first character whose PROP is `eq'
+to VALUE.  Otherwise return nil.
+The optional fifth argument, BUFFER-OR-STRING, is the buffer or string
+containing the text and defaults to the current buffer."
+  (while (and start (< start end)
+	      (not (eq value (get-text-property start prop buffer-or-string))))
+    (setq start (next-single-property-change start prop buffer-or-string end)))
+  ;; we have to insert a special check for end due to the illogical
+  ;; definition of next-single-property-change (blame FSF for this).
+  (if (eq start end) nil start))
+
+(defun text-property-not-all (start end prop value &optional buffer-or-string)
+  "Check text from START to END to see if PROP is ever not `eq' to VALUE.
+If so, return the position of the first character whose PROP is not
+`eq' to VALUE.  Otherwise, return nil.
+The optional fifth argument, BUFFER-OR-STRING, is the buffer or string
+containing the text and defaults to the current buffer."
+  (if (not (eq value (get-text-property start prop buffer-or-string)))
+      start
+    (let ((retval (next-single-property-change start prop
+					       buffer-or-string end)))
+      ;; we have to insert a special check for end due to the illogical
+      ;; definition of previous-single-property-change (blame FSF for this).
+      (if (eq retval end) nil retval))))
+
+;; Older versions that only work sometimes (when VALUE is non-nil
+;; for text-property-any, and maybe only when VALUE is nil for
+;; text-property-not-all).  They might be faster in those cases,
+;; but that's not obvious.
+
+;(defun text-property-any (start end prop value &optional buffer)
+;  "Check text from START to END to see if PROP is ever `eq' to VALUE.
+;If so, return the position of the first character whose PROP is `eq'
+;to VALUE.  Otherwise return nil."
+;  ;; #### what should (text-property-any x y 'foo nil) return when there
+;  ;; is no foo property between x and y?  Either t or nil seems sensible,
+;  ;; since a character with a property of nil is indistinguishable from
+;  ;; a character without that property set.
+;  (map-extents
+;   #'(lambda (e ignore)
+;       (if (eq value (extent-property e prop))
+;	   ;; return non-nil to stop mapping
+;	   (max start (extent-start-position e))
+;	 nil))
+;   nil start end buffer))
+;
+;(defun text-property-not-all (start end prop value &optional buffer)
+;  "Check text from START to END to see if PROP is ever not `eq' to VALUE.
+;If so, return the position of the first character whose PROP is not
+;`eq' to VALUE.  Otherwise, return nil."
+;  (let (maxend)
+;    (map-extents
+;     #'(lambda (e ignore)
+;	 ;;### no, actually, this is harder.  We need to collect all props
+;	 ;; for a given character, and then determine whether no extent
+;	 ;; contributes the given value.  Doing this without consing lots
+;	 ;; of lists is the tricky part.
+;	 (if (eq value (extent-property e prop))
+;	     (progn
+;	       (setq maxend (extent-end-position e))
+;	       nil)
+;	   (max start maxend)))
+;     nil start end buffer)))
+
+(defun next-property-change (pos &optional buffer-or-string limit)
+  "Return the position of next property change.
+Scans forward from POS in BUFFER-OR-STRING (defaults to the current buffer)
+ until it finds a change in some text property, then returns the position of
+ the change.
+Returns nil if the properties remain unchanged all the way to the end.
+If the value is non-nil, it is a position greater than POS, never equal.
+If the optional third argument LIMIT is non-nil, don't search
+ past position LIMIT; return LIMIT if nothing is found before LIMIT.
+If two or more extents with conflicting non-nil values for a property overlap
+ a particular character, it is undefined which value is considered to be
+ the value of the property. (Note that this situation will not happen if
+ you always use the text-property primitives.)"
+  (let ((limit-was-nil (null limit)))
+    (or limit (setq limit (if (bufferp buffer-or-string)
+			      (point-max buffer-or-string)
+			    (length buffer-or-string))))
+    (let ((value (extent-properties-at pos buffer-or-string)))
+      (while
+	  (and (< (setq pos (next-extent-change pos buffer-or-string)) limit)
+	       (plists-eq value (extent-properties-at pos buffer-or-string)))))
+    (if (< pos limit) pos
+      (if limit-was-nil nil
+	limit))))
+
+(defun previous-property-change (pos &optional buffer-or-string limit)
+  "Return the position of previous property change.
+Scans backward from POS in BUFFER-OR-STRING (defaults to the current buffer)
+ until it finds a change in some text property, then returns the position of
+ the change.
+Returns nil if the properties remain unchanged all the way to the beginning.
+If the value is non-nil, it is a position less than POS, never equal.
+If the optional third argument LIMIT is non-nil, don't search back
+ past position LIMIT; return LIMIT if nothing is found until LIMIT.
+If two or more extents with conflicting non-nil values for a property overlap
+ a particular character, it is undefined which value is considered to be
+ the value of the property. (Note that this situation will not happen if
+ you always use the text-property primitives.)"
+  (let ((limit-was-nil (null limit)))
+    (or limit (setq limit (if (bufferp buffer-or-string)
+			      (point-min buffer-or-string)
+			    0)))
+    (let ((value (extent-properties-at (1- pos) buffer-or-string)))
+      (while
+	  (and (> (setq pos (previous-extent-change pos buffer-or-string))
+		  limit)
+	       (plists-eq value (extent-properties-at (1- pos)
+						      buffer-or-string)))))
+    (if (> pos limit) pos
+      (if limit-was-nil nil
+	limit))))
+
+(defun text-property-bounds (pos prop &optional object at-flag)
+  "Return the bounds of property PROP at POS.
+This returns a cons (START . END) of the largest region of text containing
+POS which has a non-nil value for PROP.  The return value is nil if POS
+does not have a non-nil value for PROP.  OBJECT specifies the buffer
+or string to search in.  Optional arg AT-FLAG controls what \"at POS\"
+means, and has the same meaning as for `extent-at'."
+  (or object (setq object (current-buffer)))
+  (and (get-char-property pos prop object at-flag)
+       (let ((begin (if (stringp object) 0 (point-min object)))
+	     (end (if (stringp object) (length object) (point-max object))))
+	 (cons (previous-single-property-change (1+ pos) prop object begin)
+	       (next-single-property-change pos prop object end)))))
+
+(defun next-text-property-bounds (count pos prop &optional object)
+  "Return the COUNTth bounded property region of property PROP after POS.
+If COUNT is less than zero, search backwards.  This returns a cons
+\(START . END) of the COUNTth maximal region of text that begins after POS
+\(starts before POS) and has a non-nil value for PROP.  If there aren't
+that many regions, nil is returned.  OBJECT specifies the buffer or
+string to search in."
+  (or object (setq object (current-buffer)))
+  (let ((begin (if (stringp object) 0 (point-min object)))
+	(end (if (stringp object) (length object) (point-max object))))
+    (catch 'hit-end
+      (if (> count 0)
+	  (progn
+	    (while (> count 0)
+	      (if (>= pos end)
+		  (throw 'hit-end nil)
+		(and (get-char-property pos prop object)
+		     (setq pos (next-single-property-change pos prop
+							    object end)))
+		(setq pos (next-single-property-change pos prop object end)))
+	      (setq count (1- count)))
+	    (and (< pos end)
+		 (cons pos (next-single-property-change pos prop object end))))
+	(while (< count 0)
+	  (if (<= pos begin)
+	      (throw 'hit-end nil)
+	    (and (get-char-property (1- pos) prop object)
+		 (setq pos (previous-single-property-change pos prop
+							    object begin)))
+	    (setq pos (previous-single-property-change pos prop object
+						       begin)))
+	  (setq count (1+ count)))
+	(and (> pos begin)
+	     (cons (previous-single-property-change pos prop object begin)
+		   pos))))))
+
+;(defun detach-all-extents (&optional buffer)
+;  (map-extents #'(lambda (x i) (detach-extent x) nil)
+;	       buffer))
+
+
+(provide 'text-props)
+
+;;; text-props.el ends here