|
410
|
1 ;;; compat.el --- Mechanism for non-intrusively providing compatibility funs.
|
|
|
2
|
|
826
|
3 ;; Copyright (C) 2000, 2002 Ben Wing.
|
|
410
|
4
|
|
|
5 ;; Author: Ben Wing <ben@xemacs.org>
|
|
|
6 ;; Maintainer: Ben Wing
|
|
|
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 ;;; Authorship:
|
|
|
29
|
|
|
30 ; Written May 2000 by Ben Wing.
|
|
|
31
|
|
|
32 ;;; Commentary:
|
|
|
33
|
|
826
|
34 ;; The idea is to provide emulation of API's in a namespace-clean way. Lots of packages are filled with declarations such as
|
|
|
35
|
|
|
36 ;; (defalias 'gnus-overlay-get 'extent-property)
|
|
|
37
|
|
|
38 ; There should be a single package to provide such compatibility code. The
|
|
|
39 ; tricky part is how to do it in a clean way, without packages interfering
|
|
|
40 ; with each other.
|
|
|
41
|
|
|
42 ; The basic usage of compat is:
|
|
|
43
|
|
|
44 ; (1) Each package copies compat.el and renames it, e.g. gnus-compat.el.
|
|
|
45
|
|
|
46 ; (2) `compat' defines various API's that can be activated. To use them in a
|
|
|
47 ; file, first place code like this at the top of the file:
|
|
|
48
|
|
|
49 ;(let ((compat-current-package 'Gnus))
|
|
|
50 ; (require 'gnus-compat))
|
|
|
51
|
|
|
52 ; then wrap the rest of the code like this:
|
|
|
53
|
|
|
54 ; (Gnus-compat-wrap '(overlays events)
|
|
|
55
|
|
|
56 ;;; Commentary
|
|
|
57
|
|
|
58 ;; blah
|
|
|
59
|
|
|
60 ;;; Code
|
|
|
61
|
|
|
62 ;(defun random-module-my-fun (bar baz)
|
|
|
63 ; ...
|
|
|
64 ; (overlay-put overlay 'face 'bold)
|
|
|
65 ; ...
|
|
|
66 ;)
|
|
|
67 ;
|
|
|
68 ;(defun ...
|
|
|
69 ;)
|
|
|
70 ;
|
|
|
71 ;
|
|
|
72 ;
|
|
|
73 ;
|
|
|
74 ;) ;; end of (Gnus-compat)
|
|
|
75
|
|
|
76 ;;;; random-module.el ends here
|
|
|
77
|
|
|
78 ; (3) What this does is implement the requested API's (in this case, the
|
|
|
79 ; overlay API from GNU Emacs and event API from XEmacs) in whichever
|
|
|
80 ; version of Emacs is running, with names such as
|
|
|
81 ; `Gnus-compat-overlay-put', and then it uses `macrolet' to map the
|
|
|
82 ; generic names in the wrapped code into namespace-clean names. The
|
|
|
83 ; result of loading `gnus-compat' leaves around only functions beginning
|
|
|
84 ; with `Gnus-compat' (or whatever prefix was specified in
|
|
|
85 ; `compat-current-package'). This way, various packages, with various
|
|
|
86 ; versions of `compat' as part of them, can coexist, with each package
|
|
|
87 ; running the version of `compat' that it's been tested with. The use of
|
|
|
88 ; `macrolet' ensures that only code that's lexically wrapped -- not code
|
|
|
89 ; that's called from that code -- is affected by the API mapping.
|
|
|
90
|
|
410
|
91 ;; Typical usage:
|
|
|
92
|
|
|
93 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
94 ;; 1. Wrap modules that define compatibility functions like this: ;;
|
|
|
95 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
96
|
|
|
97 ;(compat-define-group 'fsf-compat)
|
|
|
98
|
|
|
99 ;(compat-define-functions 'fsf-compat
|
|
|
100
|
|
826
|
101 ;(defun overlay-put (overlay prop value)
|
|
|
102 ; "Set property PROP to VALUE in overlay OVERLAY."
|
|
|
103 ; (set-extent-property overlay prop value))
|
|
410
|
104
|
|
|
105 ;(defun make-overlay (beg end &optional buffer front-advance rear-advance)
|
|
|
106 ; ...)
|
|
|
107
|
|
|
108 ;...
|
|
|
109
|
|
|
110 ;) ;; end of (compat-define-group 'fsf-compat)
|
|
|
111
|
|
|
112 ;;;; overlay.el ends here
|
|
|
113
|
|
|
114
|
|
|
115 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
116 ;; 2. Wrap modules that use the compatibility functions like this: ;;
|
|
|
117 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
118
|
|
826
|
119 ;(let ((compat-current-package 'gnus))
|
|
|
120 ; (require 'gnus-compat))
|
|
|
121 ;
|
|
|
122 ;(gnus-compat 'fsf-compat
|
|
|
123 ;
|
|
|
124 ;; Code:
|
|
|
125 ;;
|
|
|
126 ;;
|
|
410
|
127 ;(defun random-module-my-fun (bar baz)
|
|
826
|
128 ; ...
|
|
|
129 ; (overlay-put overlay 'face 'bold)
|
|
|
130 ; ...
|
|
|
131 ;)
|
|
|
132 ;
|
|
|
133 ;(defun ...
|
|
|
134 ;)
|
|
|
135 ;
|
|
|
136 ;
|
|
|
137 ;
|
|
|
138 ;
|
|
410
|
139 ;) ;; end of (compat 'fsf-compat)
|
|
|
140
|
|
|
141 ;;;; random-module.el ends here
|
|
|
142
|
|
826
|
143 (defvar compat-current-package)
|
|
|
144
|
|
|
145 (eval-when-compile
|
|
|
146 (setq compat-current-package 'compat))
|
|
|
147
|
|
|
148 ;; #### not yet working
|
|
|
149 '(
|
|
|
150
|
|
|
151 (defmacro compat-define-compat-functions (&rest body)
|
|
|
152 "Define the functions of the `compat' package in a namespace-clean way.
|
|
|
153 This relies on `compat-current-package' being set. If `compat-current-package'
|
|
|
154 is equal to the symbol `foo', and within BODY is something like
|
|
|
155
|
|
|
156 \(defmacro compat-define-group (group)
|
|
|
157 ...
|
|
|
158 )
|
|
|
159
|
|
|
160 then this turns into
|
|
|
161
|
|
|
162 \(defmacro foo-compat-define-group (group)
|
|
|
163 ...
|
|
|
164 )
|
|
|
165
|
|
|
166 and all calls are replaced accordingly.
|
|
|
167
|
|
|
168
|
|
|
169
|
|
|
170
|
|
|
171 Functions such as
|
|
|
172 compatibility functions in GROUP.
|
|
|
173 You should simply wrap this around the code that defines the functions.
|
|
|
174 Any functions and macros defined at top level using `defun' or `defmacro'
|
|
|
175 will be noticed and added to GROUP. Other top-level code will be executed
|
|
|
176 normally. All code and definitions in this group can safely reference any
|
|
|
177 other functions in this group -- the code is effectively wrapped in a
|
|
|
178 `compat' call. You can call `compat-define-functions' more than once, if
|
|
|
179 necessary, for a single group.
|
|
|
180
|
|
|
181 What actually happens is that the functions and macros defined here are in
|
|
|
182 fact defined using names prefixed with GROUP. To use these functions,
|
|
|
183 wrap any calling code with the `compat' macro, which lexically renames
|
|
|
184 the function and macro calls appropriately."
|
|
|
185 (let ((prefix (if (boundp 'compat-current-package)
|
|
|
186 compat-current-package
|
|
|
187 (error
|
|
|
188 "`compat-current-package' must be defined when loading this module")))
|
|
|
189 (defs-to-munge '(defun defmacro))
|
|
|
190 mappings)
|
|
|
191 (if (symbolp prefix) (setq prefix (symbol-name prefix)))
|
|
|
192 ;; first, note all defuns and defmacros
|
|
|
193 (let (fundef
|
|
|
194 (body-tail body))
|
|
|
195 (while body-tail
|
|
|
196 (setq fundef (car body-tail))
|
|
|
197 (when (and (consp fundef) (memq (car fundef) defs-to-munge))
|
|
|
198 (push (cons (second fundef) (third fundef)) mappings))
|
|
|
199 (setq body-tail (cdr body-tail))))
|
|
|
200 ;; now, munge the definitions with the new names
|
|
|
201 (let (fundef
|
|
|
202 (body-tail body)
|
|
|
203 result
|
|
|
204 defs)
|
|
|
205 (while body-tail
|
|
|
206 (setq fundef (car body-tail))
|
|
|
207 (push
|
|
|
208 (cond ((and (consp fundef) (memq (car fundef) defs-to-munge))
|
|
|
209 (nconc (list (car fundef)
|
|
|
210 (intern (concat prefix "-"
|
|
|
211 (symbol-name (second fundef))))
|
|
|
212 (third fundef))
|
|
|
213 (nthcdr 3 fundef)))
|
|
|
214 (t fundef))
|
|
|
215 result)
|
|
|
216 (setq body-tail (cdr body-tail)))
|
|
|
217 (setq result (nreverse result))
|
|
|
218 ;; now, generate the munged code, with the references to the functions
|
|
|
219 ;; macroletted
|
|
|
220 (mapc
|
|
|
221 #'(lambda (acons)
|
|
|
222 (let ((fun (car acons))
|
|
|
223 (args (cdr acons)))
|
|
|
224 (push
|
|
|
225 (list fun args
|
|
|
226 (nconc
|
|
|
227 (list 'list
|
|
|
228 (list 'quote
|
|
|
229 (intern (concat prefix "-"
|
|
|
230 (symbol-name fun)))))
|
|
|
231 args))
|
|
|
232 defs)))
|
|
|
233 mappings)
|
|
|
234 ;; it would be cleaner to use `lexical-let' instead of `let', but that
|
|
|
235 ;; causes function definitions to have obnoxious, unreadable junk in
|
|
|
236 ;; them. #### Move `lexical-let' into C!!!
|
|
|
237 `(macrolet ((compat-current-package () ,compat-current-package)
|
|
|
238 ,@defs)
|
|
|
239 ,@result))))
|
|
|
240
|
|
|
241 (compat-define-compat-functions
|
|
410
|
242
|
|
|
243 (defun compat-hash-table (group)
|
|
|
244 (get group 'compat-table))
|
|
|
245
|
|
|
246 (defun compat-make-hash-table (group)
|
|
|
247 (put group 'compat-table (make-hash-table)))
|
|
|
248
|
|
826
|
249 (defmacro compat-define-group (group &rest body)
|
|
410
|
250 "Define GROUP as a group of compatibility functions.
|
|
826
|
251 This macro should wrap individual Individual functions are defined using `compat-define-functions'.
|
|
410
|
252 Once defined, the functions can be used by wrapping your code in the
|
|
|
253 `compat' macro.
|
|
|
254
|
|
|
255 If GROUP is already defined, nothing happens."
|
|
|
256 (let ((group (eval group)))
|
|
|
257 (or (hash-table-p (compat-hash-table group))
|
|
|
258 (compat-make-hash-table group))))
|
|
|
259
|
|
|
260 (defmacro compat-clear-functions (group)
|
|
|
261 "Clear all defined functions and macros out of GROUP."
|
|
|
262 (let ((group (eval group)))
|
|
|
263 (clrhash (compat-hash-table group))))
|
|
|
264
|
|
826
|
265 (defmacro compat-defun (args &rest body)
|
|
|
266
|
|
|
267 (defmacro compat-define-function (props name arglist &rest body)
|
|
|
268 "Define a compatibility function.
|
|
|
269 PROPS are properties controlling how the function should be defined.
|
|
|
270 control how the should simply wrap this around the code that defines the functions.
|
|
410
|
271 Any functions and macros defined at top level using `defun' or `defmacro'
|
|
|
272 will be noticed and added to GROUP. Other top-level code will be executed
|
|
|
273 normally. All code and definitions in this group can safely reference any
|
|
|
274 other functions in this group -- the code is effectively wrapped in a
|
|
|
275 `compat' call. You can call `compat-define-functions' more than once, if
|
|
|
276 necessary, for a single group.
|
|
|
277
|
|
|
278 What actually happens is that the functions and macros defined here are in
|
|
|
279 fact defined using names prefixed with GROUP. To use these functions,
|
|
|
280 wrap any calling code with the `compat' macro, which lexically renames
|
|
|
281 the function and macro calls appropriately."
|
|
826
|
282 (let ((group (eval group))
|
|
|
283 (defs-to-munge '(defun defmacro))
|
|
|
284 )
|
|
410
|
285 (let (fundef
|
|
|
286 (body-tail body))
|
|
|
287 (while body-tail
|
|
|
288 (setq fundef (car body-tail))
|
|
826
|
289 (when (and (consp fundef) (memq (car fundef) defs-to-munge))
|
|
410
|
290 (puthash (second fundef) (third fundef) (compat-hash-table group)))
|
|
|
291 (setq body-tail (cdr body-tail))))
|
|
|
292 (let (fundef
|
|
|
293 (body-tail body)
|
|
|
294 result)
|
|
|
295 (while body-tail
|
|
|
296 (setq fundef (car body-tail))
|
|
|
297 (push
|
|
826
|
298 (cond ((and (consp fundef) (memq (car fundef) defs-to-munge))
|
|
|
299 (nconc (list (car fundef)
|
|
410
|
300 (intern (concat (symbol-name group) "-"
|
|
|
301 (symbol-name (second fundef))))
|
|
|
302 (third fundef))
|
|
|
303 (nthcdr 3 fundef)))
|
|
|
304 (t fundef))
|
|
|
305 result)
|
|
|
306 (setq body-tail (cdr body-tail)))
|
|
826
|
307 (nconc (list 'compat-wrap (list 'quote group)) (nreverse result)))))
|
|
410
|
308
|
|
|
309 (defvar compat-active-groups nil)
|
|
|
310
|
|
|
311 (defun compat-fboundp (groups fun)
|
|
|
312 "T if FUN is either `fboundp' or one of the compatibility funs in GROUPS.
|
|
|
313 GROUPS is a list of compatibility groups as defined using
|
|
|
314 `compat-define-group'."
|
|
|
315 (or (fboundp fun)
|
|
|
316 (block nil
|
|
|
317 (mapcar #'(lambda (group)
|
|
|
318 (if (gethash fun (compat-hash-table group))
|
|
|
319 (return t)))
|
|
|
320 groups))))
|
|
|
321
|
|
826
|
322 (defmacro compat-wrap-runtime (groups &rest body))
|
|
|
323
|
|
|
324 (defmacro compat-wrap (groups &rest body)
|
|
|
325 "Make use of compatibility functions and macros in GROUPS.
|
|
|
326 GROUPS is a symbol, an API group, or list of API groups. Each API group
|
|
|
327 defines a set of functions, macros, variables, etc. and that will (or
|
|
|
328 should ideally) work on all recent versions of both GNU Emacs and XEmacs,
|
|
|
329 and (to some extent, depending on how the functions were designed) on older
|
|
|
330 version. When this function is used, it will generally not be named
|
|
|
331 `compat-wrap', but have some name such as `Gnus-compat-wrap', if this is
|
|
|
332 wrapping something in `gnus'. (The renaming happened when the `compat'
|
|
|
333 package was loaded -- see discussion at top).
|
|
|
334
|
|
|
335 To use `compat' in your package (assume your package is `gnus'), you first
|
|
|
336 have to do a bit if setup.
|
|
|
337
|
|
|
338 -- Copy and rename compat.el, e.g. to `gnus-compat.el'. The name must be
|
|
|
339 globally unique across everything on the load path (that means all
|
|
|
340 packages).
|
|
|
341 -- Incude this file in your package. It will not interfere with any other
|
|
|
342 versions of compat (earlier, later, etc.) provided in other packages
|
|
|
343 and similarly renamed.
|
|
|
344
|
|
|
345 To make use of the API's provided:
|
|
|
346
|
|
|
347 -- First place code like this at the top of the file, after the copyright
|
|
|
348 notices and comments:
|
|
|
349
|
|
|
350 \(let ((compat-current-package 'Gnus))
|
|
|
351 (require 'gnus-compat))
|
|
|
352
|
|
|
353 -- then wrap the rest of the code like this, assuming you want access to
|
|
|
354 the GNU Emacs overlays API, and the XEmacs events API:
|
|
|
355
|
|
|
356 \(Gnus-compat-wrap '(overlays xem-events)
|
|
|
357
|
|
|
358 ...
|
|
|
359 ...
|
|
|
360 ...
|
|
|
361
|
|
|
362 \(defun gnus-random-fun (overlay baz)
|
|
|
363 ...
|
|
|
364 (overlay-put overlay 'face 'bold)
|
|
|
365 ...
|
|
|
366 )
|
|
|
367
|
|
|
368 ...
|
|
|
369 ...
|
|
|
370
|
|
|
371 \(defun gnus-random-fun-2 (event)
|
|
|
372 (interactive "e")
|
|
|
373 (let ((x (event-x event))
|
|
|
374 (y (event-y event)))
|
|
|
375 ...
|
|
|
376 )
|
|
|
377 )
|
|
|
378
|
|
|
379 ) ;; end of (Gnus-compat)
|
|
|
380
|
|
|
381 ;;;; random-module.el ends here
|
|
|
382
|
|
|
383 Both the requested API's will be implemented whichever version of Emacs
|
|
|
384 \(GNU Emacs, XEmacs, etc.) is running, and (with limitations) on older
|
|
|
385 versions as well. Furthermore, the API's are provided *ONLY* to code
|
|
|
386 that's actually, lexically wrapped by `compat-wrap' (or its renamed
|
|
|
387 version). All other code, including code that's called by the wrapped
|
|
|
388 code, is not affected -- e.g. if we're on XEmacs, and `overlay-put' isn't
|
|
|
389 normally defined, then it won't be defined in code other than the wrapped
|
|
|
390 code, even if the wrapped code calls that code. Clever, huh?
|
|
|
391
|
|
|
392 What happens is that the `compat-wrap' actually uses `macrolet' to
|
|
|
393 inline-substitute calls to `overlay-put' to (in this case)
|
|
|
394 `Gnus-compat-overlay-put', which was defined when `gnus-compat' was loaded.
|
|
|
395
|
|
|
396 What happens is that is implement the requested API's (in this case, the
|
|
|
397 overlay API from GNU Emacs and event API from XEmacs) in whichever
|
|
|
398 version of Emacs is running, with names such as
|
|
|
399 `Gnus-compat-overlay-put', and then it uses `macrolet' to map the
|
|
|
400 generic names in the wrapped code into namespace-clean names. The
|
|
|
401 result of loading `gnus-compat' leaves around only functions beginning
|
|
|
402 with `Gnus-compat' (or whatever prefix was specified in
|
|
|
403 `compat-current-package'). This way, various packages, with various
|
|
|
404 versions of `compat' as part of them, can coexist, with each package
|
|
|
405 running the version of `compat' that it's been tested with. The use of
|
|
|
406 `macrolet' ensures that only code that's lexically wrapped -- not code
|
|
|
407 that's called from that code -- is affected by the API mapping.
|
|
|
408
|
|
|
409 Before using `compat'
|
|
|
410
|
|
|
411 For any file where you want to make use of one or more API's provided by
|
|
|
412 `compat', first do this:
|
|
|
413
|
|
|
414 Wrap a call to `compat-wrap' around your entire file, like this:
|
|
|
415
|
|
|
416 ;; First, you copied compat.el into your package -- we're assuming \"gnus\" --
|
|
|
417 ;; and renamed it, e.g. gnus-compat.el. Now we load it and tell it to
|
|
|
418 ;; use `Gnus' as the prefix for all stuff it defines. (Use a capital letter
|
|
|
419 ;; or some similar convention so that these names are not so easy to see.)
|
|
|
420
|
|
|
421 \(let ((current-compat-package 'Gnus))
|
|
|
422 (require 'gnus-compat))
|
|
|
423
|
|
|
424 ;; The function `compat-wrap' was mapped to `Gnus-compat-wrap'. The idea
|
|
|
425 ;; is that the raw functions beginning with `compat-' are never actually
|
|
|
426 ;; defined. They may appear as function calls inside of functions, but
|
|
|
427 ;; they will always be mapped to something beginning with the given prefix.
|
|
|
428
|
|
|
429 \(Gnus-compat-wrap '(overlays xem-events)
|
|
|
430
|
|
|
431 ...
|
|
|
432
|
|
|
433 )
|
|
|
434
|
|
410
|
435 You should simply wrap this around the code that uses the functions
|
|
826
|
436 and macros in GROUPS. Typically, a call to `compat' should be placed
|
|
410
|
437 at the top of an ELisp module, with the closing parenthesis at the
|
|
|
438 bottom; use this in place of a `require' statement. Wrapped code can
|
|
|
439 be either function or macro definitions or other ELisp code, and
|
|
|
440 wrapped function or macro definitions need not be at top level. All
|
|
|
441 calls to the compatibility functions or macros will be noticed anywhere
|
|
|
442 within the wrapped code. Calls to `fboundp' within the wrapped code
|
|
|
443 will also behave correctly when called on compatibility functions and
|
|
|
444 macros, even though they would return nil elsewhere (including in code
|
|
|
445 in other modules called dynamically from the wrapped code).
|
|
|
446
|
|
|
447 The functions and macros define in GROUP are actually defined under
|
|
|
448 prefixed names, to avoid namespace clashes and bad interactions with
|
|
|
449 other code that calls `fboundp'. All calls inside of the wrapped code
|
|
|
450 to the compatibility functions and macros in GROUP are lexically
|
|
|
451 mapped to the prefixed names. Since this is a lexical mapping, code
|
|
|
452 in other modules that is called by functions in this module will not
|
|
|
453 be affected."
|
|
|
454 (let ((group (eval group))
|
|
|
455 defs)
|
|
|
456 (maphash
|
|
|
457 #'(lambda (fun args)
|
|
|
458 (push
|
|
|
459 (list fun args
|
|
|
460 (nconc
|
|
|
461 (list 'list
|
|
|
462 (list 'quote
|
|
|
463 (intern (concat (symbol-name group) "-"
|
|
|
464 (symbol-name fun)))))
|
|
|
465 args))
|
|
|
466 defs))
|
|
|
467 (compat-hash-table group))
|
|
|
468 ;; it would be cleaner to use `lexical-let' instead of `let', but that
|
|
|
469 ;; causes function definitions to have obnoxious, unreadable junk in
|
|
|
470 ;; them. #### Move `lexical-let' into C!!!
|
|
|
471 `(let ((compat-active-groups (cons ',group compat-active-groups)))
|
|
|
472 (macrolet ((fboundp (fun) `(compat-fboundp ',compat-active-groups ,fun))
|
|
|
473 ,@defs)
|
|
|
474 ,@body))))
|
|
826
|
475
|
|
|
476 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
477 ;; Define the compat groups ;;
|
|
|
478 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
479
|
|
|
480 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; overlays ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
481
|
|
|
482 (compat-define-group 'overlays
|
|
|
483
|
|
|
484 (defun-compat overlayp (object)
|
|
|
485 "Return t if OBJECT is an overlay."
|
|
|
486 (and (extentp object)
|
|
|
487 (extent-property object 'overlay)))
|
|
|
488
|
|
|
489 (defun-compat make-overlay (beg end &optional buffer front-advance rear-advance)
|
|
|
490 "Create a new overlay with range BEG to END in BUFFER.
|
|
|
491 If omitted, BUFFER defaults to the current buffer.
|
|
|
492 BEG and END may be integers or markers.
|
|
|
493 The fourth arg FRONT-ADVANCE, if non-nil, makes the
|
|
|
494 front delimiter advance when text is inserted there.
|
|
|
495 The fifth arg REAR-ADVANCE, if non-nil, makes the
|
|
|
496 rear delimiter advance when text is inserted there."
|
|
|
497 (if (null buffer)
|
|
|
498 (setq buffer (current-buffer))
|
|
|
499 (check-argument-type 'bufferp buffer))
|
|
|
500 (when (> beg end)
|
|
|
501 (setq beg (prog1 end (setq end beg))))
|
|
|
502
|
|
|
503 (let ((overlay (make-extent beg end buffer)))
|
|
|
504 (set-extent-property overlay 'overlay t)
|
|
|
505 (if front-advance
|
|
|
506 (set-extent-property overlay 'start-open t)
|
|
|
507 (set-extent-property overlay 'start-closed t))
|
|
|
508 (if rear-advance
|
|
|
509 (set-extent-property overlay 'end-closed t)
|
|
|
510 (set-extent-property overlay 'end-open t))
|
|
|
511
|
|
|
512 overlay))
|
|
|
513
|
|
|
514 (defun-compat move-overlay (overlay beg end &optional buffer)
|
|
|
515 "Set the endpoints of OVERLAY to BEG and END in BUFFER.
|
|
|
516 If BUFFER is omitted, leave OVERLAY in the same buffer it inhabits now.
|
|
|
517 If BUFFER is omitted, and OVERLAY is in no buffer, put it in the current
|
|
|
518 buffer."
|
|
|
519 (check-argument-type 'overlayp overlay)
|
|
|
520 (if (null buffer)
|
|
|
521 (setq buffer (extent-object overlay)))
|
|
|
522 (if (null buffer)
|
|
|
523 (setq buffer (current-buffer)))
|
|
|
524 (check-argument-type 'bufferp buffer)
|
|
|
525 (and (= beg end)
|
|
|
526 (extent-property overlay 'evaporate)
|
|
|
527 (delete-overlay overlay))
|
|
|
528 (when (> beg end)
|
|
|
529 (setq beg (prog1 end (setq end beg))))
|
|
|
530 (set-extent-endpoints overlay beg end buffer)
|
|
|
531 overlay)
|
|
|
532
|
|
|
533 (defun-compat delete-overlay (overlay)
|
|
|
534 "Delete the overlay OVERLAY from its buffer."
|
|
|
535 (check-argument-type 'overlayp overlay)
|
|
|
536 (detach-extent overlay)
|
|
|
537 nil)
|
|
|
538
|
|
|
539 (defun-compat overlay-start (overlay)
|
|
|
540 "Return the position at which OVERLAY starts."
|
|
|
541 (check-argument-type 'overlayp overlay)
|
|
|
542 (extent-start-position overlay))
|
|
|
543
|
|
|
544 (defun-compat overlay-end (overlay)
|
|
|
545 "Return the position at which OVERLAY ends."
|
|
|
546 (check-argument-type 'overlayp overlay)
|
|
|
547 (extent-end-position overlay))
|
|
|
548
|
|
|
549 (defun-compat overlay-buffer (overlay)
|
|
|
550 "Return the buffer OVERLAY belongs to."
|
|
|
551 (check-argument-type 'overlayp overlay)
|
|
|
552 (extent-object overlay))
|
|
|
553
|
|
|
554 (defun-compat overlay-properties (overlay)
|
|
|
555 "Return a list of the properties on OVERLAY.
|
|
|
556 This is a copy of OVERLAY's plist; modifying its conses has no effect on
|
|
|
557 OVERLAY."
|
|
|
558 (check-argument-type 'overlayp overlay)
|
|
|
559 (extent-properties overlay))
|
|
|
560
|
|
|
561 (defun-compat overlays-at (pos)
|
|
|
562 "Return a list of the overlays that contain position POS."
|
|
|
563 (overlays-in pos pos))
|
|
|
564
|
|
|
565 (defun-compat overlays-in (beg end)
|
|
|
566 "Return a list of the overlays that overlap the region BEG ... END.
|
|
|
567 Overlap means that at least one character is contained within the overlay
|
|
|
568 and also contained within the specified region.
|
|
|
569 Empty overlays are included in the result if they are located at BEG
|
|
|
570 or between BEG and END."
|
|
|
571 (if (featurep 'xemacs)
|
|
|
572 (mapcar-extents #'identity nil nil beg end
|
|
|
573 'all-extents-closed-open 'overlay)
|
|
|
574 (let ((ovls (overlay-lists))
|
|
|
575 tmp retval)
|
|
|
576 (if (< end beg)
|
|
|
577 (setq tmp end
|
|
|
578 end beg
|
|
|
579 beg tmp))
|
|
|
580 (setq ovls (nconc (car ovls) (cdr ovls)))
|
|
|
581 (while ovls
|
|
|
582 (setq tmp (car ovls)
|
|
|
583 ovls (cdr ovls))
|
|
|
584 (if (or (and (<= (overlay-start tmp) end)
|
|
|
585 (>= (overlay-start tmp) beg))
|
|
|
586 (and (<= (overlay-end tmp) end)
|
|
|
587 (>= (overlay-end tmp) beg)))
|
|
|
588 (setq retval (cons tmp retval))))
|
|
|
589 retval)))
|
|
|
590
|
|
|
591 (defun-compat next-overlay-change (pos)
|
|
|
592 "Return the next position after POS where an overlay starts or ends.
|
|
|
593 If there are no more overlay boundaries after POS, return (point-max)."
|
|
|
594 (let ((next (point-max))
|
|
|
595 tmp)
|
|
|
596 (map-extents
|
|
|
597 (lambda (overlay ignore)
|
|
|
598 (when (or (and (< (setq tmp (extent-start-position overlay)) next)
|
|
|
599 (> tmp pos))
|
|
|
600 (and (< (setq tmp (extent-end-position overlay)) next)
|
|
|
601 (> tmp pos)))
|
|
|
602 (setq next tmp))
|
|
|
603 nil)
|
|
|
604 nil pos nil nil 'all-extents-closed-open 'overlay)
|
|
|
605 next))
|
|
|
606
|
|
|
607 (defun-compat previous-overlay-change (pos)
|
|
|
608 "Return the previous position before POS where an overlay starts or ends.
|
|
|
609 If there are no more overlay boundaries before POS, return (point-min)."
|
|
|
610 (let ((prev (point-min))
|
|
|
611 tmp)
|
|
|
612 (map-extents
|
|
|
613 (lambda (overlay ignore)
|
|
|
614 (when (or (and (> (setq tmp (extent-end-position overlay)) prev)
|
|
|
615 (< tmp pos))
|
|
|
616 (and (> (setq tmp (extent-start-position overlay)) prev)
|
|
|
617 (< tmp pos)))
|
|
|
618 (setq prev tmp))
|
|
|
619 nil)
|
|
|
620 nil nil pos nil 'all-extents-closed-open 'overlay)
|
|
|
621 prev))
|
|
|
622
|
|
|
623 (defun-compat overlay-lists ()
|
|
|
624 "Return a pair of lists giving all the overlays of the current buffer.
|
|
|
625 The car has all the overlays before the overlay center;
|
|
|
626 the cdr has all the overlays after the overlay center.
|
|
|
627 Recentering overlays moves overlays between these lists.
|
|
|
628 The lists you get are copies, so that changing them has no effect.
|
|
|
629 However, the overlays you get are the real objects that the buffer uses."
|
|
|
630 (or (boundp 'xemacs-internal-overlay-center-pos)
|
|
|
631 (overlay-recenter (1+ (/ (- (point-max) (point-min)) 2))))
|
|
|
632 (let ((pos xemacs-internal-overlay-center-pos)
|
|
|
633 before after)
|
|
|
634 (map-extents (lambda (overlay ignore)
|
|
|
635 (if (> pos (extent-end-position overlay))
|
|
|
636 (push overlay before)
|
|
|
637 (push overlay after))
|
|
|
638 nil)
|
|
|
639 nil nil nil nil 'all-extents-closed-open 'overlay)
|
|
|
640 (cons (nreverse before) (nreverse after))))
|
|
|
641
|
|
|
642 (defun-compat overlay-recenter (pos)
|
|
|
643 "Recenter the overlays of the current buffer around position POS."
|
|
|
644 (set (make-local-variable 'xemacs-internal-overlay-center-pos) pos))
|
|
|
645
|
|
|
646 (defun-compat overlay-get (overlay prop)
|
|
|
647 "Get the property of overlay OVERLAY with property name PROP."
|
|
|
648 (check-argument-type 'overlayp overlay)
|
|
|
649 (let ((value (extent-property overlay prop))
|
|
|
650 category)
|
|
|
651 (if (and (null value)
|
|
|
652 (setq category (extent-property overlay 'category)))
|
|
|
653 (get category prop)
|
|
|
654 value)))
|
|
|
655
|
|
|
656 (defun-compat overlay-put (overlay prop value)
|
|
|
657 "Set one property of overlay OVERLAY: give property PROP value VALUE."
|
|
|
658 (check-argument-type 'overlayp overlay)
|
|
|
659 (cond ((eq prop 'evaporate)
|
|
|
660 (set-extent-property overlay 'detachable value))
|
|
|
661 ((eq prop 'before-string)
|
|
|
662 (set-extent-property overlay 'begin-glyph
|
|
|
663 (make-glyph (vector 'string :data value))))
|
|
|
664 ((eq prop 'after-string)
|
|
|
665 (set-extent-property overlay 'end-glyph
|
|
|
666 (make-glyph (vector 'string :data value))))
|
|
|
667 ((eq prop 'local-map)
|
|
|
668 (set-extent-property overlay 'keymap value))
|
|
|
669 ((memq prop '(window insert-in-front-hooks insert-behind-hooks
|
|
|
670 modification-hooks))
|
|
|
671 (error "cannot support overlay '%s property under XEmacs"
|
|
|
672 prop)))
|
|
|
673 (set-extent-property overlay prop value))
|
|
|
674 )
|
|
|
675
|
|
|
676 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; extents ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
677
|
|
|
678 (defalias-compat 'delete-extent 'delete-overlay)
|
|
|
679 (defalias-compat 'extent-end-position 'overlay-end)
|
|
|
680 (defalias-compat 'extent-start-position 'overlay-start)
|
|
|
681 (defalias-compat 'set-extent-endpoints 'move-overlay)
|
|
|
682 (defalias-compat 'set-extent-property 'overlay-put)
|
|
|
683 (defalias-compat 'make-extent 'make-overlay)
|
|
|
684
|
|
|
685 (defun-compat extent-property (extent property &optional default)
|
|
|
686 (or (overlay-get extent property) default))
|
|
|
687
|
|
|
688 (defun-compat extent-at (pos &optional object property before at-flag)
|
|
|
689 (let ((tmp (overlays-at (point)))
|
|
|
690 ovls)
|
|
|
691 (if property
|
|
|
692 (while tmp
|
|
|
693 (if (extent-property (car tmp) property)
|
|
|
694 (setq ovls (cons (car tmp) ovls)))
|
|
|
695 (setq tmp (cdr tmp)))
|
|
|
696 (setq ovls tmp
|
|
|
697 tmp nil))
|
|
|
698 (car-safe
|
|
|
699 (sort ovls
|
|
|
700 (function
|
|
|
701 (lambda (a b)
|
|
|
702 (< (- (extent-end-position a) (extent-start-position a))
|
|
|
703 (- (extent-end-position b) (extent-start-position b)))))))))
|
|
|
704
|
|
|
705 (defun-compat map-extents (function &optional object from to
|
|
|
706 maparg flags property value)
|
|
|
707 (let ((tmp (overlays-in (or from (point-min))
|
|
|
708 (or to (point-max))))
|
|
|
709 ovls)
|
|
|
710 (if property
|
|
|
711 (while tmp
|
|
|
712 (if (extent-property (car tmp) property)
|
|
|
713 (setq ovls (cons (car tmp) ovls)))
|
|
|
714 (setq tmp (cdr tmp)))
|
|
|
715 (setq ovls tmp
|
|
|
716 tmp nil))
|
|
|
717 (catch 'done
|
|
|
718 (while ovls
|
|
|
719 (setq tmp (funcall function (car ovls) maparg)
|
|
|
720 ovls (cdr ovls))
|
|
|
721 (if tmp
|
|
|
722 (throw 'done tmp))))))
|
|
|
723
|
|
|
724 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; extents ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
725
|
|
|
726
|
|
|
727 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; events ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
728
|
|
|
729 ) ;; group overlays
|
|
|
730
|
|
|
731 ) ;; compat-define-compat-functions
|
|
|
732
|
|
|
733 (fmakunbound 'compat-define-compat-functions)
|
|
|
734
|
|
|
735 ) |
