Mercurial > hg > xemacs-beta

comparison lisp/overlay.el @ 219:262b8bb4a523 r20-4b8

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r20-4b8
author cvs
date Mon, 13 Aug 2007 10:09:35 +0200
parents
children
comparison
equal deleted inserted replaced
218:c9f226976f56 219:262b8bb4a523
1 ;;; overlay.el --- overlay support.
2
3 ;; Copyright (C) 1997 Free Software Foundation, Inc.
4
5 ;; Author: Joe Nuspl <nuspl@sequent.com>
6 ;; Maintainer: XEmacs Development Team (in <hniksic@srce.hr> incarnation)
7 ;; Keywords: internal
8
9 ;; This file is part of XEmacs.
10
11 ;; XEmacs is free software; you can redistribute it and/or modify it
12 ;; under the terms of the GNU General Public License as published by
13 ;; the Free Software Foundation; either version 2, or (at your option)
14 ;; any later version.
15
16 ;; XEmacs is distributed in the hope that it will be useful, but
17 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
19 ;; General Public License for more details.
20
21 ;; You should have received a copy of the GNU General Public License
22 ;; along with XEmacs; see the file COPYING. If not, write to the
23 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
24 ;; Boston, MA 02111-1307, USA.
25
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:
66
67 (defun overlayp (object)
68 "Return t if OBJECT is an overlay."
69 (and (extentp object)
70 (extent-property object 'overlay)))
71
72 (defun make-overlay (beg end &optional buffer front-advance rear-advance)
73 "Create a new overlay with range BEG to END in BUFFER.
74 If omitted, BUFFER defaults to the current buffer.
75 BEG and END may be integers or markers.
76 The fourth arg FRONT-ADVANCE, if non-nil, makes the
77 front delimiter advance when text is inserted there.
78 The fifth arg REAR-ADVANCE, if non-nil, makes the
79 rear delimiter advance when text is inserted there."
80 (if (null buffer)
81 (setq buffer (current-buffer))
82 (check-argument-type 'bufferp buffer))
83 (when (> beg end)
84 (setq beg (prog1 end (setq end beg))))
85
86 (let ((overlay (make-extent beg end buffer)))
87 (set-extent-property overlay 'overlay t)
88 (if front-advance
89 (set-extent-property overlay 'start-open t)
90 (set-extent-property overlay 'start-closed t))
91 (if rear-advance
92 (set-extent-property overlay 'end-closed t)
93 (set-extent-property overlay 'end-open t))
94
95 overlay))
96
97 (defun move-overlay (overlay beg end &optional buffer)
98 "Set the endpoints of OVERLAY to BEG and END in BUFFER.
99 If BUFFER is omitted, leave OVERLAY in the same buffer it inhabits now.
100 If BUFFER is omitted, and OVERLAY is in no buffer, put it in the current
101 buffer."
102 (check-argument-type 'overlayp overlay)
103 (if (null buffer)
104 (setq buffer (extent-object overlay)))
105 (if (null buffer)
106 (setq buffer (current-buffer)))
107 (check-argument-type 'bufferp buffer)
108 (and (= beg end)
109 (extent-property overlay 'evaporate)
110 (delete-overlay overlay))
111 (when (> beg end)
112 (setq beg (prog1 end (setq end beg))))
113 (set-extent-endpoints overlay beg end buffer)
114 overlay)
115
116 (defun delete-overlay (overlay)
117 "Delete the overlay OVERLAY from its buffer."
118 (check-argument-type 'overlayp overlay)
119 (detach-extent overlay)
120 nil)
121
122 (defun overlay-start (overlay)
123 "Return the position at which OVERLAY starts."
124 (check-argument-type 'overlayp overlay)
125 (extent-start-position overlay))
126
127 (defun overlay-end (overlay)
128 "Return the position at which OVERLAY ends."
129 (check-argument-type 'overlayp overlay)
130 (extent-end-position overlay))
131
132 (defun overlay-buffer (overlay)
133 "Return the buffer OVERLAY belongs to."
134 (check-argument-type 'overlayp overlay)
135 (extent-object overlay))
136
137 (defun overlay-properties (overlay)
138 "Return a list of the properties on OVERLAY.
139 This is a copy of OVERLAY's plist; modifying its conses has no effect on
140 OVERLAY."
141 (check-argument-type 'overlayp overlay)
142 (extent-properties overlay))
143
144 (defun overlays-at (pos)
145 "Return a list of the overlays that contain position POS."
146 (overlays-in pos pos))
147
148 (defun overlays-in (beg end)
149 "Return a list of the overlays that overlap the region BEG ... END.
150 Overlap means that at least one character is contained within the overlay
151 and also contained within the specified region.
152 Empty overlays are included in the result if they are located at BEG
153 or between BEG and END."
154 (mapcar-extents #'identity nil nil beg end
155 'all-extents-closed-open 'overlay))
156
157 (defun next-overlay-change (pos)
158 "Return the next position after POS where an overlay starts or ends.
159 If there are no more overlay boundaries after POS, return (point-max)."
160 (let ((next (point-max))
161 tmp)
162 (map-extents
163 (lambda (overlay ignore)
164 (when (or (and (< (setq tmp (extent-start-position overlay)) next)
165 (> tmp pos))
166 (and (< (setq tmp (extent-end-position overlay)) next)
167 (> tmp pos)))
168 (setq next tmp))
169 nil)
170 nil pos nil nil 'all-extents-closed-open 'overlay)
171 next))
172
173 (defun previous-overlay-change (pos)
174 "Return the previous position before POS where an overlay starts or ends.
175 If there are no more overlay boundaries before POS, return (point-min)."
176 (let ((prev (point-min))
177 tmp)
178 (map-extents
179 (lambda (overlay ignore)
180 (when (or (and (> (setq tmp (extent-end-position overlay)) prev)
181 (< tmp pos))
182 (and (> (setq tmp (extent-start-position overlay)) prev)
183 (< tmp pos)))
184 (setq prev tmp))
185 nil)
186 nil nil pos nil 'all-extents-closed-open 'overlay)
187 prev))
188
189 (defun overlay-lists ()
190 "Return a pair of lists giving all the overlays of the current buffer.
191 The car has all the overlays before the overlay center;
192 the cdr has all the overlays after the overlay center.
193 Recentering overlays moves overlays between these lists.
194 The lists you get are copies, so that changing them has no effect.
195 However, the overlays you get are the real objects that the buffer uses."
196 (or (boundp 'xemacs-internal-overlay-center-pos)
197 (overlay-recenter (1+ (/ (- (point-max) (point-min)) 2))))
198 (let ((pos xemacs-internal-overlay-center-pos)
199 before after)
200 (map-extents (lambda (overlay ignore)
201 (if (> pos (extent-end-position overlay))
202 (push overlay before)
203 (push overlay after))
204 nil)
205 nil nil nil nil 'all-extents-closed-open 'overlay)
206 (cons (nreverse before) (nreverse after))))
207
208 (defun overlay-recenter (pos)
209 "Recenter the overlays of the current buffer around position POS."
210 (set (make-local-variable 'xemacs-internal-overlay-center-pos) pos))
211
212 (defun overlay-get (overlay prop)
213 "Get the property of overlay OVERLAY with property name PROP."
214 (check-argument-type 'overlayp overlay)
215 (let ((value (extent-property overlay prop))
216 category)
217 (if (and (null value)
218 (setq category (extent-property overlay 'category)))
219 (get category prop)
220 value)))
221
222 (defun overlay-put (overlay prop value)
223 "Set one property of overlay OVERLAY: give property PROP value VALUE."
224 (check-argument-type 'overlayp overlay)
225 (cond ((eq prop 'evaporate)
226 (set-extent-property overlay 'detachable value))
227 ((eq prop 'before-string)
228 (set-extent-property overlay 'begin-glyph
229 (make-glyph (vector 'string :data value))))
230 ((eq prop 'after-string)
231 (set-extent-property overlay 'end-glyph
232 (make-glyph (vector 'string :data value))))
233 ((eq prop 'local-map)
234 (set-extent-property overlay 'keymap value))
235 ((memq prop '(window insert-in-front-hooks insert-behind-hooks
236 modification-hooks))
237 (error "cannot support overlay '%s property under XEmacs"
238 prop)))
239 (set-extent-property overlay prop value))
240
241 (provide 'overlay)
242
243 ;;; overlay.el ends here