]> code.delx.au - gnu-emacs/blob - src/textprop.c
(Fget_text_property): Simplify using Ftext_properties_at.
[gnu-emacs] / src / textprop.c
1 /* Interface code for dealing with text properties.
2 Copyright (C) 1993, 1994 Free Software Foundation, Inc.
3
4 This file is part of GNU Emacs.
5
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 2, or (at your option)
9 any later version.
10
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.
15
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. */
19
20 #include <config.h>
21 #include "lisp.h"
22 #include "intervals.h"
23 #include "buffer.h"
24 #include "window.h"
25 \f
26
27 /* NOTES: previous- and next- property change will have to skip
28 zero-length intervals if they are implemented. This could be done
29 inside next_interval and previous_interval.
30
31 set_properties needs to deal with the interval property cache.
32
33 It is assumed that for any interval plist, a property appears
34 only once on the list. Although some code i.e., remove_properties,
35 handles the more general case, the uniqueness of properties is
36 necessary for the system to remain consistent. This requirement
37 is enforced by the subrs installing properties onto the intervals. */
38
39 /* The rest of the file is within this conditional */
40 #ifdef USE_TEXT_PROPERTIES
41 \f
42 /* Types of hooks. */
43 Lisp_Object Qmouse_left;
44 Lisp_Object Qmouse_entered;
45 Lisp_Object Qpoint_left;
46 Lisp_Object Qpoint_entered;
47 Lisp_Object Qcategory;
48 Lisp_Object Qlocal_map;
49
50 /* Visual properties text (including strings) may have. */
51 Lisp_Object Qforeground, Qbackground, Qfont, Qunderline, Qstipple;
52 Lisp_Object Qinvisible, Qread_only, Qintangible;
53
54 /* Sticky properties */
55 Lisp_Object Qfront_sticky, Qrear_nonsticky;
56
57 /* If o1 is a cons whose cdr is a cons, return non-zero and set o2 to
58 the o1's cdr. Otherwise, return zero. This is handy for
59 traversing plists. */
60 #define PLIST_ELT_P(o1, o2) (CONSP (o1) && CONSP ((o2) = XCONS (o1)->cdr))
61
62 Lisp_Object Vinhibit_point_motion_hooks;
63
64 \f
65 /* Extract the interval at the position pointed to by BEGIN from
66 OBJECT, a string or buffer. Additionally, check that the positions
67 pointed to by BEGIN and END are within the bounds of OBJECT, and
68 reverse them if *BEGIN is greater than *END. The objects pointed
69 to by BEGIN and END may be integers or markers; if the latter, they
70 are coerced to integers.
71
72 When OBJECT is a string, we increment *BEGIN and *END
73 to make them origin-one.
74
75 Note that buffer points don't correspond to interval indices.
76 For example, point-max is 1 greater than the index of the last
77 character. This difference is handled in the caller, which uses
78 the validated points to determine a length, and operates on that.
79 Exceptions are Ftext_properties_at, Fnext_property_change, and
80 Fprevious_property_change which call this function with BEGIN == END.
81 Handle this case specially.
82
83 If FORCE is soft (0), it's OK to return NULL_INTERVAL. Otherwise,
84 create an interval tree for OBJECT if one doesn't exist, provided
85 the object actually contains text. In the current design, if there
86 is no text, there can be no text properties. */
87
88 #define soft 0
89 #define hard 1
90
91 static INTERVAL
92 validate_interval_range (object, begin, end, force)
93 Lisp_Object object, *begin, *end;
94 int force;
95 {
96 register INTERVAL i;
97 int searchpos;
98
99 CHECK_STRING_OR_BUFFER (object, 0);
100 CHECK_NUMBER_COERCE_MARKER (*begin, 0);
101 CHECK_NUMBER_COERCE_MARKER (*end, 0);
102
103 /* If we are asked for a point, but from a subr which operates
104 on a range, then return nothing. */
105 if (*begin == *end && begin != end)
106 return NULL_INTERVAL;
107
108 if (XINT (*begin) > XINT (*end))
109 {
110 Lisp_Object n;
111 n = *begin;
112 *begin = *end;
113 *end = n;
114 }
115
116 if (XTYPE (object) == Lisp_Buffer)
117 {
118 register struct buffer *b = XBUFFER (object);
119
120 if (!(BUF_BEGV (b) <= XINT (*begin) && XINT (*begin) <= XINT (*end)
121 && XINT (*end) <= BUF_ZV (b)))
122 args_out_of_range (*begin, *end);
123 i = b->intervals;
124
125 /* If there's no text, there are no properties. */
126 if (BUF_BEGV (b) == BUF_ZV (b))
127 return NULL_INTERVAL;
128
129 searchpos = XINT (*begin);
130 }
131 else
132 {
133 register struct Lisp_String *s = XSTRING (object);
134
135 if (! (0 <= XINT (*begin) && XINT (*begin) <= XINT (*end)
136 && XINT (*end) <= s->size))
137 args_out_of_range (*begin, *end);
138 /* User-level Positions in strings start with 0,
139 but the interval code always wants positions starting with 1. */
140 XFASTINT (*begin) += 1;
141 if (begin != end)
142 XFASTINT (*end) += 1;
143 i = s->intervals;
144
145 if (s->size == 0)
146 return NULL_INTERVAL;
147
148 searchpos = XINT (*begin);
149 }
150
151 if (NULL_INTERVAL_P (i))
152 return (force ? create_root_interval (object) : i);
153
154 return find_interval (i, searchpos);
155 }
156
157 /* Validate LIST as a property list. If LIST is not a list, then
158 make one consisting of (LIST nil). Otherwise, verify that LIST
159 is even numbered and thus suitable as a plist. */
160
161 static Lisp_Object
162 validate_plist (list)
163 Lisp_Object list;
164 {
165 if (NILP (list))
166 return Qnil;
167
168 if (CONSP (list))
169 {
170 register int i;
171 register Lisp_Object tail;
172 for (i = 0, tail = list; !NILP (tail); i++)
173 {
174 tail = Fcdr (tail);
175 QUIT;
176 }
177 if (i & 1)
178 error ("Odd length text property list");
179 return list;
180 }
181
182 return Fcons (list, Fcons (Qnil, Qnil));
183 }
184
185 /* Return nonzero if interval I has all the properties,
186 with the same values, of list PLIST. */
187
188 static int
189 interval_has_all_properties (plist, i)
190 Lisp_Object plist;
191 INTERVAL i;
192 {
193 register Lisp_Object tail1, tail2, sym1, sym2;
194 register int found;
195
196 /* Go through each element of PLIST. */
197 for (tail1 = plist; ! NILP (tail1); tail1 = Fcdr (Fcdr (tail1)))
198 {
199 sym1 = Fcar (tail1);
200 found = 0;
201
202 /* Go through I's plist, looking for sym1 */
203 for (tail2 = i->plist; ! NILP (tail2); tail2 = Fcdr (Fcdr (tail2)))
204 if (EQ (sym1, Fcar (tail2)))
205 {
206 /* Found the same property on both lists. If the
207 values are unequal, return zero. */
208 if (! EQ (Fcar (Fcdr (tail1)), Fcar (Fcdr (tail2))))
209 return 0;
210
211 /* Property has same value on both lists; go to next one. */
212 found = 1;
213 break;
214 }
215
216 if (! found)
217 return 0;
218 }
219
220 return 1;
221 }
222
223 /* Return nonzero if the plist of interval I has any of the
224 properties of PLIST, regardless of their values. */
225
226 static INLINE int
227 interval_has_some_properties (plist, i)
228 Lisp_Object plist;
229 INTERVAL i;
230 {
231 register Lisp_Object tail1, tail2, sym;
232
233 /* Go through each element of PLIST. */
234 for (tail1 = plist; ! NILP (tail1); tail1 = Fcdr (Fcdr (tail1)))
235 {
236 sym = Fcar (tail1);
237
238 /* Go through i's plist, looking for tail1 */
239 for (tail2 = i->plist; ! NILP (tail2); tail2 = Fcdr (Fcdr (tail2)))
240 if (EQ (sym, Fcar (tail2)))
241 return 1;
242 }
243
244 return 0;
245 }
246 \f
247 /* Changing the plists of individual intervals. */
248
249 /* Return the value of PROP in property-list PLIST, or Qunbound if it
250 has none. */
251 static int
252 property_value (plist, prop)
253 {
254 Lisp_Object value;
255
256 while (PLIST_ELT_P (plist, value))
257 if (EQ (XCONS (plist)->car, prop))
258 return XCONS (value)->car;
259 else
260 plist = XCONS (value)->cdr;
261
262 return Qunbound;
263 }
264
265 /* Set the properties of INTERVAL to PROPERTIES,
266 and record undo info for the previous values.
267 OBJECT is the string or buffer that INTERVAL belongs to. */
268
269 static void
270 set_properties (properties, interval, object)
271 Lisp_Object properties, object;
272 INTERVAL interval;
273 {
274 Lisp_Object sym, value;
275
276 if (BUFFERP (object))
277 {
278 /* For each property in the old plist which is missing from PROPERTIES,
279 or has a different value in PROPERTIES, make an undo record. */
280 for (sym = interval->plist;
281 PLIST_ELT_P (sym, value);
282 sym = XCONS (value)->cdr)
283 if (! EQ (property_value (properties, XCONS (sym)->car),
284 XCONS (value)->car))
285 {
286 modify_region (XBUFFER (object),
287 make_number (interval->position),
288 make_number (interval->position + LENGTH (interval)));
289 record_property_change (interval->position, LENGTH (interval),
290 XCONS (sym)->car, XCONS (value)->car,
291 object);
292 }
293
294 /* For each new property that has no value at all in the old plist,
295 make an undo record binding it to nil, so it will be removed. */
296 for (sym = properties;
297 PLIST_ELT_P (sym, value);
298 sym = XCONS (value)->cdr)
299 if (EQ (property_value (interval->plist, XCONS (sym)->car), Qunbound))
300 {
301 modify_region (XBUFFER (object),
302 make_number (interval->position),
303 make_number (interval->position + LENGTH (interval)));
304 record_property_change (interval->position, LENGTH (interval),
305 XCONS (sym)->car, Qnil,
306 object);
307 }
308 }
309
310 /* Store new properties. */
311 interval->plist = Fcopy_sequence (properties);
312 }
313
314 /* Add the properties of PLIST to the interval I, or set
315 the value of I's property to the value of the property on PLIST
316 if they are different.
317
318 OBJECT should be the string or buffer the interval is in.
319
320 Return nonzero if this changes I (i.e., if any members of PLIST
321 are actually added to I's plist) */
322
323 static int
324 add_properties (plist, i, object)
325 Lisp_Object plist;
326 INTERVAL i;
327 Lisp_Object object;
328 {
329 register Lisp_Object tail1, tail2, sym1, val1;
330 register int changed = 0;
331 register int found;
332
333 /* Go through each element of PLIST. */
334 for (tail1 = plist; ! NILP (tail1); tail1 = Fcdr (Fcdr (tail1)))
335 {
336 sym1 = Fcar (tail1);
337 val1 = Fcar (Fcdr (tail1));
338 found = 0;
339
340 /* Go through I's plist, looking for sym1 */
341 for (tail2 = i->plist; ! NILP (tail2); tail2 = Fcdr (Fcdr (tail2)))
342 if (EQ (sym1, Fcar (tail2)))
343 {
344 register Lisp_Object this_cdr;
345
346 this_cdr = Fcdr (tail2);
347 /* Found the property. Now check its value. */
348 found = 1;
349
350 /* The properties have the same value on both lists.
351 Continue to the next property. */
352 if (EQ (val1, Fcar (this_cdr)))
353 break;
354
355 /* Record this change in the buffer, for undo purposes. */
356 if (XTYPE (object) == Lisp_Buffer)
357 {
358 modify_region (XBUFFER (object),
359 make_number (i->position),
360 make_number (i->position + LENGTH (i)));
361 record_property_change (i->position, LENGTH (i),
362 sym1, Fcar (this_cdr), object);
363 }
364
365 /* I's property has a different value -- change it */
366 Fsetcar (this_cdr, val1);
367 changed++;
368 break;
369 }
370
371 if (! found)
372 {
373 /* Record this change in the buffer, for undo purposes. */
374 if (XTYPE (object) == Lisp_Buffer)
375 {
376 modify_region (XBUFFER (object),
377 make_number (i->position),
378 make_number (i->position + LENGTH (i)));
379 record_property_change (i->position, LENGTH (i),
380 sym1, Qnil, object);
381 }
382 i->plist = Fcons (sym1, Fcons (val1, i->plist));
383 changed++;
384 }
385 }
386
387 return changed;
388 }
389
390 /* For any members of PLIST which are properties of I, remove them
391 from I's plist.
392 OBJECT is the string or buffer containing I. */
393
394 static int
395 remove_properties (plist, i, object)
396 Lisp_Object plist;
397 INTERVAL i;
398 Lisp_Object object;
399 {
400 register Lisp_Object tail1, tail2, sym, current_plist;
401 register int changed = 0;
402
403 current_plist = i->plist;
404 /* Go through each element of plist. */
405 for (tail1 = plist; ! NILP (tail1); tail1 = Fcdr (Fcdr (tail1)))
406 {
407 sym = Fcar (tail1);
408
409 /* First, remove the symbol if its at the head of the list */
410 while (! NILP (current_plist) && EQ (sym, Fcar (current_plist)))
411 {
412 if (XTYPE (object) == Lisp_Buffer)
413 {
414 modify_region (XBUFFER (object),
415 make_number (i->position),
416 make_number (i->position + LENGTH (i)));
417 record_property_change (i->position, LENGTH (i),
418 sym, Fcar (Fcdr (current_plist)),
419 object);
420 }
421
422 current_plist = Fcdr (Fcdr (current_plist));
423 changed++;
424 }
425
426 /* Go through i's plist, looking for sym */
427 tail2 = current_plist;
428 while (! NILP (tail2))
429 {
430 register Lisp_Object this;
431 this = Fcdr (Fcdr (tail2));
432 if (EQ (sym, Fcar (this)))
433 {
434 if (XTYPE (object) == Lisp_Buffer)
435 {
436 modify_region (XBUFFER (object),
437 make_number (i->position),
438 make_number (i->position + LENGTH (i)));
439 record_property_change (i->position, LENGTH (i),
440 sym, Fcar (Fcdr (this)), object);
441 }
442
443 Fsetcdr (Fcdr (tail2), Fcdr (Fcdr (this)));
444 changed++;
445 }
446 tail2 = this;
447 }
448 }
449
450 if (changed)
451 i->plist = current_plist;
452 return changed;
453 }
454
455 #if 0
456 /* Remove all properties from interval I. Return non-zero
457 if this changes the interval. */
458
459 static INLINE int
460 erase_properties (i)
461 INTERVAL i;
462 {
463 if (NILP (i->plist))
464 return 0;
465
466 i->plist = Qnil;
467 return 1;
468 }
469 #endif
470 \f
471 DEFUN ("text-properties-at", Ftext_properties_at,
472 Stext_properties_at, 1, 2, 0,
473 "Return the list of properties held by the character at POSITION\n\
474 in optional argument OBJECT, a string or buffer. If nil, OBJECT\n\
475 defaults to the current buffer.\n\
476 If POSITION is at the end of OBJECT, the value is nil.")
477 (pos, object)
478 Lisp_Object pos, object;
479 {
480 register INTERVAL i;
481
482 if (NILP (object))
483 XSET (object, Lisp_Buffer, current_buffer);
484
485 i = validate_interval_range (object, &pos, &pos, soft);
486 if (NULL_INTERVAL_P (i))
487 return Qnil;
488 /* If POS is at the end of the interval,
489 it means it's the end of OBJECT.
490 There are no properties at the very end,
491 since no character follows. */
492 if (XINT (pos) == LENGTH (i) + i->position)
493 return Qnil;
494
495 return i->plist;
496 }
497
498 DEFUN ("get-text-property", Fget_text_property, Sget_text_property, 2, 3, 0,
499 "Return the value of position POS's property PROP, in OBJECT.\n\
500 OBJECT is optional and defaults to the current buffer.\n\
501 If POSITION is at the end of OBJECT, the value is nil.")
502 (pos, prop, object)
503 Lisp_Object pos, object;
504 Lisp_Object prop;
505 {
506 return textget (Ftext_properties_at (pos, object), prop);
507 }
508
509 DEFUN ("get-char-property", Fget_char_property, Sget_char_property, 2, 3, 0,
510 "Return the value of position POS's property PROP, in OBJECT.\n\
511 OBJECT is optional and defaults to the current buffer.\n\
512 If POS is at the end of OBJECT, the value is nil.\n\
513 If OBJECT is a buffer, then overlay properties are considered as well as\n\
514 text properties.\n\
515 If OBJECT is a window, then that window's buffer is used, but window-specific\n\
516 overlays are considered only if they are associated with OBJECT.")
517 (pos, prop, object)
518 Lisp_Object pos, object;
519 register Lisp_Object prop;
520 {
521 struct window *w = 0;
522
523 CHECK_NUMBER_COERCE_MARKER (pos, 0);
524
525 if (NILP (object))
526 XSET (object, Lisp_Buffer, current_buffer);
527
528 if (WINDOWP (object))
529 {
530 w = XWINDOW (object);
531 XSET (object, Lisp_Buffer, w->buffer);
532 }
533 if (BUFFERP (object))
534 {
535 int posn = XINT (pos);
536 int noverlays;
537 Lisp_Object *overlay_vec, tem;
538 int next_overlay;
539 int len;
540
541 /* First try with room for 40 overlays. */
542 len = 40;
543 overlay_vec = (Lisp_Object *) alloca (len * sizeof (Lisp_Object));
544
545 noverlays = overlays_at (posn, 0, &overlay_vec, &len, &next_overlay);
546
547 /* If there are more than 40,
548 make enough space for all, and try again. */
549 if (noverlays > len)
550 {
551 len = noverlays;
552 overlay_vec = (Lisp_Object *) alloca (len * sizeof (Lisp_Object));
553 noverlays = overlays_at (posn, 0, &overlay_vec, &len, &next_overlay);
554 }
555 noverlays = sort_overlays (overlay_vec, noverlays, w);
556
557 /* Now check the overlays in order of decreasing priority. */
558 while (--noverlays >= 0)
559 {
560 tem = Foverlay_get (overlay_vec[noverlays], prop);
561 if (!NILP (tem))
562 return (tem);
563 }
564 }
565 /* Not a buffer, or no appropriate overlay, so fall through to the
566 simpler case. */
567 return (Fget_text_property (pos, prop, object));
568 }
569
570 DEFUN ("next-property-change", Fnext_property_change,
571 Snext_property_change, 1, 3, 0,
572 "Return the position of next property change.\n\
573 Scans characters forward from POS in OBJECT till it finds\n\
574 a change in some text property, then returns the position of the change.\n\
575 The optional second argument OBJECT is the string or buffer to scan.\n\
576 Return nil if the property is constant all the way to the end of OBJECT.\n\
577 If the value is non-nil, it is a position greater than POS, never equal.\n\n\
578 If the optional third argument LIMIT is non-nil, don't search\n\
579 past position LIMIT; return LIMIT if nothing is found before LIMIT.")
580 (pos, object, limit)
581 Lisp_Object pos, object, limit;
582 {
583 register INTERVAL i, next;
584
585 if (NILP (object))
586 XSET (object, Lisp_Buffer, current_buffer);
587
588 if (!NILP (limit))
589 CHECK_NUMBER_COERCE_MARKER (limit, 0);
590
591 i = validate_interval_range (object, &pos, &pos, soft);
592 if (NULL_INTERVAL_P (i))
593 return limit;
594
595 next = next_interval (i);
596 while (! NULL_INTERVAL_P (next) && intervals_equal (i, next)
597 && (NILP (limit) || next->position < XFASTINT (limit)))
598 next = next_interval (next);
599
600 if (NULL_INTERVAL_P (next))
601 return limit;
602 if (! NILP (limit) && !(next->position < XFASTINT (limit)))
603 return limit;
604
605 return next->position - (XTYPE (object) == Lisp_String);
606 }
607
608 /* Return 1 if there's a change in some property between BEG and END. */
609
610 int
611 property_change_between_p (beg, end)
612 int beg, end;
613 {
614 register INTERVAL i, next;
615 Lisp_Object object, pos;
616
617 XSET (object, Lisp_Buffer, current_buffer);
618 XFASTINT (pos) = beg;
619
620 i = validate_interval_range (object, &pos, &pos, soft);
621 if (NULL_INTERVAL_P (i))
622 return 0;
623
624 next = next_interval (i);
625 while (! NULL_INTERVAL_P (next) && intervals_equal (i, next))
626 {
627 next = next_interval (next);
628 if (NULL_INTERVAL_P (next))
629 return 0;
630 if (next->position >= end)
631 return 0;
632 }
633
634 if (NULL_INTERVAL_P (next))
635 return 0;
636
637 return 1;
638 }
639
640 DEFUN ("next-single-property-change", Fnext_single_property_change,
641 Snext_single_property_change, 2, 4, 0,
642 "Return the position of next property change for a specific property.\n\
643 Scans characters forward from POS till it finds\n\
644 a change in the PROP property, then returns the position of the change.\n\
645 The optional third argument OBJECT is the string or buffer to scan.\n\
646 The property values are compared with `eq'.\n\
647 Return nil if the property is constant all the way to the end of OBJECT.\n\
648 If the value is non-nil, it is a position greater than POS, never equal.\n\n\
649 If the optional fourth argument LIMIT is non-nil, don't search\n\
650 past position LIMIT; return LIMIT if nothing is found before LIMIT.")
651 (pos, prop, object, limit)
652 Lisp_Object pos, prop, object, limit;
653 {
654 register INTERVAL i, next;
655 register Lisp_Object here_val;
656
657 if (NILP (object))
658 XSET (object, Lisp_Buffer, current_buffer);
659
660 if (!NILP (limit))
661 CHECK_NUMBER_COERCE_MARKER (limit, 0);
662
663 i = validate_interval_range (object, &pos, &pos, soft);
664 if (NULL_INTERVAL_P (i))
665 return limit;
666
667 here_val = textget (i->plist, prop);
668 next = next_interval (i);
669 while (! NULL_INTERVAL_P (next)
670 && EQ (here_val, textget (next->plist, prop))
671 && (NILP (limit) || next->position < XFASTINT (limit)))
672 next = next_interval (next);
673
674 if (NULL_INTERVAL_P (next))
675 return limit;
676 if (! NILP (limit) && !(next->position < XFASTINT (limit)))
677 return limit;
678
679 return next->position - (XTYPE (object) == Lisp_String);
680 }
681
682 DEFUN ("previous-property-change", Fprevious_property_change,
683 Sprevious_property_change, 1, 3, 0,
684 "Return the position of previous property change.\n\
685 Scans characters backwards from POS in OBJECT till it finds\n\
686 a change in some text property, then returns the position of the change.\n\
687 The optional second argument OBJECT is the string or buffer to scan.\n\
688 Return nil if the property is constant all the way to the start of OBJECT.\n\
689 If the value is non-nil, it is a position less than POS, never equal.\n\n\
690 If the optional third argument LIMIT is non-nil, don't search\n\
691 back past position LIMIT; return LIMIT if nothing is found until LIMIT.")
692 (pos, object, limit)
693 Lisp_Object pos, object, limit;
694 {
695 register INTERVAL i, previous;
696
697 if (NILP (object))
698 XSET (object, Lisp_Buffer, current_buffer);
699
700 if (!NILP (limit))
701 CHECK_NUMBER_COERCE_MARKER (limit, 0);
702
703 i = validate_interval_range (object, &pos, &pos, soft);
704 if (NULL_INTERVAL_P (i))
705 return limit;
706
707 /* Start with the interval containing the char before point. */
708 if (i->position == XFASTINT (pos))
709 i = previous_interval (i);
710
711 previous = previous_interval (i);
712 while (! NULL_INTERVAL_P (previous) && intervals_equal (previous, i)
713 && (NILP (limit)
714 || previous->position + LENGTH (previous) > XFASTINT (limit)))
715 previous = previous_interval (previous);
716 if (NULL_INTERVAL_P (previous))
717 return limit;
718 if (!NILP (limit)
719 && !(previous->position + LENGTH (previous) > XFASTINT (limit)))
720 return limit;
721
722 return (previous->position + LENGTH (previous)
723 - (XTYPE (object) == Lisp_String));
724 }
725
726 DEFUN ("previous-single-property-change", Fprevious_single_property_change,
727 Sprevious_single_property_change, 2, 4, 0,
728 "Return the position of previous property change for a specific property.\n\
729 Scans characters backward from POS till it finds\n\
730 a change in the PROP property, then returns the position of the change.\n\
731 The optional third argument OBJECT is the string or buffer to scan.\n\
732 The property values are compared with `eq'.\n\
733 Return nil if the property is constant all the way to the start of OBJECT.\n\
734 If the value is non-nil, it is a position less than POS, never equal.\n\n\
735 If the optional fourth argument LIMIT is non-nil, don't search\n\
736 back past position LIMIT; return LIMIT if nothing is found until LIMIT.")
737 (pos, prop, object, limit)
738 Lisp_Object pos, prop, object, limit;
739 {
740 register INTERVAL i, previous;
741 register Lisp_Object here_val;
742
743 if (NILP (object))
744 XSET (object, Lisp_Buffer, current_buffer);
745
746 if (!NILP (limit))
747 CHECK_NUMBER_COERCE_MARKER (limit, 0);
748
749 i = validate_interval_range (object, &pos, &pos, soft);
750
751 /* Start with the interval containing the char before point. */
752 if (! NULL_INTERVAL_P (i) && i->position == XFASTINT (pos))
753 i = previous_interval (i);
754
755 if (NULL_INTERVAL_P (i))
756 return limit;
757
758 here_val = textget (i->plist, prop);
759 previous = previous_interval (i);
760 while (! NULL_INTERVAL_P (previous)
761 && EQ (here_val, textget (previous->plist, prop))
762 && (NILP (limit)
763 || previous->position + LENGTH (previous) > XFASTINT (limit)))
764 previous = previous_interval (previous);
765 if (NULL_INTERVAL_P (previous))
766 return limit;
767 if (!NILP (limit)
768 && !(previous->position + LENGTH (previous) > XFASTINT (limit)))
769 return limit;
770
771 return (previous->position + LENGTH (previous)
772 - (XTYPE (object) == Lisp_String));
773 }
774
775 DEFUN ("add-text-properties", Fadd_text_properties,
776 Sadd_text_properties, 3, 4, 0,
777 "Add properties to the text from START to END.\n\
778 The third argument PROPS is a property list\n\
779 specifying the property values to add.\n\
780 The optional fourth argument, OBJECT,\n\
781 is the string or buffer containing the text.\n\
782 Return t if any property value actually changed, nil otherwise.")
783 (start, end, properties, object)
784 Lisp_Object start, end, properties, object;
785 {
786 register INTERVAL i, unchanged;
787 register int s, len, modified = 0;
788
789 properties = validate_plist (properties);
790 if (NILP (properties))
791 return Qnil;
792
793 if (NILP (object))
794 XSET (object, Lisp_Buffer, current_buffer);
795
796 i = validate_interval_range (object, &start, &end, hard);
797 if (NULL_INTERVAL_P (i))
798 return Qnil;
799
800 s = XINT (start);
801 len = XINT (end) - s;
802
803 /* If we're not starting on an interval boundary, we have to
804 split this interval. */
805 if (i->position != s)
806 {
807 /* If this interval already has the properties, we can
808 skip it. */
809 if (interval_has_all_properties (properties, i))
810 {
811 int got = (LENGTH (i) - (s - i->position));
812 if (got >= len)
813 return Qnil;
814 len -= got;
815 i = next_interval (i);
816 }
817 else
818 {
819 unchanged = i;
820 i = split_interval_right (unchanged, s - unchanged->position);
821 copy_properties (unchanged, i);
822 }
823 }
824
825 /* We are at the beginning of interval I, with LEN chars to scan. */
826 for (;;)
827 {
828 if (i == 0)
829 abort ();
830
831 if (LENGTH (i) >= len)
832 {
833 if (interval_has_all_properties (properties, i))
834 return modified ? Qt : Qnil;
835
836 if (LENGTH (i) == len)
837 {
838 add_properties (properties, i, object);
839 return Qt;
840 }
841
842 /* i doesn't have the properties, and goes past the change limit */
843 unchanged = i;
844 i = split_interval_left (unchanged, len);
845 copy_properties (unchanged, i);
846 add_properties (properties, i, object);
847 return Qt;
848 }
849
850 len -= LENGTH (i);
851 modified += add_properties (properties, i, object);
852 i = next_interval (i);
853 }
854 }
855
856 DEFUN ("put-text-property", Fput_text_property,
857 Sput_text_property, 4, 5, 0,
858 "Set one property of the text from START to END.\n\
859 The third and fourth arguments PROP and VALUE\n\
860 specify the property to add.\n\
861 The optional fifth argument, OBJECT,\n\
862 is the string or buffer containing the text.")
863 (start, end, prop, value, object)
864 Lisp_Object start, end, prop, value, object;
865 {
866 Fadd_text_properties (start, end,
867 Fcons (prop, Fcons (value, Qnil)),
868 object);
869 return Qnil;
870 }
871
872 DEFUN ("set-text-properties", Fset_text_properties,
873 Sset_text_properties, 3, 4, 0,
874 "Completely replace properties of text from START to END.\n\
875 The third argument PROPS is the new property list.\n\
876 The optional fourth argument, OBJECT,\n\
877 is the string or buffer containing the text.")
878 (start, end, props, object)
879 Lisp_Object start, end, props, object;
880 {
881 register INTERVAL i, unchanged;
882 register INTERVAL prev_changed = NULL_INTERVAL;
883 register int s, len;
884
885 props = validate_plist (props);
886
887 if (NILP (object))
888 XSET (object, Lisp_Buffer, current_buffer);
889
890 i = validate_interval_range (object, &start, &end, hard);
891 if (NULL_INTERVAL_P (i))
892 return Qnil;
893
894 s = XINT (start);
895 len = XINT (end) - s;
896
897 if (i->position != s)
898 {
899 unchanged = i;
900 i = split_interval_right (unchanged, s - unchanged->position);
901
902 if (LENGTH (i) > len)
903 {
904 copy_properties (unchanged, i);
905 i = split_interval_left (i, len);
906 set_properties (props, i, object);
907 return Qt;
908 }
909
910 set_properties (props, i, object);
911
912 if (LENGTH (i) == len)
913 return Qt;
914
915 prev_changed = i;
916 len -= LENGTH (i);
917 i = next_interval (i);
918 }
919
920 /* We are starting at the beginning of an interval, I */
921 while (len > 0)
922 {
923 if (i == 0)
924 abort ();
925
926 if (LENGTH (i) >= len)
927 {
928 if (LENGTH (i) > len)
929 i = split_interval_left (i, len);
930
931 if (NULL_INTERVAL_P (prev_changed))
932 set_properties (props, i, object);
933 else
934 merge_interval_left (i);
935 return Qt;
936 }
937
938 len -= LENGTH (i);
939 if (NULL_INTERVAL_P (prev_changed))
940 {
941 set_properties (props, i, object);
942 prev_changed = i;
943 }
944 else
945 prev_changed = i = merge_interval_left (i);
946
947 i = next_interval (i);
948 }
949
950 return Qt;
951 }
952
953 DEFUN ("remove-text-properties", Fremove_text_properties,
954 Sremove_text_properties, 3, 4, 0,
955 "Remove some properties from text from START to END.\n\
956 The third argument PROPS is a property list\n\
957 whose property names specify the properties to remove.\n\
958 \(The values stored in PROPS are ignored.)\n\
959 The optional fourth argument, OBJECT,\n\
960 is the string or buffer containing the text.\n\
961 Return t if any property was actually removed, nil otherwise.")
962 (start, end, props, object)
963 Lisp_Object start, end, props, object;
964 {
965 register INTERVAL i, unchanged;
966 register int s, len, modified = 0;
967
968 if (NILP (object))
969 XSET (object, Lisp_Buffer, current_buffer);
970
971 i = validate_interval_range (object, &start, &end, soft);
972 if (NULL_INTERVAL_P (i))
973 return Qnil;
974
975 s = XINT (start);
976 len = XINT (end) - s;
977
978 if (i->position != s)
979 {
980 /* No properties on this first interval -- return if
981 it covers the entire region. */
982 if (! interval_has_some_properties (props, i))
983 {
984 int got = (LENGTH (i) - (s - i->position));
985 if (got >= len)
986 return Qnil;
987 len -= got;
988 i = next_interval (i);
989 }
990 /* Split away the beginning of this interval; what we don't
991 want to modify. */
992 else
993 {
994 unchanged = i;
995 i = split_interval_right (unchanged, s - unchanged->position);
996 copy_properties (unchanged, i);
997 }
998 }
999
1000 /* We are at the beginning of an interval, with len to scan */
1001 for (;;)
1002 {
1003 if (i == 0)
1004 abort ();
1005
1006 if (LENGTH (i) >= len)
1007 {
1008 if (! interval_has_some_properties (props, i))
1009 return modified ? Qt : Qnil;
1010
1011 if (LENGTH (i) == len)
1012 {
1013 remove_properties (props, i, object);
1014 return Qt;
1015 }
1016
1017 /* i has the properties, and goes past the change limit */
1018 unchanged = i;
1019 i = split_interval_left (i, len);
1020 copy_properties (unchanged, i);
1021 remove_properties (props, i, object);
1022 return Qt;
1023 }
1024
1025 len -= LENGTH (i);
1026 modified += remove_properties (props, i, object);
1027 i = next_interval (i);
1028 }
1029 }
1030
1031 DEFUN ("text-property-any", Ftext_property_any,
1032 Stext_property_any, 4, 5, 0,
1033 "Check text from START to END to see if PROP is ever `eq' to VALUE.\n\
1034 If so, return the position of the first character whose PROP is `eq'\n\
1035 to VALUE. Otherwise return nil.\n\
1036 The optional fifth argument, OBJECT, is the string or buffer\n\
1037 containing the text.")
1038 (start, end, prop, value, object)
1039 Lisp_Object start, end, prop, value, object;
1040 {
1041 register INTERVAL i;
1042 register int e, pos;
1043
1044 if (NILP (object))
1045 XSET (object, Lisp_Buffer, current_buffer);
1046 i = validate_interval_range (object, &start, &end, soft);
1047 e = XINT (end);
1048
1049 while (! NULL_INTERVAL_P (i))
1050 {
1051 if (i->position >= e)
1052 break;
1053 if (EQ (textget (i->plist, prop), value))
1054 {
1055 pos = i->position;
1056 if (pos < XINT (start))
1057 pos = XINT (start);
1058 return make_number (pos - (XTYPE (object) == Lisp_String));
1059 }
1060 i = next_interval (i);
1061 }
1062 return Qnil;
1063 }
1064
1065 DEFUN ("text-property-not-all", Ftext_property_not_all,
1066 Stext_property_not_all, 4, 5, 0,
1067 "Check text from START to END to see if PROP is ever not `eq' to VALUE.\n\
1068 If so, return the position of the first character whose PROP is not\n\
1069 `eq' to VALUE. Otherwise, return nil.\n\
1070 The optional fifth argument, OBJECT, is the string or buffer\n\
1071 containing the text.")
1072 (start, end, prop, value, object)
1073 Lisp_Object start, end, prop, value, object;
1074 {
1075 register INTERVAL i;
1076 register int s, e;
1077
1078 if (NILP (object))
1079 XSET (object, Lisp_Buffer, current_buffer);
1080 i = validate_interval_range (object, &start, &end, soft);
1081 if (NULL_INTERVAL_P (i))
1082 return (NILP (value) || EQ (start, end)) ? Qnil : start;
1083 s = XINT (start);
1084 e = XINT (end);
1085
1086 while (! NULL_INTERVAL_P (i))
1087 {
1088 if (i->position >= e)
1089 break;
1090 if (! EQ (textget (i->plist, prop), value))
1091 {
1092 if (i->position > s)
1093 s = i->position;
1094 return make_number (s - (XTYPE (object) == Lisp_String));
1095 }
1096 i = next_interval (i);
1097 }
1098 return Qnil;
1099 }
1100
1101 #if 0 /* You can use set-text-properties for this. */
1102
1103 DEFUN ("erase-text-properties", Ferase_text_properties,
1104 Serase_text_properties, 2, 3, 0,
1105 "Remove all properties from the text from START to END.\n\
1106 The optional third argument, OBJECT,\n\
1107 is the string or buffer containing the text.")
1108 (start, end, object)
1109 Lisp_Object start, end, object;
1110 {
1111 register INTERVAL i;
1112 register INTERVAL prev_changed = NULL_INTERVAL;
1113 register int s, len, modified;
1114
1115 if (NILP (object))
1116 XSET (object, Lisp_Buffer, current_buffer);
1117
1118 i = validate_interval_range (object, &start, &end, soft);
1119 if (NULL_INTERVAL_P (i))
1120 return Qnil;
1121
1122 s = XINT (start);
1123 len = XINT (end) - s;
1124
1125 if (i->position != s)
1126 {
1127 register int got;
1128 register INTERVAL unchanged = i;
1129
1130 /* If there are properties here, then this text will be modified. */
1131 if (! NILP (i->plist))
1132 {
1133 i = split_interval_right (unchanged, s - unchanged->position);
1134 i->plist = Qnil;
1135 modified++;
1136
1137 if (LENGTH (i) > len)
1138 {
1139 i = split_interval_right (i, len);
1140 copy_properties (unchanged, i);
1141 return Qt;
1142 }
1143
1144 if (LENGTH (i) == len)
1145 return Qt;
1146
1147 got = LENGTH (i);
1148 }
1149 /* If the text of I is without any properties, and contains
1150 LEN or more characters, then we may return without changing
1151 anything.*/
1152 else if (LENGTH (i) - (s - i->position) <= len)
1153 return Qnil;
1154 /* The amount of text to change extends past I, so just note
1155 how much we've gotten. */
1156 else
1157 got = LENGTH (i) - (s - i->position);
1158
1159 len -= got;
1160 prev_changed = i;
1161 i = next_interval (i);
1162 }
1163
1164 /* We are starting at the beginning of an interval, I. */
1165 while (len > 0)
1166 {
1167 if (LENGTH (i) >= len)
1168 {
1169 /* If I has no properties, simply merge it if possible. */
1170 if (NILP (i->plist))
1171 {
1172 if (! NULL_INTERVAL_P (prev_changed))
1173 merge_interval_left (i);
1174
1175 return modified ? Qt : Qnil;
1176 }
1177
1178 if (LENGTH (i) > len)
1179 i = split_interval_left (i, len);
1180 if (! NULL_INTERVAL_P (prev_changed))
1181 merge_interval_left (i);
1182 else
1183 i->plist = Qnil;
1184
1185 return Qt;
1186 }
1187
1188 /* Here if we still need to erase past the end of I */
1189 len -= LENGTH (i);
1190 if (NULL_INTERVAL_P (prev_changed))
1191 {
1192 modified += erase_properties (i);
1193 prev_changed = i;
1194 }
1195 else
1196 {
1197 modified += ! NILP (i->plist);
1198 /* Merging I will give it the properties of PREV_CHANGED. */
1199 prev_changed = i = merge_interval_left (i);
1200 }
1201
1202 i = next_interval (i);
1203 }
1204
1205 return modified ? Qt : Qnil;
1206 }
1207 #endif /* 0 */
1208
1209 /* I don't think this is the right interface to export; how often do you
1210 want to do something like this, other than when you're copying objects
1211 around?
1212
1213 I think it would be better to have a pair of functions, one which
1214 returns the text properties of a region as a list of ranges and
1215 plists, and another which applies such a list to another object. */
1216
1217 /* DEFUN ("copy-text-properties", Fcopy_text_properties,
1218 Scopy_text_properties, 5, 6, 0,
1219 "Add properties from SRC-START to SRC-END of SRC at DEST-POS of DEST.\n\
1220 SRC and DEST may each refer to strings or buffers.\n\
1221 Optional sixth argument PROP causes only that property to be copied.\n\
1222 Properties are copied to DEST as if by `add-text-properties'.\n\
1223 Return t if any property value actually changed, nil otherwise.") */
1224
1225 Lisp_Object
1226 copy_text_properties (start, end, src, pos, dest, prop)
1227 Lisp_Object start, end, src, pos, dest, prop;
1228 {
1229 INTERVAL i;
1230 Lisp_Object res;
1231 Lisp_Object stuff;
1232 Lisp_Object plist;
1233 int s, e, e2, p, len, modified = 0;
1234
1235 i = validate_interval_range (src, &start, &end, soft);
1236 if (NULL_INTERVAL_P (i))
1237 return Qnil;
1238
1239 CHECK_NUMBER_COERCE_MARKER (pos, 0);
1240 {
1241 Lisp_Object dest_start, dest_end;
1242
1243 dest_start = pos;
1244 XFASTINT (dest_end) = XINT (dest_start) + (XINT (end) - XINT (start));
1245 /* Apply this to a copy of pos; it will try to increment its arguments,
1246 which we don't want. */
1247 validate_interval_range (dest, &dest_start, &dest_end, soft);
1248 }
1249
1250 s = XINT (start);
1251 e = XINT (end);
1252 p = XINT (pos);
1253
1254 stuff = Qnil;
1255
1256 while (s < e)
1257 {
1258 e2 = i->position + LENGTH (i);
1259 if (e2 > e)
1260 e2 = e;
1261 len = e2 - s;
1262
1263 plist = i->plist;
1264 if (! NILP (prop))
1265 while (! NILP (plist))
1266 {
1267 if (EQ (Fcar (plist), prop))
1268 {
1269 plist = Fcons (prop, Fcons (Fcar (Fcdr (plist)), Qnil));
1270 break;
1271 }
1272 plist = Fcdr (Fcdr (plist));
1273 }
1274 if (! NILP (plist))
1275 {
1276 /* Must defer modifications to the interval tree in case src
1277 and dest refer to the same string or buffer. */
1278 stuff = Fcons (Fcons (make_number (p),
1279 Fcons (make_number (p + len),
1280 Fcons (plist, Qnil))),
1281 stuff);
1282 }
1283
1284 i = next_interval (i);
1285 if (NULL_INTERVAL_P (i))
1286 break;
1287
1288 p += len;
1289 s = i->position;
1290 }
1291
1292 while (! NILP (stuff))
1293 {
1294 res = Fcar (stuff);
1295 res = Fadd_text_properties (Fcar (res), Fcar (Fcdr (res)),
1296 Fcar (Fcdr (Fcdr (res))), dest);
1297 if (! NILP (res))
1298 modified++;
1299 stuff = Fcdr (stuff);
1300 }
1301
1302 return modified ? Qt : Qnil;
1303 }
1304
1305 void
1306 syms_of_textprop ()
1307 {
1308 DEFVAR_INT ("interval-balance-threshold", &interval_balance_threshold,
1309 "Threshold for rebalancing interval trees, expressed as the\n\
1310 percentage by which the left interval tree should not differ from the right.");
1311 interval_balance_threshold = 8;
1312
1313 DEFVAR_LISP ("inhibit-point-motion-hooks", &Vinhibit_point_motion_hooks,
1314 "If non-nil, don't call the text property values of\n\
1315 `point-left' and `point-entered'.");
1316 Vinhibit_point_motion_hooks = Qnil;
1317
1318 /* Common attributes one might give text */
1319
1320 staticpro (&Qforeground);
1321 Qforeground = intern ("foreground");
1322 staticpro (&Qbackground);
1323 Qbackground = intern ("background");
1324 staticpro (&Qfont);
1325 Qfont = intern ("font");
1326 staticpro (&Qstipple);
1327 Qstipple = intern ("stipple");
1328 staticpro (&Qunderline);
1329 Qunderline = intern ("underline");
1330 staticpro (&Qread_only);
1331 Qread_only = intern ("read-only");
1332 staticpro (&Qinvisible);
1333 Qinvisible = intern ("invisible");
1334 staticpro (&Qintangible);
1335 Qintangible = intern ("intangible");
1336 staticpro (&Qcategory);
1337 Qcategory = intern ("category");
1338 staticpro (&Qlocal_map);
1339 Qlocal_map = intern ("local-map");
1340 staticpro (&Qfront_sticky);
1341 Qfront_sticky = intern ("front-sticky");
1342 staticpro (&Qrear_nonsticky);
1343 Qrear_nonsticky = intern ("rear-nonsticky");
1344
1345 /* Properties that text might use to specify certain actions */
1346
1347 staticpro (&Qmouse_left);
1348 Qmouse_left = intern ("mouse-left");
1349 staticpro (&Qmouse_entered);
1350 Qmouse_entered = intern ("mouse-entered");
1351 staticpro (&Qpoint_left);
1352 Qpoint_left = intern ("point-left");
1353 staticpro (&Qpoint_entered);
1354 Qpoint_entered = intern ("point-entered");
1355
1356 defsubr (&Stext_properties_at);
1357 defsubr (&Sget_text_property);
1358 defsubr (&Sget_char_property);
1359 defsubr (&Snext_property_change);
1360 defsubr (&Snext_single_property_change);
1361 defsubr (&Sprevious_property_change);
1362 defsubr (&Sprevious_single_property_change);
1363 defsubr (&Sadd_text_properties);
1364 defsubr (&Sput_text_property);
1365 defsubr (&Sset_text_properties);
1366 defsubr (&Sremove_text_properties);
1367 defsubr (&Stext_property_any);
1368 defsubr (&Stext_property_not_all);
1369 /* defsubr (&Serase_text_properties); */
1370 /* defsubr (&Scopy_text_properties); */
1371 }
1372
1373 #else
1374
1375 lose -- this shouldn't be compiled if USE_TEXT_PROPERTIES isn't defined
1376
1377 #endif /* USE_TEXT_PROPERTIES */