cgit.sxemacs.org Git - packages/blob - xemacs-packages/fsf-compat/overlay.el

   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@xemacs.org> 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 \f
  65 ;;; Code:
  66
  67 ;; Have compiled 21.4 code also work on XEmacs binaries with real support
  68 ;; for multiple values, by avoiding runtime calls to #'values:
  69 (eval-when-compile (when (eq 'list (symbol-function 'values))
  70                      (define-compiler-macro values (&rest args)
  71                        `(list ,@args))))
  72
  73 (defun overlayp (object)
  74   "Return t if OBJECT is an overlay."
  75   (and (extentp object)
  76        (extent-property object 'overlay)))
  77
  78
  79 (defsubst overlay-normalize-pos (pos buffer)
  80   "Return the normalized POS, so 1 <= POS <= \(1+ \(length BUFFER))."
  81   (let ((buffer-min 1)
  82         (buffer-max (1+ (buffer-size buffer))))
  83     (cond ((< pos buffer-min)
  84            buffer-min)
  85           ((> pos buffer-max)
  86            buffer-max)
  87           (t
  88            pos))))
  89
  90 (defsubst overlay-normalize-begin-end-buffer (beg end &optional buffer)
  91   "Normalize BEG and END so that 1 <= BEG <= END <= \(1+ \(length BUFFER)).
  92
  93 If BUFFER is nil, the current buffer is assumed.  If BEG is
  94 greater than END, exchange their value.
  95
  96 Returns values BEG END BUFFER.  See `multiple-value-setq' and
  97 `multiple-value-bind'. "
  98   (check-argument-type #'bufferp (setq buffer (or buffer (current-buffer))))
  99   (setq beg (overlay-normalize-pos beg buffer)
 100         end (overlay-normalize-pos end buffer))
 101   (when (> beg end)
 102     (setq beg (prog1 end (setq end beg))))
 103   (values beg end buffer))
 104
 105 (defun make-overlay (beg end &optional buffer front-advance rear-advance)
 106   "Create a new overlay with range BEG to END in BUFFER.
 107 If omitted, BUFFER defaults to the current buffer.
 108 BEG and END may be integers or markers.
 109 The fourth arg FRONT-ADVANCE, if non-nil, makes the
 110 front delimiter advance when text is inserted there.
 111 The fifth arg REAR-ADVANCE, if non-nil, makes the
 112 rear delimiter advance when text is inserted there.
 113
 114 BEG and END will be normalized so 1 <= BEG <= END <= \(1+ \(length BUFFER)).
 115 If BUFFER is nil, the current buffer is assumed.  If BEG is
 116 greater than END, exchange their value."
 117
 118   (multiple-value-setq
 119       (beg end buffer)
 120     (overlay-normalize-begin-end-buffer beg end buffer))
 121   (let ((overlay (make-extent beg end buffer)))
 122     (set-extent-property overlay 'overlay t)
 123     (if front-advance
 124         (set-extent-property overlay 'start-open t)
 125       (set-extent-property overlay 'start-closed t))
 126     (if rear-advance
 127         (set-extent-property overlay 'end-closed t)
 128       (set-extent-property overlay 'end-open t))
 129     overlay))
 130
 131 (defun move-overlay (overlay beg end &optional buffer)
 132   "Set the endpoints of OVERLAY to BEG and END in BUFFER.
 133 If BUFFER is omitted, leave OVERLAY in the same buffer it inhabits now.
 134 If BUFFER is omitted, and OVERLAY is in no buffer, put it in the current
 135 buffer.
 136
 137
 138 BEG and END will be normalized so 1 <= BEG <= END <= \(1+ \(length BUFFER)).
 139 If BUFFER is nil, the current buffer is assumed.  If BEG is
 140 greater than END, exchange their value."
 141
 142   (check-argument-type 'overlayp overlay)
 143   (if (null buffer)
 144       (setq buffer (extent-object overlay)))
 145   (multiple-value-setq (beg end buffer)
 146     (overlay-normalize-begin-end-buffer beg end buffer))
 147   (check-argument-type 'bufferp buffer)
 148   (and (= beg end)
 149        (extent-property overlay 'evaporate)
 150        (delete-overlay overlay))
 151   (when (> beg end)
 152     (setq beg (prog1 end (setq end beg))))
 153   (set-extent-endpoints overlay beg end buffer)
 154   overlay)
 155
 156 (defun delete-overlay (overlay)
 157   "Delete the overlay OVERLAY from its buffer."
 158   (check-argument-type 'overlayp overlay)
 159   (detach-extent overlay)
 160   nil)
 161
 162 (defun overlay-start (overlay)
 163   "Return the position at which OVERLAY starts."
 164   (check-argument-type 'overlayp overlay)
 165   (extent-start-position overlay))
 166
 167 (defun overlay-end (overlay)
 168   "Return the position at which OVERLAY ends."
 169   (check-argument-type 'overlayp overlay)
 170   (extent-end-position overlay))
 171
 172 (defun overlay-buffer (overlay)
 173   "Return the buffer OVERLAY belongs to."
 174   (check-argument-type 'overlayp overlay)
 175   (extent-object overlay))
 176
 177 (defun overlay-properties (overlay)
 178   "Return a list of the properties on OVERLAY.
 179 This is a copy of OVERLAY's plist; modifying its conses has no effect on
 180 OVERLAY."
 181   (check-argument-type 'overlayp overlay)
 182   (extent-properties overlay))
 183
 184 (defun overlays-at (pos &optional buffer)
 185   "Return a list of the overlays that contain position POS."
 186   (overlays-in pos pos buffer))
 187
 188 (defun overlays-in (beg end &optional buffer)
 189   "Return a list of the overlays that overlap the region BEG ... END.
 190 Overlap means that at least one character is contained within the overlay
 191 and also contained within the specified region.
 192 Empty overlays are included in the result if they are located at BEG
 193 or between BEG and END.
 194
 195 BEG and END will be normalized so 1 <= BEG <= END <= \(1+ \(length CURRENT-BUFFER))."
 196   (setq beg (overlay-normalize-pos beg buffer)
 197         end (overlay-normalize-pos end buffer))
 198   (mapcar-extents #'identity nil nil beg end
 199                   'all-extents-closed-open 'overlay))
 200
 201 (defun next-overlay-change (pos &optional buffer)
 202   "Return the next position after POS where an overlay starts or ends.
 203 If there are no more overlay boundaries after POS, return (point-max).
 204
 205 POS will be normalized  so 1 <= POS <= \(1+ \(length CURRENT-BUFFER))."
 206   (let ((next (point-max buffer))
 207         tmp)
 208     (setq pos (overlay-normalize-pos pos buffer))
 209     (map-extents
 210      (lambda (overlay ignore)
 211             (when (or (and (< (setq tmp (extent-start-position overlay)) next)
 212                            (> tmp pos))
 213                       (and (< (setq tmp (extent-end-position overlay)) next)
 214                            (> tmp pos)))
 215               (setq next tmp))
 216        nil)
 217      nil pos nil nil 'all-extents-closed-open 'overlay)
 218     next))
 219
 220 (defun previous-overlay-change (pos &optional buffer)
 221   "Return the previous position before POS where an overlay starts or ends.
 222 If there are no more overlay boundaries before POS, return (point-min).
 223
 224 POS will be normalized  so 1 <= POS <= \(1+ \(length CURRENT-BUFFER))."
 225   (let ((prev (point-min buffer))
 226         tmp)
 227     (setq pos (overlay-normalize-pos pos buffer))
 228     (map-extents
 229      (lambda (overlay ignore)
 230        (when (or (and (> (setq tmp (extent-end-position overlay)) prev)
 231                       (< tmp pos))
 232                  (and (> (setq tmp (extent-start-position overlay)) prev)
 233                       (< tmp pos)))
 234          (setq prev tmp))
 235        nil)
 236      nil nil pos nil 'all-extents-closed-open 'overlay)
 237     prev))
 238
 239 (defun overlay-lists ()
 240   "Return a pair of lists giving all the overlays of the current buffer.
 241 The car has all the overlays before the overlay center;
 242 the cdr has all the overlays after the overlay center.
 243 Recentering overlays moves overlays between these lists.
 244 The lists you get are copies, so that changing them has no effect.
 245 However, the overlays you get are the real objects that the buffer uses."
 246   (or (boundp 'xemacs-internal-overlay-center-pos)
 247       (overlay-recenter (1+ (/ (- (point-max) (point-min)) 2))))
 248   (let ((pos xemacs-internal-overlay-center-pos)
 249         before after)
 250     (map-extents (lambda (overlay ignore)
 251                    (if (> pos (extent-end-position overlay))
 252                        (push overlay before)
 253                      (push overlay after))
 254                    nil)
 255                  nil nil nil nil 'all-extents-closed-open 'overlay)
 256     (cons (nreverse before) (nreverse after))))
 257
 258 (defun overlay-recenter (pos &optional buffer)
 259   "Recenter the overlays of the current buffer around position POS.
 260
 261 POS will be normalized  so 1 <= POS <= \(1+ \(length CURRENT-BUFFER))."
 262   (setq pos (overlay-normalize-pos pos buffer))
 263   (set (make-local-variable 'xemacs-internal-overlay-center-pos) pos))
 264
 265 (defun overlay-get (overlay prop)
 266   "Get the property of overlay OVERLAY with property name PROP."
 267   (check-argument-type 'overlayp overlay)
 268   (let ((value (extent-property overlay prop))
 269         category)
 270     (if (and (null value)
 271              (setq category (extent-property overlay 'category)))
 272         (get category prop)
 273       value)))
 274
 275 (defun overlay-put (overlay prop value)
 276   "Set one property of overlay OVERLAY: give property PROP value VALUE."
 277   (check-argument-type 'overlayp overlay)
 278   (cond ((eq prop 'evaporate)
 279          (set-extent-property overlay 'detachable value))
 280         ((eq prop 'before-string)
 281          (set-extent-property overlay 'begin-glyph
 282                               (make-glyph (vector 'string :data value))))
 283         ((eq prop 'after-string)
 284          (set-extent-property overlay 'end-glyph
 285                               (make-glyph (vector 'string :data value))))
 286         ((eq prop 'local-map)
 287          (set-extent-property overlay 'keymap value))
 288         ((memq prop '(window insert-in-front-hooks insert-behind-hooks
 289                              modification-hooks))
 290          (error "cannot support overlay '%s property under XEmacs"
 291                 prop)))
 292   (set-extent-property overlay prop value))
 293
 294 (defun copy-overlay (o)
 295   "Return a copy of overlay O."
 296   (let ((o1 (if (overlay-buffer o)
 297                 (make-overlay (overlay-start o) (overlay-end o)
 298                               ;; FIXME: there's no easy way to find the
 299                               ;; insertion-type of the two markers.
 300                               (overlay-buffer o))
 301               (let ((o1 (make-overlay (point-min) (point-min))))
 302                 (delete-overlay o1)
 303                 o1)))
 304         (props (overlay-properties o)))
 305     (while props
 306       (overlay-put o1 (pop props) (pop props)))
 307     o1))
 308
 309 (defun remove-overlays (&optional beg end name val)
 310   "Clear BEG and END of overlays whose property NAME has value VAL.
 311 Overlays might be moved and/or split.
 312 BEG and END default respectively to the beginning and end of buffer."
 313   ;; This speeds up the loops over overlays.
 314   (unless beg (setq beg (point-min)))
 315   (unless end (setq end (point-max)))
 316   (overlay-recenter end)
 317   (if (< end beg)
 318       (setq beg (prog1 end (setq end beg))))
 319   (save-excursion
 320     (dolist (o (overlays-in beg end))
 321       (when (eq (overlay-get o name) val)
 322         ;; Either push this overlay outside beg...end
 323         ;; or split it to exclude beg...end
 324         ;; or delete it entirely (if it is contained in beg...end).
 325         (if (< (overlay-start o) beg)
 326             (if (> (overlay-end o) end)
 327                 (progn
 328                   (move-overlay (copy-overlay o)
 329                                 (overlay-start o) beg)
 330                   (move-overlay o end (overlay-end o)))
 331               (move-overlay o (overlay-start o) beg))
 332           (if (> (overlay-end o) end)
 333               (move-overlay o end (overlay-end o))
 334             (delete-overlay o)))))))
 335
 336
 337 (provide 'overlay)
 338
 339 ;;; overlay.el ends here