Mercurial > hg > xemacs-beta

comparison lisp/hyperbole/kotl/kprop-xe.el @ 0:376386a54a3c r19-14

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r19-14
author cvs
date Mon, 13 Aug 2007 08:45:50 +0200
parents
children 4103f0995bd7
comparison
equal deleted inserted replaced
-1:000000000000 0:376386a54a3c
1 ;;!emacs
2 ;;
3 ;; FILE: kprop-xe.el
4 ;; SUMMARY: Koutline text property handling under XEmacs.
5 ;; USAGE: XEmacs Lisp Library
6 ;; KEYWORDS: outlines, wp
7 ;;
8 ;; AUTHOR: Bob Weiner
9 ;;
10 ;; ORIG-DATE: 7/27/93
11 ;; LAST-MOD: 30-Oct-95 at 21:21:20 by Bob Weiner
12 ;;
13 ;; This file is part of Hyperbole.
14 ;; Available for use and distribution under the same terms as GNU Emacs.
15 ;;
16 ;; Copyright (C) 1993, 1994, 1995 Free Software Foundation, Inc.
17 ;; Developed with support from Motorola Inc.
18 ;;
19 ;; DESCRIPTION:
20 ;; DESCRIP-END.
21
22 ;;; ************************************************************************
23 ;;; Other required Elisp libraries
24 ;;; ************************************************************************
25
26 (require 'hversion)
27
28 ;;; ************************************************************************
29 ;;; Public functions
30 ;;; ************************************************************************
31
32 (defun kproperty:get (pos prop &optional object)
33 "Return the value of position POS's property PROP, in OBJECT.
34 OBJECT is optional and defaults to the current buffer.
35 If POSITION is at the end of OBJECT, the value is nil."
36 (extent-property (extent-at pos object) prop))
37
38 (if (and hyperb:xemacs-p (or (>= emacs-minor-version 12)
39 (> emacs-major-version 19)))
40 (defun kproperty:map (function property &optional value)
41 "Apply FUNCTION to each PROPERTY `eq' to VALUE in the current buffer.
42 FUNCTION is called with point preceding PROPERTY and receives PROPERTY as an
43 argument."
44 (let ((result))
45 (save-excursion
46 (map-extents
47 (function (lambda (extent unused)
48 (goto-char (or (extent-start-position extent) (point)))
49 (setq result (cons (funcall function extent) result))
50 nil))
51 nil nil nil nil nil property value))
52 (nreverse result)))
53 (defun kproperty:map (function property &optional value)
54 "Apply FUNCTION to each PROPERTY `eq' to VALUE in the current buffer.
55 FUNCTION is called with point preceding PROPERTY and receives PROPERTY as an
56 argument."
57 (let ((result))
58 (save-excursion
59 (map-extents
60 (function (lambda (extent unused)
61 (if (eq (extent-property extent property) value)
62 (progn (goto-char (or (extent-start-position extent)
63 (point)))
64 (setq result (cons (funcall function extent)
65 result))))
66 nil))))
67 (nreverse result))))
68
69 ;; (next-single-property-change (pos prop &optional object))
70 ;; Return the position of next property change for a specific property.
71 ;; Scans characters forward from POS till it finds
72 ;; a change in the PROP property, then returns the position of the change.
73 ;; The optional third argument OBJECT is the string or buffer to scan.
74 ;; Return nil if the property is constant all the way to the end of OBJECT.
75 ;; If the value is non-nil, it is a position greater than POS, never equal.
76 (fset 'kproperty:next-single-change 'next-single-property-change)
77
78 ;; (previous-single-property-change (pos prop &optional object))
79 ;; Return the position of previous property change for a specific property.
80 ;; Scans characters backward from POS till it finds
81 ;; a change in the PROP property, then returns the position of the change.
82 ;; The optional third argument OBJECT is the string or buffer to scan.
83 ;; Return nil if the property is constant all the way to the start of OBJECT.
84 ;; If the value is non-nil, it is a position less than POS, never equal.
85 (fset 'kproperty:previous-single-change 'previous-single-property-change)
86
87 (fset 'kproperty:properties 'extent-properties-at)
88
89 (defun kproperty:put (start end property-list &optional object)
90 "From START to END, add PROPERTY-LIST properties to the text.
91 The optional fourth argument, OBJECT, is the string or buffer containing the
92 text. Text inserted before or after this region does not inherit the added
93 properties."
94 ;; Don't use text properties internally because they don't work as desired
95 ;; when copied to a string and then reinserted.
96 (let ((extent (make-extent start end object)))
97 (if (null extent)
98 (error "(kproperty:put): No extent at %d-%d to add properties %s"
99 start end property-list))
100 (if (/= (mod (length property-list) 2) 0)
101 (error "(kproperty:put): Property-list has odd number of elements, %s"
102 property-list))
103 (set-extent-property extent 'text-prop t)
104 (set-extent-property extent 'duplicable t)
105 (set-extent-property extent 'start-open t)
106 (set-extent-property extent 'end-open t)
107 (while property-list
108 (set-extent-property
109 extent (car property-list) (car (cdr property-list)))
110 (setq property-list (nthcdr 2 property-list)))
111 extent))
112
113 (defun kproperty:remove (start end property-list &optional object)
114 "From START to END, remove the text properties in PROPERTY-LIST.
115 The optional fourth argument, OBJECT, is the string or buffer containing the
116 text. PROPERTY-LIST should be a plist; if the value of a property is
117 non-nil, then only a property with a matching value will be removed.
118 Returns t if any property was changed, nil otherwise."
119 ;; Don't use text property functions internally because they only look for
120 ;; closed extents, which kproperty does not use.
121 (let ((changed) property value)
122 (while property-list
123 (setq property (car property-list)
124 value (car (cdr property-list))
125 property-list (nthcdr 2 property-list))
126 (map-extents
127 (function (lambda (extent maparg)
128 (if (extent-live-p extent)
129 (progn (setq changed t)
130 (delete-extent extent)))
131 nil))
132 object start end nil nil property value))
133 changed))
134
135 (defun kproperty:replace-separator (pos label-separator old-sep-len)
136 "Replace at POS the cell label separator with LABEL-SEPARATOR.
137 OLD-SEP-LEN is the length of the separator being replaced."
138 (let (extent)
139 (while (setq pos (kproperty:next-single-change (point) 'kcell))
140 (goto-char pos)
141 (setq extent (extent-at pos))
142 ;; Replace label-separator while maintaining cell properties.
143 (insert label-separator)
144 (set-extent-endpoints extent pos (+ pos 2))
145 (delete-region (point) (+ (point) old-sep-len)))))
146
147 (defun kproperty:set (property value)
148 "Set PROPERTY of character at point to VALUE."
149 (kproperty:put (point) (min (+ 2 (point)) (point-max))
150 (list property value)))