Mercurial > hg > xemacs-beta

comparison lisp/prim/overlay.el @ 163:0132846995bd r20-3b8

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r20-3b8
author cvs
date Mon, 13 Aug 2007 09:43:35 +0200
parents 56c54cf7c5b6
children 85ec50267440
comparison
equal deleted inserted replaced
162:4de2936b4e77 163:0132846995bd
1 ;;; overlay.el --- overlay support. 1 ;;; overlay.el --- overlay support.
2 2
3 ;;;; Copyright (C) 1997 Free Software Foundation, Inc. 3 ;;;; Copyright (C) 1997 Free Software Foundation, Inc.
4 4
5 ;; Maintainer: XEmacs 5 ;; Author: Joe Nuspl <nuspl@sequent.com>
6 ;; Maintainer: XEmacs Development Team (in <hniksic@srce.hr> incarnation)
6 ;; Keywords: internal 7 ;; Keywords: internal
7 8
8 ;; This file is part of XEmacs. 9 ;; This file is part of XEmacs.
9 10
10 ;; XEmacs is free software; you can redistribute it and/or modify it 11 ;; XEmacs is free software; you can redistribute it and/or modify it
21 ;; along with XEmacs; see the file COPYING. If not, write to the 22 ;; along with XEmacs; see the file COPYING. If not, write to the
22 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, 23 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
23 ;; Boston, MA 02111-1307, USA. 24 ;; Boston, MA 02111-1307, USA.
24 25
25 ;;; Synched up with: Not in FSF. 26 ;;; Synched up with: Not in FSF.
27
28 ;;; Commentary:
29
30 ;; Unlike the text-properties interface, these functions are in fact
31 ;; totally useless in XEmacs. They are a more or less straightforward
32 ;; interface to the much better extent API, provided exclusively for
33 ;; GNU Emacs compatibility. If you notice an incompatibility not
34 ;; mentioned below, be sure to mention it. Anyways, you should really
35 ;; not use this.
36
37 ;; Known incompatibilities with the FSF interface:
38
39 ;; 1. There is not an `overlay' type. Any extent with non-nil
40 ;; 'overlay property is considered an "overlay".
41 ;;
42 ;; 2. Some features of FSF overlays have not been implemented in
43 ;; extents (or are unneeded). Specifically, those are the
44 ;; following special properties: window, insert-in-front-hooks,
45 ;; insert-behind-hooks, and modification-hooks. Some of these will
46 ;; probably be implemented for extents in the future.
47 ;;
48 ;; 3. In FSF, beginning and end of an overlay are markers, which means
49 ;; that you can use `insert-before-markers' to change insertion
50 ;; property of overlay. It will not work in this emulation, and we
51 ;; have no plans of providing it.
52 ;;
53 ;; 4. The `overlays-in' and `overlays-at' functions in some cases
54 ;; don't work as they should. To be fixed RSN.
55 ;;
56 ;; 5. Finally, setting or modification of overlay properties specific
57 ;; to extents will have unusual results. While (overlay-put
58 ;; overlay 'start-open t) does nothing under FSF, it has a definite
59 ;; effect under XEmacs. This is solved by simply avoiding such
60 ;; names (see `set-extent-property' for a list).
61
62 ;; Some functions were broken; fixed-up by Hrvoje Niksic, June 1997.
63
64
65 ;;; Code:
26 66
27 (defun overlayp (object) 67 (defun overlayp (object)
28 "Return t if OBJECT is an overlay." 68 "Return t if OBJECT is an overlay."
29 (and (extentp object) 69 (and (extentp object)
30 (extent-property object 'overlay))) 70 (extent-property object 'overlay)))
35 BEG and END may be integers or markers. 75 BEG and END may be integers or markers.
36 The fourth arg FRONT-ADVANCE, if non-nil, makes the 76 The fourth arg FRONT-ADVANCE, if non-nil, makes the
37 front delimiter advance when text is inserted there. 77 front delimiter advance when text is inserted there.
38 The fifth arg REAR-ADVANCE, if non-nil, makes the 78 The fifth arg REAR-ADVANCE, if non-nil, makes the
39 rear delimiter advance when text is inserted there." 79 rear delimiter advance when text is inserted there."
40 (let (overlay temp) 80 (if (null buffer)
41 (if (null buffer) 81 (setq buffer (current-buffer))
42 (setq buffer (current-buffer)) 82 (check-argument-type 'bufferp buffer))
43 (check-argument-type 'bufferp buffer)) 83 (when (> beg end)
44 84 (setq beg (prog1 end (setq end beg))))
45 (if (> beg end) 85
46 (setq temp beg 86 (let ((overlay (make-extent beg end buffer)))
47 beg end
48 end temp))
49
50 (setq overlay (make-extent beg end buffer))
51 (set-extent-property overlay 'overlay t) 87 (set-extent-property overlay 'overlay t)
52
53 (if front-advance 88 (if front-advance
54 (set-extent-property overlay 'start-open t) 89 (set-extent-property overlay 'start-open t)
55 (set-extent-property overlay 'start-closed t)) 90 (set-extent-property overlay 'start-closed t))
56
57 (if rear-advance 91 (if rear-advance
58 (set-extent-property overlay 'end-closed t) 92 (set-extent-property overlay 'end-closed t)
59 (set-extent-property overlay 'end-open t)) 93 (set-extent-property overlay 'end-open t))
60 94
61 overlay)) 95 overlay))
63 (defun move-overlay (overlay beg end &optional buffer) 97 (defun move-overlay (overlay beg end &optional buffer)
64 "Set the endpoints of OVERLAY to BEG and END in BUFFER. 98 "Set the endpoints of OVERLAY to BEG and END in BUFFER.
65 If BUFFER is omitted, leave OVERLAY in the same buffer it inhabits now. 99 If BUFFER is omitted, leave OVERLAY in the same buffer it inhabits now.
66 If BUFFER is omitted, and OVERLAY is in no buffer, put it in the current 100 If BUFFER is omitted, and OVERLAY is in no buffer, put it in the current
67 buffer." 101 buffer."
68 (let (temp) 102 (check-argument-type 'overlayp overlay)
69 (check-argument-type 'overlayp overlay) 103 (if (null buffer)
70 (if (null buffer) 104 (setq buffer (extent-object overlay)))
71 (setq buffer (extent-object overlay))) 105 (if (null buffer)
72 106 (setq buffer (current-buffer)))
73 (if (null buffer) 107 (check-argument-type 'bufferp buffer)
74 (setq buffer (current-buffer))) 108 (and (= beg end)
75 109 (extent-property overlay 'evaporate)
76 (check-argument-type 'bufferp buffer) 110 (delete-overlay overlay))
77 111 (when (> beg end)
78 (if (and (= beg end) 112 (setq beg (prog1 end (setq end beg))))
79 (not (null (extent-property overlay 'evaporate)))) 113 (set-extent-endpoints overlay beg end buffer)
80 (delete-overlay overlay) 114 overlay)
81
82 (if (> beg end)
83 (setq temp beg
84 beg end
85 end temp))
86
87 (set-extent-endpoints overlay beg end buffer)
88 overlay)))
89 115
90 (defun delete-overlay (overlay) 116 (defun delete-overlay (overlay)
91 "Delete the overlay OVERLAY from its buffer." 117 "Delete the overlay OVERLAY from its buffer."
92 (check-argument-type 'overlayp overlay) 118 (check-argument-type 'overlayp overlay)
93 (detach-extent overlay) 119 (detach-extent overlay)
123 "Return a list of the overlays that overlap the region BEG ... END. 149 "Return a list of the overlays that overlap the region BEG ... END.
124 Overlap means that at least one character is contained within the overlay 150 Overlap means that at least one character is contained within the overlay
125 and also contained within the specified region. 151 and also contained within the specified region.
126 Empty overlays are included in the result if they are located at BEG 152 Empty overlays are included in the result if they are located at BEG
127 or between BEG and END." 153 or between BEG and END."
128 (let (lst) 154 (mapcar-extents #'identity nil nil beg end nil 'overlay))
129 (mapcar (function
130 (lambda (overlay)
131 (and (extent-property overlay 'overlay)
132 (setq lst (append lst (list overlay))))))
133 (extent-list nil beg end))
134 lst))
135 155
136 (defun next-overlay-change (pos) 156 (defun next-overlay-change (pos)
137 "Return the next position after POS where an overlay starts or ends. 157 "Return the next position after POS where an overlay starts or ends.
138 If there are no more overlay boundaries after POS, return (point-max)." 158 If there are no more overlay boundaries after POS, return (point-max)."
139 (let ((next (point-max)) 159 (let ((next (point-max))
140 end) 160 tmp)
141 (mapcar (function 161 (map-extents
142 (lambda (overlay) 162 (lambda (overlay ignore)
143 (if (< (setq end (extent-end-position overlay)) next) 163 (when (or (and (< (setq tmp (extent-start-position overlay)) next)
144 (setq next end)))) 164 (> tmp pos))
145 (overlays-in pos end)) 165 (and (< (setq tmp (extent-end-position overlay)) next)
166 (> tmp pos)))
167 (setq next tmp))
168 nil)
169 nil pos nil nil nil 'overlay)
146 next)) 170 next))
147 171
148 (defun previous-overlay-change (pos) 172 (defun previous-overlay-change (pos)
149 "Return the previous position before POS where an overlay starts or ends. 173 "Return the previous position before POS where an overlay starts or ends.
150 If there are no more overlay boundaries before POS, return (point-min)." 174 If there are no more overlay boundaries before POS, return (point-min)."
151 (let ((prev (point-min)) 175 (let ((prev (point-min))
152 beg) 176 tmp)
153 (mapcar (function 177 (map-extents
154 (lambda (overlay) 178 (lambda (overlay ignore)
155 (if (and (> (setq beg (extent-start-position overlay)) prev) 179 (when (or (and (> (setq tmp (extent-end-position overlay)) prev)
156 (< beg pos)) 180 (< tmp pos))
157 (setq prev beg)))) 181 (and (> (setq tmp (extent-start-position overlay)) prev)
158 (overlays-in prev pos)) 182 (< tmp pos)))
183 (setq prev tmp))
184 nil)
185 nil nil pos nil nil 'overlay)
159 prev)) 186 prev))
160 187
161 (defun overlay-lists () 188 (defun overlay-lists ()
162 "Return a pair of lists giving all the overlays of the current buffer. 189 "Return a pair of lists giving all the overlays of the current buffer.
163 The car has all the overlays before the overlay center; 190 The car has all the overlays before the overlay center;
164 the cdr has all the overlays after the overlay center. 191 the cdr has all the overlays after the overlay center.
165 Recentering overlays moves overlays between these lists. 192 Recentering overlays moves overlays between these lists.
166 The lists you get are copies, so that changing them has no effect. 193 The lists you get are copies, so that changing them has no effect.
167 However, the overlays you get are the real objects that the buffer uses." 194 However, the overlays you get are the real objects that the buffer uses."
168 (if (not (boundp 'xemacs-internal-overlay-center-pos)) 195 (or (boundp 'xemacs-internal-overlay-center-pos)
169 (overlay-recenter (/ (- (point-max) (point-min)) 2))) 196 (overlay-recenter (1+ (/ (- (point-max) (point-min)) 2))))
170 (let ((pos xemacs-internal-overlay-center-pos) 197 (let ((pos xemacs-internal-overlay-center-pos)
171 before after) 198 before after)
172 (mapcar 199 (map-extents (lambda (overlay ignore)
173 (function 200 (if (> pos (extent-end-position overlay))
174 (lambda (overlay) 201 (push overlay before)
175 (if (extent-property overlay 'overlay) 202 (push overlay after))
176 (if (> pos (extent-end-position overlay)) 203 nil)
177 (setq before (append before (list overlay))) 204 nil nil nil nil nil 'overlay)
178 (setq after (append after (list overlay))))))) 205 (cons (nreverse before) (nreverse after))))
179 (extent-list))
180 (cons before after)))
181 206
182 (defun overlay-recenter (pos) 207 (defun overlay-recenter (pos)
183 "Recenter the overlays of the current buffer around position POS." 208 "Recenter the overlays of the current buffer around position POS."
184 (set (make-local-variable 'xemacs-internal-overlay-center-pos) pos)) 209 (set (make-local-variable 'xemacs-internal-overlay-center-pos) pos))
185 210
186 (defun overlay-get (overlay prop) 211 (defun overlay-get (overlay prop)
187 "Get the property of overlay OVERLAY with property name PROP." 212 "Get the property of overlay OVERLAY with property name PROP."
188 (check-argument-type 'overlayp overlay) 213 (check-argument-type 'overlayp overlay)
189 (extent-property overlay prop)) 214 (let ((value (extent-property overlay prop))
215 category)
216 (if (and (null value)
217 (setq category (extent-property overlay 'category)))
218 (get category prop)
219 value)))
190 220
191 (defun overlay-put (overlay prop value) 221 (defun overlay-put (overlay prop value)
192 "Set one property of overlay OVERLAY: give property PROP value VALUE." 222 "Set one property of overlay OVERLAY: give property PROP value VALUE."
193 (check-argument-type 'overlayp overlay) 223 (check-argument-type 'overlayp overlay)
194 (cond ((eq prop 'evaporate) 224 (cond ((eq prop 'evaporate)
197 (set-extent-property overlay 'begin-glyph 227 (set-extent-property overlay 'begin-glyph
198 (make-glyph (vector 'string :data value)))) 228 (make-glyph (vector 'string :data value))))
199 ((eq prop 'after-string) 229 ((eq prop 'after-string)
200 (set-extent-property overlay 'end-glyph 230 (set-extent-property overlay 'end-glyph
201 (make-glyph (vector 'string :data value)))) 231 (make-glyph (vector 'string :data value))))
232 ((eq prop 'local-map)
233 (set-extent-property overlay 'keymap value))
202 ((memq prop '(window insert-in-front-hooks insert-behind-hooks 234 ((memq prop '(window insert-in-front-hooks insert-behind-hooks
203 modification-hooks)) 235 modification-hooks))
204 (error "cannot support overlay '%s property under XEmacs" 236 (error "cannot support overlay '%s property under XEmacs"
205 prop))) 237 prop)))
206 (set-extent-property overlay prop value)) 238 (set-extent-property overlay prop value))