;;; text-props.el --- implements properties of characters

;; Copyright (C) 1993, 1994 Free Software Foundation, Inc.
;; Copyright (C) 1995 Amdahl Corporation.

;; Keywords: extensions, wp, faces
;; Author: Jamie Zawinski <jwz@lucid.com>
;; Modified: Ben Wing <wing@netcom.com> -- many of the Lisp functions below
;;           were completely broken.
;;
;; 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, 675 Mass Ave, Cambridge, MA 02139, USA.


;;; Commentary:

;;; This is a nearly complete implementation of the FSF19 text properties API,
;;; except that this code currently only works on buffers, not strings.
;;; 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 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:


;; The following functions were ported to C for speed; the overhead of doing
;; this many full lisp function calls was not small.

;;;;###autoload
;(defun put-text-property (start end prop value &optional buffer)
;  "Adds the given property/value to all characters in the specified region.
;The property is conceptually attached to the characters rather than the
;region.  The properties are copied when the characters are copied/pasted."
;  (put-text-property-1 start end prop value buffer t)
;  prop)
;
;;;;###autoload
;(defun put-nonduplicable-text-property (start end prop value &optional buffer)
;  "Adds the given property/value to all characters in the specified region.
;The property is conceptually attached to the characters rather than the
;region, however the properties will not be copied the characters are copied."
;  (put-text-property-1 start end prop value buffer nil)
;  prop)
;
;(defun put-text-property-1 (start end prop value buffer duplicable)
;  ;; returns whether any property of a character was changed
;  (if (= start end)
;      nil
;    (save-excursion
;      (and buffer (set-buffer buffer))
;      (let ((the-extent nil)
;	    (changed nil))
;	;; prop, value, the-extent, start, end, and changed are of dynamic
;	;; scope.  changed and the-extent are assigned.
;	(map-extents (function put-text-property-mapper) nil
;		     (max 1 (1- start))
;		     (min (buffer-size) (1+ end)))
;
;	;; If we made it through the loop without reusing an extent
;	;; (and we want there to be one) make it now.
;	(cond ((and value (not the-extent))
;	       (setq the-extent (make-extent start end))
;	       (set-extent-property the-extent 'text-prop prop)
;	       (set-extent-property the-extent prop value)
;	       (setq changed t)
;	       (cond (duplicable
;		      (set-extent-property the-extent 'duplicable t)
;		      (set-extent-property the-extent 'paste-function
;					   'text-prop-extent-paste-function)))
;	       ))
;	changed))))
;
;(defun put-text-property-mapper (e ignore)
;  ;; prop, value, the-extent, start, end, and changed are of dynamic scope.
;  ;; changed and the-extent are assigned.
;  (let ((e-start (extent-start-position e))
;	(e-end (extent-end-position e))
;	(e-val (extent-property e prop)))
;    (cond ((not (eq (extent-property e 'text-prop) prop))
;           ;; It's not for this property; do nothing.
;           nil)
;
;	  ((and value
;		(not the-extent)
;		(eq value e-val))
;	   ;; we want there to be an extent here at the end, and we haven't
;	   ;; picked one yet, so use this one.  Extend it as necessary.
;	   ;; We only reuse an extent which has an EQ value for the prop in
;	   ;; question to avoid side-effecting the kill ring (that is, we
;	   ;; never change the property on an extent after it has been
;	   ;; created.)
;	   (cond
;	    ((or (/= e-start start) (/= e-end end))
;	     (set-extent-endpoints e (min e-start start) (max e-end end))
;	     (setq changed t)))
;	   (setq the-extent e))
;
;	  ;; Even if we're adding a prop, at this point, we want all other
;	  ;; extents of this prop to go away (as now they overlap.)
;	  ;; So the theory here is that, when we are adding a prop to a
;	  ;; region that has multiple (disjoint) occurences of that prop
;	  ;; in it already, we pick one of those and extend it, and remove
;	  ;; the others.
;
;	  ((eq e the-extent)
;	   ;; just in case map-extents hits it again (does that happen?)
;	   nil)
;
;	  ((and (>= e-start start)
;		(<= e-end end))
;	   ;; extent is contained in region; remove it.  Don't destroy or
;	   ;; modify it, because we don't want to change the attributes
;	   ;; pointed to by the duplicates in the kill ring.
;	   (setq changed t)
;	   (detach-extent e))
;
;	  ((and the-extent
;		(eq value e-val)
;		(<= e-start end)
;		(>= e-end start))
;	   ;; this extent overlaps, and has the same prop/value as the
;	   ;; extent we've decided to reuse, so we can remove this existing
;	   ;; extent as well (the whole thing, even the part outside of the
;	   ;; region) and extend the-extent to cover it, resulting in the
;	   ;; minimum number of extents in the buffer.
;	   (cond
;	    ((and (/= (extent-start-position the-extent) e-start)
;		  (/= (extent-end-position the-extent) e-end))
;	     (set-extent-endpoints the-extent
;				   (min (extent-start-position the-extent)
;					e-start)
;				   (max (extent-end-position the-extent)
;					e-end))
;	     (setq changed t)))
;	   (detach-extent e))
;
;	  ((<= (extent-end-position e) end)
;	   ;; extent begins before start but ends before end,
;	   ;; so we can just decrease its end position.
;	   (if (and (= (extent-start-position e) e-start)
;		    (= (extent-end-position e) start))
;	       nil
;	     (set-extent-endpoints e e-start start)
;	     (setq changed t)))
;
;	  ((>= (extent-start-position e) start)
;	   ;; extent ends after end but begins after start,
;	   ;; so we can just increase its start position.
;	   (if (and (= (extent-start-position e) end)
;		    (= (extent-start-position e) e-end))
;	       nil
;	     (set-extent-endpoints e end e-end)
;	     (setq changed t)))
;
;	  (t
;	   ;; Otherwise, the extent straddles the region.
;	   ;; We need to split it.
;	   (set-extent-endpoints e e-start start)
;	   (setq e (copy-extent e))
;	   (set-extent-endpoints e end e-end)
;	   (setq changed t))))
;  ;; return nil to continue mapping over region.
;  nil)
;
;
;(defun text-prop-extent-paste-function (extent from to)
;  ;; Whenever a text-prop extent is pasted into a buffer (via `yank' or
;  ;; `insert' or whatever) we attach the properties to the buffer by calling
;  ;; `put-text-property' instead of by simply alowing the extent to be copied
;  ;; or re-attached.  Then we return nil, telling the C code not to attach
;  ;; it again. By handing the insertion hackery in this way, we make kill/yank
;  ;; behave consistently iwth put-text-property and not fragment the extents
;  ;; (since text-prop extents must partition, not overlap.)
;  (let* ((prop (or (extent-property extent 'text-prop)
;		   (error "internal error: no text-prop on %S" extent)))
;	 (val (or (extent-property extent prop)
;		  (error "internal error: no text-prop %S on %S"
;			 prop extent))))
;    (put-text-property from to prop val)
;    nil))
;		     
;;;;###autoload
;(defun add-text-properties (start end props &optional buffer)
;  "Add properties to the characters from START to END.
;The third argument PROPS is a property list specifying the property values
;to add.  The optional fourth argument, OBJECT, is the buffer containing the
;text.  Returns t if any property was changed, nil otherwise."
;  (let ((changed nil))
;    (while props
;      (setq changed
;	    (or (put-text-property-1 start end (car props) (car (cdr props))
;				     buffer t)
;		changed))
;      (setq props (cdr (cdr props))))
;    changed))
;
;;;;###autoload
;(defun remove-text-properties (start end props &optional buffer)
;  "Remove the given properties from all characters in the specified region.
;PROPS should be a plist, but the values in that plist are ignored (treated
;as nil.)  Returns t if any property was changed, nil otherwise."
;  (let ((changed nil))
;    (while props
;      (setq changed
;	    (or (put-text-property-1 start end (car props) nil buffer t)
;		changed))
;      (setq props (cdr (cdr props))))
;    changed))
;
;;;;###autoload
(defun set-text-properties (start end props &optional buffer)
  "You should NEVER use this function.  It is ideologically blasphemous.
It is provided only to ease porting of broken FSF Emacs programs."
  (map-extents #'(lambda (extent ignored)
		   (remove-text-properties start end
					   (list (extent-property extent
								  'text-prop)
						 nil)
					   buffer))
	       buffer start end nil nil 'text-prop)
  (add-text-properties start end props buffer))


;;; The following functions can probably stay in lisp, since they're so simple.

;;;###autoload
(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 text-props-only)
  (let ((extent nil)
	(props nil)
	new-props)
    (while (setq extent (extent-at position buffer
				   (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))

;;;###autoload
(defun extent-properties-at (position &optional buffer)
  "Returns the properties of the character at the given position,
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.

This returns all properties on all extents."
  (extent-properties-at-1 position buffer nil))

;;;###autoload
(defun text-properties-at (position &optional buffer)
  "Returns the properties of the character at the given position,
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.

This returns only those properties added with `put-text-property'.
See also `extent-properties-at'."
  (extent-properties-at-1 position buffer t))

;;;###autoload
(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.
The optional fifth argument, OBJECT, is the buffer containing the text."
  (while (and start (< start end)
	      (not (eq value (get-text-property start prop buffer))))
    (setq start (next-single-property-change start prop buffer 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))

;;;###autoload
(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.
The optional fifth argument, OBJECT, is the buffer containing the text."
  (if (not (eq value (get-text-property start prop buffer)))
      start
    (let ((retval (next-single-property-change start prop buffer 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))))

;;;###autoload
(defun next-property-change (pos &optional buffer limit)
  "Return the position of next property change.
Scans forward from POS in BUFFER (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 (point-max buffer)))
    (let ((value (extent-properties-at pos buffer)))
      (while
	  (and (< (setq pos (next-extent-change pos buffer)) limit)
	       (plists-eq value (extent-properties-at pos buffer)))))
    (if (< pos limit) pos
      (if limit-was-nil nil
	limit))))

;;;###autoload
(defun previous-property-change (pos &optional buffer limit)
  "Return the position of previous property change.
Scans backward from POS in BUFFER (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 (point-min buffer)))
    (let ((value (extent-properties-at (1- pos) buffer)))
      (while
	  (and (> (setq pos (previous-extent-change pos buffer)) limit)
	       (plists-eq value (extent-properties-at (1- pos) buffer)))))
    (if (> pos limit) pos
      (if limit-was-nil nil
	limit))))

;(defun detach-all-extents (&optional buffer)
;  (map-extents #'(lambda (x i) (detach-extent x) nil)
;	       buffer))

;(defun buffer-extents (&optional buffer)
;  (let* ((e (next-extent buffer))
;	 (rest (list e)))
;    (while (setq e (next-extent e)) (setq rest (cons e rest)))
;    (nreverse rest)))


(provide 'text-props)

;;; text-props.el ends here
