1 /* Interface code for dealing with text properties.
2 Copyright (C) 1992 Free Software Foundation, Inc.
4 This file is part of GNU Emacs.
6 GNU Emacs is free software; you can redistribute it and/or modify
7 it under the terms of the GNU General Public License as published by
8 the Free Software Foundation; either version 1, or (at your option)
11 GNU Emacs is distributed in the hope that it will be useful,
12 but WITHOUT ANY WARRANTY; without even the implied warranty of
13 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
14 GNU General Public License for more details.
16 You should have received a copy of the GNU General Public License
17 along with GNU Emacs; see the file COPYING. If not, write to
18 the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */
22 #include "intervals.h"
26 /* NOTES: previous- and next- property change will have to skip
27 zero-length intervals if they are implemented. This could be done
28 inside next_interval and previous_interval.
30 set_properties needs to deal with the interval property cache.
32 It is assumed that for any interval plist, a property appears
33 only once on the list. Although some code i.e., remove_properties (),
34 handles the more general case, the uniqueness of properties is
35 neccessary for the system to remain consistent. This requirement
36 is enforced by the subrs installing properties onto the intervals. */
38 /* The rest of the file is within this conditional */
39 #ifdef USE_TEXT_PROPERTIES
42 Lisp_Object Qmouse_left
;
43 Lisp_Object Qmouse_entered
;
44 Lisp_Object Qpoint_left
;
45 Lisp_Object Qpoint_entered
;
46 Lisp_Object Qmodification
;
48 /* Visual properties text (including strings) may have. */
49 Lisp_Object Qforeground
, Qbackground
, Qfont
, Qunderline
, Qstipple
;
50 Lisp_Object Qinvisible
, Qread_only
;
52 /* Extract the interval at the position pointed to by BEGIN from
53 OBJECT, a string or buffer. Additionally, check that the positions
54 pointed to by BEGIN and END are within the bounds of OBJECT, and
55 reverse them if *BEGIN is greater than *END. The objects pointed
56 to by BEGIN and END may be integers or markers; if the latter, they
57 are coerced to integers.
59 Note that buffer points don't correspond to interval indices.
60 For example, point-max is 1 greater than the index of the last
61 character. This difference is handled in the caller, which uses
62 the validated points to determine a length, and operates on that.
63 Exceptions are Ftext_properties_at, Fnext_property_change, and
64 Fprevious_property_change which call this function with BEGIN == END.
65 Handle this case specially.
67 If FORCE is soft (0), it's OK to return NULL_INTERVAL. Otherwise,
68 create an interval tree for OBJECT if one doesn't exist, provided
69 the object actually contains text. In the current design, if there
70 is no text, there can be no text properties. */
76 validate_interval_range (object
, begin
, end
, force
)
77 Lisp_Object object
, *begin
, *end
;
81 CHECK_STRING_OR_BUFFER (object
, 0);
82 CHECK_NUMBER_COERCE_MARKER (*begin
, 0);
83 CHECK_NUMBER_COERCE_MARKER (*end
, 0);
85 /* If we are asked for a point, but from a subr which operates
86 on a range, then return nothing. */
87 if (*begin
== *end
&& begin
!= end
)
90 if (XINT (*begin
) > XINT (*end
))
93 n
= XFASTINT (*begin
); /* This is legit even if *begin is < 0 */
95 XFASTINT (*end
) = n
; /* because this is all we do with n. */
98 if (XTYPE (object
) == Lisp_Buffer
)
100 register struct buffer
*b
= XBUFFER (object
);
102 /* If there's no text, there are no properties. */
103 if (BUF_BEGV (b
) == BUF_ZV (b
))
104 return NULL_INTERVAL
;
106 if (!(BUF_BEGV (b
) <= XINT (*begin
) && XINT (*begin
) <= XINT (*end
)
107 && XINT (*end
) <= BUF_ZV (b
)))
108 args_out_of_range (*begin
, *end
);
111 /* Special case for point-max: return the interval for the
113 if (*begin
== *end
&& *begin
== BUF_Z (b
))
118 register struct Lisp_String
*s
= XSTRING (object
);
120 if (! (1 <= XINT (*begin
) && XINT (*begin
) <= XINT (*end
)
121 && XINT (*end
) <= s
->size
))
122 args_out_of_range (*begin
, *end
);
126 if (NULL_INTERVAL_P (i
))
127 return (force
? create_root_interval (object
) : i
);
129 return find_interval (i
, XINT (*begin
));
132 /* Validate LIST as a property list. If LIST is not a list, then
133 make one consisting of (LIST nil). Otherwise, verify that LIST
134 is even numbered and thus suitable as a plist. */
137 validate_plist (list
)
145 register Lisp_Object tail
;
146 for (i
= 0, tail
= list
; !NILP (tail
); i
++)
149 error ("Odd length text property list");
153 return Fcons (list
, Fcons (Qnil
, Qnil
));
156 #define set_properties(list,i) (i->plist = Fcopy_sequence (list))
158 /* Return nonzero if interval I has all the properties,
159 with the same values, of list PLIST. */
162 interval_has_all_properties (plist
, i
)
166 register Lisp_Object tail1
, tail2
, sym1
, sym2
;
169 /* Go through each element of PLIST. */
170 for (tail1
= plist
; ! NILP (tail1
); tail1
= Fcdr (Fcdr (tail1
)))
175 /* Go through I's plist, looking for sym1 */
176 for (tail2
= i
->plist
; ! NILP (tail2
); tail2
= Fcdr (Fcdr (tail2
)))
177 if (EQ (sym1
, Fcar (tail2
)))
179 /* Found the same property on both lists. If the
180 values are unequal, return zero. */
181 if (! EQ (Fequal (Fcar (Fcdr (tail1
)), Fcar (Fcdr (tail2
))),
185 /* Property has same value on both lists; go to next one. */
197 /* Return nonzero if the plist of interval I has any of the
198 properties of PLIST, regardless of their values. */
201 interval_has_some_properties (plist
, i
)
205 register Lisp_Object tail1
, tail2
, sym
;
207 /* Go through each element of PLIST. */
208 for (tail1
= plist
; ! NILP (tail1
); tail1
= Fcdr (Fcdr (tail1
)))
212 /* Go through i's plist, looking for tail1 */
213 for (tail2
= i
->plist
; ! NILP (tail2
); tail2
= Fcdr (Fcdr (tail2
)))
214 if (EQ (sym
, Fcar (tail2
)))
221 /* Add the properties of PLIST to the interval I, or set
222 the value of I's property to the value of the property on PLIST
223 if they are different.
225 Return nonzero if this changes I (i.e., if any members of PLIST
226 are actually added to I's plist) */
229 add_properties (plist
, i
)
233 register Lisp_Object tail1
, tail2
, sym1
, val1
;
234 register int changed
= 0;
237 /* Go through each element of PLIST. */
238 for (tail1
= plist
; ! NILP (tail1
); tail1
= Fcdr (Fcdr (tail1
)))
241 val1
= Fcar (Fcdr (tail1
));
244 /* Go through I's plist, looking for sym1 */
245 for (tail2
= i
->plist
; ! NILP (tail2
); tail2
= Fcdr (Fcdr (tail2
)))
246 if (EQ (sym1
, Fcar (tail2
)))
248 register Lisp_Object this_cdr
= Fcdr (tail2
);
250 /* Found the property. Now check its value. */
253 /* The properties have the same value on both lists.
254 Continue to the next property. */
255 if (Fequal (val1
, Fcar (this_cdr
)))
258 /* I's property has a different value -- change it */
259 Fsetcar (this_cdr
, val1
);
266 i
->plist
= Fcons (sym1
, Fcons (val1
, i
->plist
));
274 /* For any members of PLIST which are properties of I, remove them
278 remove_properties (plist
, i
)
282 register Lisp_Object tail1
, tail2
, sym
;
283 register Lisp_Object current_plist
= i
->plist
;
284 register int changed
= 0;
286 /* Go through each element of plist. */
287 for (tail1
= plist
; ! NILP (tail1
); tail1
= Fcdr (Fcdr (tail1
)))
291 /* First, remove the symbol if its at the head of the list */
292 while (! NILP (current_plist
) && EQ (sym
, Fcar (current_plist
)))
294 current_plist
= Fcdr (Fcdr (current_plist
));
298 /* Go through i's plist, looking for sym */
299 tail2
= current_plist
;
300 while (! NILP (tail2
))
302 register Lisp_Object
this = Fcdr (Fcdr (tail2
));
303 if (EQ (sym
, Fcar (this)))
305 Fsetcdr (Fcdr (tail2
), Fcdr (Fcdr (this)));
313 i
->plist
= current_plist
;
317 /* Remove all properties from interval I. Return non-zero
318 if this changes the interval. */
331 DEFUN ("text-properties-at", Ftext_properties_at
,
332 Stext_properties_at
, 1, 2, 0,
333 "Return the list of properties held by the character at POSITION\n\
334 in optional argument OBJECT, a string or buffer. If nil, OBJECT\n\
335 defaults to the current buffer.")
337 Lisp_Object pos
, object
;
343 XSET (object
, Lisp_Buffer
, current_buffer
);
345 i
= validate_interval_range (object
, &pos
, &pos
, soft
);
346 if (NULL_INTERVAL_P (i
))
352 DEFUN ("next-property-change", Fnext_property_change
,
353 Snext_property_change
, 2, 2, 0,
354 "Return the position after POSITION in OBJECT which has properties\n\
355 different from those at POSITION. OBJECT may be a string or buffer.\n\
356 Returns nil if unsuccessful.")
358 Lisp_Object pos
, object
;
360 register INTERVAL i
, next
;
362 i
= validate_interval_range (object
, &pos
, &pos
, soft
);
363 if (NULL_INTERVAL_P (i
))
366 next
= next_interval (i
);
367 while (! NULL_INTERVAL_P (next
) && intervals_equal (i
, next
))
368 next
= next_interval (next
);
370 if (NULL_INTERVAL_P (next
))
373 return next
->position
;
376 DEFUN ("next-single-property-change", Fnext_single_property_change
,
377 Snext_single_property_change
, 3, 3, 0,
378 "Return the position after POSITION in OBJECT which has a different\n\
379 value for PROPERTY than the text at POSITION. OBJECT may be a string or\n\
380 buffer. Returns nil if unsuccessful.")
383 register INTERVAL i
, next
;
384 register Lisp_Object here_val
;
386 i
= validate_interval_range (object
, &pos
, &pos
, soft
);
387 if (NULL_INTERVAL_P (i
))
390 here_val
= Fget (prop
, i
->plist
);
391 next
= next_interval (i
);
392 while (! NULL_INTERVAL_P (next
) && EQ (here_val
, Fget (prop
, next
->plist
)))
393 next
= next_interval (next
);
395 if (NULL_INTERVAL_P (next
))
398 return next
->position
;
401 DEFUN ("previous-property-change", Fprevious_property_change
,
402 Sprevious_property_change
, 2, 2, 0,
403 "Return the position preceding POSITION in OBJECT which has properties\n\
404 different from those at POSITION. OBJECT may be a string or buffer.\n\
405 Returns nil if unsuccessful.")
407 Lisp_Object pos
, object
;
409 register INTERVAL i
, previous
;
411 i
= validate_interval_range (object
, &pos
, &pos
, soft
);
412 if (NULL_INTERVAL_P (i
))
415 previous
= previous_interval (i
);
416 while (! NULL_INTERVAL_P (previous
) && intervals_equal (previous
, i
))
417 previous
= previous_interval (previous
);
418 if (NULL_INTERVAL_P (previous
))
421 return previous
->position
+ LENGTH (previous
) - 1;
424 DEFUN ("previous-single-property-change", Fprevious_single_property_change
,
425 Sprevious_single_property_change
, 3, 3, 0,
426 "Return the position preceding POSITION in OBJECT which has a\n\
427 different value for PROPERTY than the text at POSITION. OBJECT may be
428 a string or buffer. Returns nil if unsuccessful.")
431 register INTERVAL i
, previous
;
432 register Lisp_Object here_val
;
434 i
= validate_interval_range (object
, &pos
, &pos
, soft
);
435 if (NULL_INTERVAL_P (i
))
438 here_val
= Fget (prop
, i
->plist
);
439 previous
= previous_interval (i
);
440 while (! NULL_INTERVAL_P (previous
)
441 && EQ (here_val
, Fget (prop
, previous
->plist
)))
442 previous
= previous_interval (previous
);
443 if (NULL_INTERVAL_P (previous
))
446 return previous
->position
+ LENGTH (previous
) - 1;
449 DEFUN ("add-text-properties", Fadd_text_properties
,
450 Sadd_text_properties
, 4, 4, 0,
451 "Add the PROPERTIES, a property list, to the text of OBJECT,\n\
452 a string or buffer, in the range START to END. Returns t if any change\n\
453 was made, nil otherwise.")
454 (object
, start
, end
, properties
)
455 Lisp_Object object
, start
, end
, properties
;
457 register INTERVAL i
, unchanged
;
458 register int s
, len
, modified
;
460 properties
= validate_plist (properties
);
461 if (NILP (properties
))
464 i
= validate_interval_range (object
, &start
, &end
, hard
);
465 if (NULL_INTERVAL_P (i
))
469 len
= XINT (end
) - s
;
471 /* If we're not starting on an interval boundary, we have to
472 split this interval. */
473 if (i
->position
!= s
)
475 /* If this interval already has the properties, we can
477 if (interval_has_all_properties (properties
, i
))
479 int got
= (LENGTH (i
) - (s
- i
->position
));
487 i
= split_interval_right (unchanged
, s
- unchanged
->position
+ 1);
488 copy_properties (unchanged
, i
);
489 if (LENGTH (i
) > len
)
491 i
= split_interval_left (i
, len
+ 1);
492 copy_properties (unchanged
, i
);
493 add_properties (properties
, i
);
497 add_properties (properties
, i
);
500 i
= next_interval (i
);
504 /* We are at the beginning of an interval, with len to scan */
507 if (LENGTH (i
) >= len
)
509 if (interval_has_all_properties (properties
, i
))
510 return modified
? Qt
: Qnil
;
512 if (LENGTH (i
) == len
)
514 add_properties (properties
, i
);
518 /* i doesn't have the properties, and goes past the change limit */
520 i
= split_interval_left (unchanged
, len
+ 1);
521 copy_properties (unchanged
, i
);
522 add_properties (properties
, i
);
527 modified
+= add_properties (properties
, i
);
528 i
= next_interval (i
);
532 DEFUN ("set-text-properties", Fset_text_properties
,
533 Sset_text_properties
, 4, 4, 0,
534 "Make the text of OBJECT, a string or buffer, have precisely\n\
535 PROPERTIES, a list of properties, in the range START to END.\n\
537 If called with a valid property list, return t (text was changed).\n\
538 Otherwise return nil.")
539 (object
, start
, end
, properties
)
540 Lisp_Object object
, start
, end
, properties
;
542 register INTERVAL i
, unchanged
;
543 register INTERVAL prev_changed
= NULL_INTERVAL
;
546 properties
= validate_plist (properties
);
547 if (NILP (properties
))
550 i
= validate_interval_range (object
, &start
, &end
, hard
);
551 if (NULL_INTERVAL_P (i
))
555 len
= XINT (end
) - s
;
557 if (i
->position
!= s
)
560 i
= split_interval_right (unchanged
, s
- unchanged
->position
+ 1);
561 set_properties (properties
, i
);
563 if (LENGTH (i
) > len
)
565 i
= split_interval_right (i
, len
);
566 copy_properties (unchanged
, i
);
570 if (LENGTH (i
) == len
)
575 i
= next_interval (i
);
578 /* We are starting at the beginning of an interval, I */
581 if (LENGTH (i
) >= len
)
583 if (LENGTH (i
) > len
)
584 i
= split_interval_left (i
, len
+ 1);
586 if (NULL_INTERVAL_P (prev_changed
))
587 set_properties (properties
, i
);
589 merge_interval_left (i
);
594 if (NULL_INTERVAL_P (prev_changed
))
596 set_properties (properties
, i
);
600 prev_changed
= i
= merge_interval_left (i
);
602 i
= next_interval (i
);
608 DEFUN ("remove-text-properties", Fremove_text_properties
,
609 Sremove_text_properties
, 4, 4, 0,
610 "Remove the PROPERTIES, a property list, from the text of OBJECT,\n\
611 a string or buffer, in the range START to END. Returns t if any change\n\
612 was made, nil otherwise.")
613 (object
, start
, end
, properties
)
614 Lisp_Object object
, start
, end
, properties
;
616 register INTERVAL i
, unchanged
;
617 register int s
, len
, modified
;
619 i
= validate_interval_range (object
, &start
, &end
, soft
);
620 if (NULL_INTERVAL_P (i
))
624 len
= XINT (end
) - s
;
626 if (i
->position
!= s
)
628 /* No properties on this first interval -- return if
629 it covers the entire region. */
630 if (! interval_has_some_properties (properties
, i
))
632 int got
= (LENGTH (i
) - (s
- i
->position
));
637 /* Remove the properties from this interval. If it's short
638 enough, return, splitting it if it's too short. */
642 i
= split_interval_right (unchanged
, s
- unchanged
->position
+ 1);
643 copy_properties (unchanged
, i
);
644 if (LENGTH (i
) > len
)
646 i
= split_interval_left (i
, len
+ 1);
647 copy_properties (unchanged
, i
);
648 remove_properties (properties
, i
);
652 remove_properties (properties
, i
);
655 i
= next_interval (i
);
659 /* We are at the beginning of an interval, with len to scan */
662 if (LENGTH (i
) >= len
)
664 if (! interval_has_some_properties (properties
, i
))
665 return modified
? Qt
: Qnil
;
667 if (LENGTH (i
) == len
)
669 remove_properties (properties
, i
);
673 /* i has the properties, and goes past the change limit */
674 unchanged
= split_interval_right (i
, len
+ 1);
675 copy_properties (unchanged
, i
);
676 remove_properties (properties
, i
);
681 modified
+= remove_properties (properties
, i
);
682 i
= next_interval (i
);
686 DEFUN ("erase-text-properties", Ferase_text_properties
,
687 Serase_text_properties
, 3, 3, 0,
688 "Remove all text properties from OBJECT (a string or buffer), in the\n\
689 range START to END. Returns t if any change was made, nil otherwise.")
691 Lisp_Object object
, start
, end
;
694 register INTERVAL prev_changed
= NULL_INTERVAL
;
695 register int s
, len
, modified
;
697 i
= validate_interval_range (object
, &start
, &end
, soft
);
698 if (NULL_INTERVAL_P (i
))
702 len
= XINT (end
) - s
;
704 if (i
->position
!= s
)
707 register INTERVAL unchanged
= i
;
709 /* If there are properties here, then this text will be modified. */
710 if (! NILP (i
->plist
))
712 i
= split_interval_right (unchanged
, s
- unchanged
->position
+ 1);
716 if (LENGTH (i
) > len
)
718 i
= split_interval_right (i
, len
+ 1);
719 copy_properties (unchanged
, i
);
723 if (LENGTH (i
) == len
)
728 /* If the text of I is without any properties, and contains
729 LEN or more characters, then we may return without changing
731 else if (LENGTH (i
) - (s
- i
->position
) <= len
)
733 /* The amount of text to change extends past I, so just note
734 how much we've gotten. */
736 got
= LENGTH (i
) - (s
- i
->position
);
740 i
= next_interval (i
);
743 /* We are starting at the beginning of an interval, I. */
746 if (LENGTH (i
) >= len
)
748 /* If I has no properties, simply merge it if possible. */
751 if (! NULL_INTERVAL_P (prev_changed
))
752 merge_interval_left (i
);
754 return modified
? Qt
: Qnil
;
757 if (LENGTH (i
) > len
)
758 i
= split_interval_left (i
, len
+ 1);
759 if (! NULL_INTERVAL_P (prev_changed
))
760 merge_interval_left (i
);
767 /* Here if we still need to erase past the end of I */
769 if (NULL_INTERVAL_P (prev_changed
))
771 modified
+= erase_properties (i
);
776 modified
+= ! NILP (i
->plist
);
777 /* Merging I will give it the properties of PREV_CHANGED. */
778 prev_changed
= i
= merge_interval_left (i
);
781 i
= next_interval (i
);
784 return modified
? Qt
: Qnil
;
790 DEFVAR_INT ("interval-balance-threshold", &interval_balance_threshold
,
791 "Threshold for rebalancing interval trees, expressed as the
792 percentage by which the left interval tree should not differ from the right.");
793 interval_balance_threshold
= 8;
795 /* Common attributes one might give text */
797 staticpro (&Qforeground
);
798 Qforeground
= intern ("foreground");
799 staticpro (&Qbackground
);
800 Qbackground
= intern ("background");
802 Qfont
= intern ("font");
803 staticpro (&Qstipple
);
804 Qstipple
= intern ("stipple");
805 staticpro (&Qunderline
);
806 Qunderline
= intern ("underline");
807 staticpro (&Qread_only
);
808 Qread_only
= intern ("read-only");
809 staticpro (&Qinvisible
);
810 Qinvisible
= intern ("invisible");
812 /* Properties that text might use to specify certain actions */
814 staticpro (&Qmouse_left
);
815 Qmouse_left
= intern ("mouse-left");
816 staticpro (&Qmouse_entered
);
817 Qmouse_entered
= intern ("mouse-entered");
818 staticpro (&Qpoint_left
);
819 Qpoint_left
= intern ("point-left");
820 staticpro (&Qpoint_entered
);
821 Qpoint_entered
= intern ("point-entered");
822 staticpro (&Qmodification
);
823 Qmodification
= intern ("modification");
825 defsubr (&Stext_properties_at
);
826 defsubr (&Snext_property_change
);
827 defsubr (&Snext_single_property_change
);
828 defsubr (&Sprevious_property_change
);
829 defsubr (&Sprevious_single_property_change
);
830 defsubr (&Sadd_text_properties
);
831 defsubr (&Sset_text_properties
);
832 defsubr (&Sremove_text_properties
);
833 defsubr (&Serase_text_properties
);
838 lose
-- this shouldn
't be compiled if USE_TEXT_PROPERTIES isn't defined
840 #endif /* USE_TEXT_PROPERTIES */