Mercurial > hg > xemacs-beta

comparison lisp/prim/overlay.el @ 22:8fc7fe29b841 r19-15b94

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r19-15b94
author cvs
date Mon, 13 Aug 2007 08:50:29 +0200
parents
children 56c54cf7c5b6
comparison
equal deleted inserted replaced
21:b88636d63495 22:8fc7fe29b841
1 ;;; overlay.el --- overlay support.
2
3 ;;;; Copyright (C) 1997 Free Software Foundation, Inc.
4
5 ;; Maintainer: XEmacs
6 ;; Keywords: internal
7
8 ;; This file is part of XEmacs.
9
10 ;; XEmacs is free software; you can redistribute it and/or modify it
11 ;; under the terms of the GNU General Public License as published by
12 ;; the Free Software Foundation; either version 2, or (at your option)
13 ;; any later version.
14
15 ;; XEmacs is distributed in the hope that it will be useful, but
16 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
18 ;; General Public License for more details.
19
20 ;; You should have received a copy of the GNU General Public License
21 ;; along with XEmacs; see the file COPYING. If not, write to the
22 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
23 ;; Boston, MA 02111-1307, USA.
24
25 ;;; Synched up with: Not in FSF.
26
27 (defun overlayp (object)
28 "Return t if OBJECT is an overlay."
29 (and (extentp object)
30 (extent-property object 'overlay)))
31
32 (defun make-overlay (beg end &optional buffer front-advance rear-advance)
33 "Create a new overlay with range BEG to END in BUFFER.
34 If omitted, BUFFER defaults to the current buffer.
35 BEG and END may be integers or markers.
36 The fourth arg FRONT-ADVANCE, if non-nil, makes the
37 front delimiter advance when text is inserted there.
38 The fifth arg REAR-ADVANCE, if non-nil, makes the
39 rear delimiter advance when text is inserted there."
40 (let (overlay temp)
41 (if (null buffer)
42 (setq buffer (current-buffer))
43 (check-argument-type 'bufferp buffer))
44
45 (if (> beg end)
46 (setq temp beg
47 beg end
48 end temp))
49
50 (setq overlay (make-extent beg end buffer))
51 (set-extent-property overlay 'overlay t)
52
53 (if front-advance
54 (set-extent-property overlay 'start-open t)
55 (set-extent-property overlay 'start-closed t))
56
57 (if rear-advance
58 (set-extent-property overlay 'end-closed t)
59 (set-extent-property overlay 'end-open t))
60
61 overlay))
62
63 (defun move-overlay (overlay beg end &optional buffer)
64 "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.
66 If BUFFER is omitted, and OVERLAY is in no buffer, put it in the current
67 buffer."
68 (let (temp)
69 (check-argument-type 'overlayp overlay)
70 (if (null buffer)
71 (setq buffer (extent-object overlay)))
72
73 (if (null buffer)
74 (setq buffer (current-buffer)))
75
76 (check-argument-type 'bufferp buffer)
77
78 (if (and (= beg end)
79 (not (null (extent-property overlay 'evaporate))))
80 (delete-overlay 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
90 (defun delete-overlay (overlay)
91 "Delete the overlay OVERLAY from its buffer."
92 (check-argument-type 'overlayp overlay)
93 (detach-extent overlay)
94 nil)
95
96 (defun overlay-start (overlay)
97 "Return the position at which OVERLAY starts."
98 (check-argument-type 'overlayp overlay)
99 (extent-start-position overlay))
100
101 (defun overlay-end (overlay)
102 "Return the position at which OVERLAY ends."
103 (check-argument-type 'overlayp overlay)
104 (extent-end-position overlay))
105
106 (defun overlay-buffer (overlay)
107 "Return the buffer OVERLAY belongs to."
108 (check-argument-type 'overlayp overlay)
109 (extent-object overlay))
110
111 (defun overlay-properties (overlay)
112 "Return a list of the properties on OVERLAY.
113 This is a copy of OVERLAY's plist; modifying its conses has no effect on
114 OVERLAY."
115 (check-argument-type 'overlayp overlay)
116 (extent-properties overlay))
117
118 (defun overlays-at (pos)
119 "Return a list of the overlays that contain position POS."
120 (overlays-in pos pos))
121
122 (defun overlays-in (beg end)
123 "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
125 and also contained within the specified region.
126 Empty overlays are included in the result if they are located at BEG
127 or between BEG and END."
128 (let (lst)
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
136 (defun next-overlay-change (pos)
137 "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)."
139 (let ((next (point-max))
140 end)
141 (mapcar (function
142 (lambda (overlay)
143 (if (< (setq end (extent-end-position overlay)) next)
144 (setq next end))))
145 (overlays-in pos end))
146 next))
147
148 (defun previous-overlay-change (pos)
149 "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)."
151 (let ((prev (point-min))
152 beg)
153 (mapcar (function
154 (lambda (overlay)
155 (if (and (> (setq beg (extent-start-position overlay)) prev)
156 (< beg pos))
157 (setq prev beg))))
158 (overlays-in prev pos))
159 prev))
160
161 (defun overlay-lists ()
162 "Return a pair of lists giving all the overlays of the current buffer.
163 The car has all the overlays before the overlay center;
164 the cdr has all the overlays after the overlay center.
165 Recentering overlays moves overlays between these lists.
166 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."
168 (if (not (boundp 'xemacs-internal-overlay-center-pos))
169 (overlay-recenter (/ (- (point-max) (point-min)) 2)))
170 (let ((pos xemacs-internal-overlay-center-pos)
171 before after)
172 (mapcar
173 (function
174 (lambda (overlay)
175 (if (extent-property overlay 'overlay)
176 (if (> pos (extent-end-position overlay))
177 (setq before (append before (list overlay)))
178 (setq after (append after (list overlay)))))))
179 (extent-list))
180 (list before after)))
181
182 (defun overlay-recenter (pos)
183 "Recenter the overlays of the current buffer around position POS."
184 (set (make-local-variable 'xemacs-internal-overlay-center-pos) pos))
185
186 (defun overlay-get (overlay prop)
187 "Get the property of overlay OVERLAY with property name PROP."
188 (check-argument-type 'overlayp overlay)
189 (extent-property overlay prop))
190
191 (defun overlay-put (overlay prop value)
192 "Set one property of overlay OVERLAY: give property PROP value VALUE."
193 (check-argument-type 'overlayp overlay)
194 (cond ((eq prop 'evaporate)
195 (set-extent-property overlay 'detachable value))
196 ((eq prop 'before-string)
197 (set-extent-property overlay 'begin-glyph
198 (make-glyph (vector 'string :data value))))
199 ((eq prop 'after-string)
200 (set-extent-property overlay 'end-glyph
201 (make-glyph (vector 'string :data value))))
202 ((memq prop '(window insert-in-front-hooks insert-behind-hooks
203 modification-hooks))
204 (error "cannot support overlay '%s property under XEmacs"
205 prop)))
206 (set-extent-property overlay prop value))
207
208 (provide 'overlay)
209
210 ;;; overlay.el ends here