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 )
